diff --git a/physics/GFS_DCNV_generic.F90 b/physics/GFS_DCNV_generic.F90 index f03e1d298..e7dec5ca1 100644 --- a/physics/GFS_DCNV_generic.F90 +++ b/physics/GFS_DCNV_generic.F90 @@ -17,7 +17,7 @@ end subroutine GFS_DCNV_generic_pre_finalize !! subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplchm, & gu0, gv0, gt0, gq0, nsamftrac, ntqv, & - save_u, save_v, save_t, save_q, dqdti, clw, & + save_u, save_v, save_t, save_q, clw, & ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl, & ntgnc, cscnv, satmedmf, trans_trac, ras, ntrac, & dtidx, index_of_process_dcnv, errmsg, errflg) @@ -37,8 +37,6 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc real(kind=kind_phys), dimension(:,:), intent(inout) :: save_v real(kind=kind_phys), dimension(:,:), intent(inout) :: save_t real(kind=kind_phys), dimension(:,:,:), intent(inout) :: save_q - ! dqdti only allocated if cplchm is .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg logical, intent(in) :: cscnv, satmedmf, trans_trac, ras @@ -90,10 +88,6 @@ subroutine GFS_DCNV_generic_pre_run (im, levs, ldiag3d, qdiag3d, do_cnvgwd, cplc save_q(:,:,ntqv) = gq0(:,:,ntqv) endif - if (cplchm) then - dqdti = zero - endif - end subroutine GFS_DCNV_generic_pre_run end module GFS_DCNV_generic_pre diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 97781f216..45368a2e7 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -143,15 +143,6 @@ kind = kind_phys intent = in optional = F -[dqdti] - 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_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [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 diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 9470caa2b..239aded39 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -84,7 +84,7 @@ end subroutine GFS_MP_generic_post_init !! !> \section gfs_mp_gen GFS MP Generic Post General Algorithm !> @{ - subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & + subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, & imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, con_g, 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, & @@ -98,7 +98,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, implicit none - integer, intent(in) :: im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac + integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm integer, intent(in) :: index_of_temperature,index_of_process_mp @@ -383,7 +383,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, do i=1, im work1(i) = zero enddo - if (ncld > 0) then + if (nncl > 0) then do ic = ntcw, ntcw+nncl-1 do i=1,im work1(i) = work1(i) + gq0(i,k,ic) diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 816441086..190fedf84 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -56,8 +56,8 @@ intent = in optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer @@ -167,17 +167,9 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = choice of cloud scheme / number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 029db59fd..63e622204 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -83,7 +83,7 @@ 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, & imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & - imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, cplchm, ltaerosol, & + imp_physics_zhao_carr, imp_physics_mg, imp_physics_fer_hires, ltaerosol, & 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) @@ -100,7 +100,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, 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) :: cplchm, ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend + logical, intent(in) :: ltaerosol, hybedmf, do_shoc, satmedmf, flag_for_pbl_generic_tend real(kind=kind_phys), dimension(:,:,:), intent(in) :: qgrs real(kind=kind_phys), dimension(:,:), intent(in) :: ugrs, vgrs, tgrs @@ -258,7 +258,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, rtg_ozone_index, imp_physics_mg, ntgl, imp_physics_gfdl, & imp_physics_zhao_carr, kk, & errmsg, errflg) - if (.not.errflg==1) return + if (errflg /= 0) return ! k1 = kk do n=ntchs,ntchm+ntchs-1 @@ -335,7 +335,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, index_of_process_pbl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, & dqsfc_diag, dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag, & rd, cp, fvirt, hvap, t1, q1, prsl, hflx, ushfsfci, oceanfrac, kdt, dusfc_cice, dvsfc_cice, & - dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, dkt_cpl, dkt, hffac, hefac, & + dtsfc_cice, dqsfc_cice, wet, dry, icy, wind, stress_wat, hflx_wat, evap_wat, ugrs1, vgrs1, hffac, & ugrs, vgrs, tgrs, qgrs, save_u, save_v, save_t, save_q, errmsg, errflg) use machine, only : kind_phys @@ -344,14 +344,13 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, implicit none integer, parameter :: kp = kind_phys - integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm + 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 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 logical, intent(in) :: ltaerosol, cplflx, cplchm, lssav, ldiag3d, lsidea logical, intent(in) :: hybedmf, do_shoc, satmedmf, shinhong, do_ysu - integer, intent(in) :: kdt logical, intent(in) :: flag_for_pbl_generic_tend real(kind=kind_phys), dimension(:,:), intent(in) :: save_u, save_v, save_t @@ -386,11 +385,8 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, logical, dimension(:),intent(in) :: wet, dry, icy real(kind=kind_phys), dimension(:), intent(out) :: ushfsfci - real(kind=kind_phys), dimension(:,:), intent(inout) :: dkt_cpl - real(kind=kind_phys), dimension(:,:), intent(in) :: dkt - ! From canopy heat storage - reduction factors in latent/sensible heat flux due to surface roughness - real(kind=kind_phys), dimension(:), intent(in) :: hffac, hefac + real(kind=kind_phys), dimension(:), intent(in) :: hffac character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -425,7 +421,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, imp_physics_mg, ntgl, imp_physics_gfdl, & imp_physics_zhao_carr, kk, & errmsg, errflg) - if (.not.errflg==1) return + if (errflg /= 0) return ! k1 = kk do n=ntchs,ntchm+ntchs-1 @@ -554,30 +550,21 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, endif ! nvdiff == ntrac - if (cplchm) then - do i = 1, im - tem = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) - ushfsfci(i) = -cp * tem * hflx(i) ! upward sensible heat flux - enddo - dkt_cpl(1:im,1:levs) = dkt(1:im,1:levs) - endif - - ! --- ... coupling insertion if (cplflx) then do i=1,im - if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES + if (oceanfrac(i) > zero) then ! Ocean only, NO LAKES if ( .not. wet(i)) then ! no open water - if ( kdt > 1 ) then !use results from CICE + if (kdt > 1) then !use results from CICE dusfci_cpl(i) = dusfc_cice(i) dvsfci_cpl(i) = dvsfc_cice(i) dtsfci_cpl(i) = dtsfc_cice(i) dqsfci_cpl(i) = dqsfc_cice(i) - else !use PBL fluxes when CICE fluxes is unavailable + else !use PBL fluxes when CICE fluxes is unavailable dusfci_cpl(i) = dusfc1(i) dvsfci_cpl(i) = dvsfc1(i) - dtsfci_cpl(i) = dtsfc1(i) + dtsfci_cpl(i) = dtsfc1(i)*hffac(i) dqsfci_cpl(i) = dqsfc1(i) end if elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point @@ -596,7 +583,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dusfci_cpl(i) = dusfc1(i) dvsfci_cpl(i) = dvsfc1(i) dtsfci_cpl(i) = dtsfc1(i)*hffac(i) - dqsfci_cpl(i) = dqsfc1(i)*hefac(i) + dqsfci_cpl(i) = dqsfc1(i) endif ! dusfc_cpl (i) = dusfc_cpl(i) + dusfci_cpl(i) * dtf @@ -614,6 +601,24 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, enddo endif + if (cplchm) then + if (cplflx) then + do i = 1, im + if (oceanfrac(i) > zero) then + ushfsfci(i) = dtsfci_cpl(i) + else + rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) + ushfsfci(i) = cp * rho * hflx(i) + end if + end do + else + do i = 1, im + rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) + ushfsfci(i) = cp * rho * hflx(i) + end do + end if + end if + !-------------------------------------------------------lssav if loop ---------- if (lssav) then do i=1,im @@ -622,7 +627,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dusfci_diag(i) = dusfc1(i) dvsfci_diag(i) = dvsfc1(i) dtsfci_diag(i) = dtsfc1(i)*hffac(i) - dqsfci_diag(i) = dqsfc1(i)*hefac(i) + dqsfci_diag(i) = dqsfc1(i) dtsfc_diag (i) = dtsfc_diag(i) + dtsfci_diag(i) * dtf dqsfc_diag (i) = dqsfc_diag(i) + dqsfci_diag(i) * dtf enddo diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 10a9adc75..341d6040e 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -263,14 +263,6 @@ type = integer intent = in optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F [ltaerosol] standard_name = flag_for_aerosol_physics long_name = flag for aerosol physics @@ -1310,24 +1302,6 @@ kind = kind_phys intent = in optional = F -[dkt_cpl] - standard_name = instantaneous_atmosphere_heat_diffusivity - long_name = instantaneous atmospheric heat diffusivity - units = m2 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = inout - optional = F -[dkt] - standard_name = atmosphere_heat_diffusivity - long_name = atmospheric heat diffusivity - units = m2 s-1 - dimensions = (horizontal_loop_extent,vertical_dimension) - type = real - kind = kind_phys - intent = in - optional = F [hffac] standard_name = surface_upward_sensible_heat_flux_reduction_factor long_name = surface upward sensible heat flux reduction factor from canopy heat storage @@ -1337,15 +1311,6 @@ kind = kind_phys intent = in optional = F -[hefac] - standard_name = surface_upward_latent_heat_flux_reduction_factor - long_name = surface upward latent heat flux reduction factor from canopy heat storage - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [ugrs] standard_name = x_wind long_name = zonal wind diff --git a/physics/GFS_SCNV_generic.F90 b/physics/GFS_SCNV_generic.F90 index ac77eaa68..2440d9bc7 100644 --- a/physics/GFS_SCNV_generic.F90 +++ b/physics/GFS_SCNV_generic.F90 @@ -92,7 +92,7 @@ end subroutine GFS_SCNV_generic_post_finalize !! \htmlinclude GFS_SCNV_generic_post_run.html !! subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & - cplchm, frain, gu0, gv0, gt0, gq0, save_u, save_v, save_t, save_q, dqdti, & + frain, gu0, gv0, gt0, gq0, save_u, save_v, save_t, save_q, & clw, shcnvcw, rain1, npdf3d, num_p3d, ncnvcld3d, cnvc, cnvw, nsamftrac, & rainc, cnvprcp, cnvprcpb, cnvw_phy_f3d, cnvc_phy_f3d, & dtend, dtidx, index_of_temperature, index_of_x_wind, index_of_y_wind, & @@ -107,14 +107,13 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & integer, intent(in) :: im, levs, nn, ntqv, nsamftrac integer, intent(in) :: ntcw,ntiw,ntclamt,ntrw,ntsw,ntrnc,ntsnc,ntgl,ntgnc,ntrac - logical, intent(in) :: lssav, ldiag3d, qdiag3d, cplchm, flag_for_scnv_generic_tend + logical, intent(in) :: lssav, ldiag3d, qdiag3d, flag_for_scnv_generic_tend real(kind=kind_phys), intent(in) :: frain real(kind=kind_phys), dimension(:,:), intent(in) :: gu0, gv0, gt0 real(kind=kind_phys), dimension(:,:), intent(in) :: save_u, save_v, save_t real(kind=kind_phys), dimension(:,:,:), intent(in) :: save_q, gq0 ! dtend only allocated if ldiag3d == .true. - real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti real(kind=kind_phys), intent(inout) :: dtend(:,:,:) integer, intent(in) :: dtidx(:,:) integer, intent(in) :: index_of_temperature, index_of_x_wind, index_of_y_wind, index_of_process_scnv @@ -209,15 +208,6 @@ subroutine GFS_SCNV_generic_post_run (im, levs, nn, lssav, ldiag3d, qdiag3d, & endif endif endif -! - if (cplchm) then - do k=1,levs - do i=1,im - tem = (gq0(i,k,ntqv)-save_q(i,k,ntqv)) * frain - dqdti(i,k) = dqdti(i,k) + tem - enddo - enddo - endif ! do k=1,levs do i=1,im diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index 650814d67..92b732ba9 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -348,14 +348,6 @@ type = logical intent = in optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F [frain] standard_name = dynamics_to_physics_timestep_ratio long_name = ratio of dynamics timestep to physics timestep @@ -437,15 +429,6 @@ kind = kind_phys intent = in optional = F -[dqdti] - 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_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [dtend] standard_name = cumulative_change_of_state_variables long_name = diagnostic tendencies for state variables diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index da88303fb..f4fd9e808 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -871,8 +871,8 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, if (Model%cplchm) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%rainc_cpl', Coupling%rainc_cpl) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ushfsfci ', Coupling%ushfsfci ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dkt ', Coupling%dkt ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dqdti ', Coupling%dqdti ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%pfi_lsan', Coupling%pfi_lsan ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%pfl_lsan', Coupling%pfl_lsan ) end if if (Model%do_sppt) then call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%sppt_wts', Coupling%sppt_wts) @@ -1199,7 +1199,6 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_ice ', Interstitial%ep1d_ice ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_land ', Interstitial%ep1d_land ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_water ', Interstitial%ep1d_water ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evapq ', Interstitial%evapq ) 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 ) @@ -1242,7 +1241,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gflx_water ', Interstitial%gflx_water ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gwdcu ', Interstitial%gwdcu ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gwdcv ', Interstitial%gwdcv ) - call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hefac ', Interstitial%hefac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zvfun ', Interstitial%zvfun ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hffac ', Interstitial%hffac ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hflxq ', Interstitial%hflxq ) call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hflx_ice ', Interstitial%hflx_ice ) @@ -1318,8 +1317,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%slopetype ', Interstitial%slopetype ) 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%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%soiltype ', Interstitial%soiltype ) @@ -1353,8 +1352,8 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegtype ', Interstitial%vegtype ) 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%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 ) diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index b68900d09..20c6c68c3 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -75,7 +75,7 @@ subroutine GFS_phys_time_vary_init ( isot, ivegsrc, nlunit, sncovr, sncovr_ice, lsm, lsm_noahmp, lsm_ruc, min_seaice, & fice, landfrac, vtype, weasd, lsoil, zs, dzs, lsnow_lsm_lbound, lsnow_lsm_ubound, & tvxy, tgxy, tahxy, canicexy, canliqxy, eahxy, cmxy, chxy, fwetxy, sneqvoxy, alboldxy,& - qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & + qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & @@ -319,10 +319,10 @@ subroutine GFS_phys_time_vary_init ( jindx2_aer, ddy_aer, xlon_d, & iindx1_aer, iindx2_aer, ddx_aer, & me, master) - iamin=min(minval(iindx1_aer), iamin) - iamax=max(maxval(iindx2_aer), iamax) - jamin=min(minval(jindx1_aer), jamin) - jamax=max(maxval(jindx2_aer), jamax) + iamin = min(minval(iindx1_aer), iamin) + iamax = max(maxval(iindx2_aer), iamax) + jamin = min(minval(jindx1_aer), jamin) + jamax = max(maxval(jindx2_aer), jamax) endif !$OMP section @@ -723,7 +723,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, shdmin, shdmax, snowd, & - cv, cvb, cvt, oro, oro_uf, xlat_d, xlon_d, slmsk, & + 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) implicit none @@ -760,7 +760,7 @@ subroutine GFS_phys_time_vary_timestep_init ( character(len=*), intent(in) :: input_nml_file(:) 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(:) + xlat_d(:), xlon_d(:), landfrac(:) real(kind_phys), intent(inout) :: smc(:,:), slc(:,:), stc(:,:), smois(:,:), sh2o(:,:), & tslb(:,:), tiice(:,:), tg3(:), tref(:), & tsfc(:), tsfco(:), tisfc(:), hice(:), fice(:), & @@ -888,7 +888,7 @@ subroutine GFS_phys_time_vary_timestep_init ( ! aerinterpol is using threading inside, don't ! move into OpenMP parallel section above call aerinterpol (me, master, nthrds, im, idate, & - fhour, jindx1_aer, jindx2_aer,& + fhour, jindx1_aer, jindx2_aer, & ddy_aer, iindx1_aer, & iindx2_aer, ddx_aer, & levs, prsl, aer_nm) @@ -897,13 +897,13 @@ 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, & - input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, 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, & + call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + 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) endif endif diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 6289fb6a7..217dd5be7 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -2006,6 +2006,15 @@ kind = kind_phys intent = inout optional = F +[landfrac] + standard_name = land_area_fraction + long_name = fraction of horizontal grid area occupied by land + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [slmsk] standard_name = sea_land_ice_mask_real long_name = landmask: sea/land/ice=0/1/2 diff --git a/physics/GFS_phys_time_vary.scm.F90 b/physics/GFS_phys_time_vary.scm.F90 index e1b5c3d9b..e0f380276 100644 --- a/physics/GFS_phys_time_vary.scm.F90 +++ b/physics/GFS_phys_time_vary.scm.F90 @@ -69,7 +69,7 @@ subroutine GFS_phys_time_vary_init ( isot, ivegsrc, nlunit, sncovr, sncovr_ice, lsm, lsm_noahmp, lsm_ruc, min_seaice, & fice, landfrac, vtype, weasd, lsoil, zs, dzs, lsnow_lsm_lbound, lsnow_lsm_ubound, & tvxy, tgxy, tahxy, canicexy, canliqxy, eahxy, cmxy, chxy, fwetxy, sneqvoxy, alboldxy,& - qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & + qsnowxy, wslakexy, albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, albdvis_ice, & albdnir_ice, albivis_ice, albinir_ice, emiss_lnd, emiss_ice, taussxy, waxy, wtxy, & zwtxy, xlaixy, xsaixy, lfmassxy, stmassxy, rtmassxy, woodxy, stblcpxy, fastcpxy, & smcwtdxy, deeprechxy, rechxy, snowxy, snicexy, snliqxy, tsnoxy , smoiseq, zsnsoxy, & @@ -281,10 +281,10 @@ subroutine GFS_phys_time_vary_init ( jindx2_aer, ddy_aer, xlon_d, & iindx1_aer, iindx2_aer, ddx_aer, & me, master) - iamin=min(minval(iindx1_aer), iamin) - iamax=max(maxval(iindx2_aer), iamax) - jamin=min(minval(jindx1_aer), jamin) - jamax=max(maxval(jindx2_aer), jamax) + iamin = min(minval(iindx1_aer), iamin) + iamax = max(maxval(iindx2_aer), iamax) + jamin = min(minval(jindx1_aer), jamin) + jamax = max(maxval(jindx2_aer), jamax) endif !> - Call setindxci() to initialize IN and CCN data @@ -691,8 +691,7 @@ subroutine GFS_phys_time_vary_timestep_init ( integer, intent(out) :: errflg ! Local variables - integer :: i, j, k, iseed, iskip, ix, kdt_rad - real(kind=kind_phys) :: sec_zero, rsnow + 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) @@ -792,18 +791,18 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Not needed for SCM: !> - 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, & - ! input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - ! use_ufo, nst_anl, fhcyc, phour, 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) - ! endif - !endif + ! if (nscyc > 0) then + ! if (mod(kdt,nscyc) == 1) THEN + ! call gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + ! 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) + ! endif + ! endif end subroutine GFS_phys_time_vary_timestep_init !! @} diff --git a/physics/GFS_radiation_surface.F90 b/physics/GFS_radiation_surface.F90 index dd0c56d43..2481af163 100644 --- a/physics/GFS_radiation_surface.F90 +++ b/physics/GFS_radiation_surface.F90 @@ -159,7 +159,7 @@ subroutine GFS_radiation_surface_run ( & if (lslwr) then !> - Call module_radiation_surface::setemis(),to set up surface !! emissivity for LW radiation. - call setemis (lsm, lsm_noahmp, lsm_ruc, vtype, landfrac, & + call setemis (lsm, lsm_noahmp, lsm_ruc, vtype, & frac_grid, min_seaice, xlon, xlat, slmsk, & snowd, sncovr, sncovr_ice, zorl, tsfg, tsfa, & hprime, semis_lnd, semis_ice, im, & @@ -182,7 +182,7 @@ subroutine GFS_radiation_surface_run ( & !! albedor for SW radiation. call setalb (slmsk, lsm, lsm_noahmp, lsm_ruc, snowd, sncovr, sncovr_ice, snoalb, & - zorl, coszen, tsfg, tsfa, hprime, landfrac, frac_grid, min_seaice, & + zorl, coszen, tsfg, tsfa, hprime, frac_grid, min_seaice, & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & albdvis_lnd, albdnir_lnd, albivis_lnd, albinir_lnd, & albdvis_ice, albdnir_ice, albivis_ice, albinir_ice, & diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index 158067c05..dbea66985 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -18,7 +18,7 @@ end subroutine GFS_rrtmg_pre_init ! in the CCPP version - they are defined in the interstitial_create routine 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, ncld, ntrw, ntsw, ntgl, ntwa, ntoz, & + ntqv, ntcw,ntiw, ntlnc, ntinc, ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, lndp_type, kdt, imp_physics, & imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & @@ -83,7 +83,7 @@ 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, ncld, & + ntcw, ntiw, ntlnc, ntinc, & ntrw, ntsw, ntgl, ntwa, ntoz, & ntclamt, nleffr, nieffr, nseffr, & lndp_type, & @@ -594,7 +594,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & !! call module_radiation_clouds::progcld1() !! - For Zhao/Moorthi's prognostic cloud+pdfcld, !! call module_radiation_clouds::progcld3() -!! call module_radiation_clouds::progclduni() for unified cloud and ncld=2 +!! call module_radiation_clouds::progclduni() for unified cloud and ncnd>=2 ! --- ... obtain cloud information for radiation calculations @@ -690,11 +690,6 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntiw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntsw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntgl) - -! else -! do j=1,ncld -! ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount -! enddo endif do k=1,LMK do i=1,IM @@ -949,7 +944,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, & if (imp_physics == imp_physics_zhao_carr .or. imp_physics == imp_physics_mg) then ! zhao/moorthi's prognostic cloud scheme ! or unified cloud and/or with MG microphysics - if (uni_cld .and. ncld >= 2) then + if (uni_cld .and. ncndl >= 2) then call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs xlat, xlon, slmsk, dz, delp, & IM, LMK, LMP, cldcov, & diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index 344befa97..d6da64ffb 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -161,14 +161,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = choice of cloud scheme / number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [ntrw] standard_name = index_for_rain_water long_name = tracer index for rain water diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index 1af386370..fc660994d 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -282,7 +282,7 @@ subroutine GFS_rrtmg_setup_init ( & print *,' In rad_initialize (GFS_rrtmg_setup_init), before calling radinit' print *,' si =',si print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& - & ' iaer=',iaer,' ntcw=',ntcw + & ' iaermdl=',iaermdl,' iaerflg=',iaerflg print *,' np3d=',num_p3d,' ntoz=',ntoz, & & ' iovr=',iovr,' isubc_sw=',isubc_sw, & & ' isubc_lw=',isubc_lw,' icliq_sw=',icliq_sw, & diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index b793c2902..6bc702216 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -235,8 +235,8 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_ ! --- ... sfc lw fluxes used by atmospheric model are saved for output if (.not. use_LW_jacobian) then - if (frac_grid) then - do i=1,im + if (frac_grid) then + do i=1,im tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell if (flag_cice(i)) then adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & @@ -247,9 +247,9 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_ + adjsfculw_ice(i) * tem & + adjsfculw_wat(i) * (one - frland(i) - tem) endif - enddo - else - do i=1,im + enddo + else + do i=1,im if (dry(i)) then ! all land adjsfculw(i) = adjsfculw_lnd(i) elseif (icy(i)) then ! ice (and water) @@ -270,15 +270,15 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, flag_ else ! all water adjsfculw(i) = adjsfculw_wat(i) endif - enddo - endif + enddo + endif endif do i=1,im dlwsfc(i) = dlwsfc(i) + adjsfcdlw(i)*dtf ulwsfc(i) = ulwsfc(i) + adjsfculw(i)*dtf psmean(i) = psmean(i) + pgr(i)*dtf ! mean surface pressure - end do + enddo if (ldiag3d) then if (lsidea) then @@ -699,10 +699,10 @@ end subroutine GFS_suite_interstitial_4_finalize !> \section arg_table_GFS_suite_interstitial_4_run Argument Table !! \htmlinclude GFS_suite_interstitial_4_run.html !! - subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_total, ntrac, ntcw, ntiw, ntclamt, & + subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& - index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, dqdti, ldiag3d, & + index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nwfa, spechum, ldiag3d, & qdiag3d, save_lnc, save_inc, ntk, ntke, errmsg, errflg) use machine, only: kind_phys @@ -716,7 +716,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf - logical, intent(in ) :: ltaerosol, cplchm, convert_dry_rho + logical, intent(in) :: ltaerosol, convert_dry_rho real(kind=kind_phys), intent(in ) :: con_pi, dtf real(kind=kind_phys), intent(in ), dimension(:,:) :: save_qc @@ -736,9 +736,6 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to real(kind=kind_phys), dimension(:,:), intent(in) :: nwfa, save_tcp real(kind=kind_phys), dimension(:,:), intent(in) :: spechum - ! dqdti may not be allocated - real(kind=kind_phys), intent(inout), dimension(:,:) :: dqdti - character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -910,15 +907,6 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to enddo endif ! end if_ntcw -! dqdt_v : instaneous moisture tendency (kg/kg/sec) - if (cplchm) then - do k=1,levs - do i=1,im - dqdti(i,k) = dqdti(i,k) * (one / dtf) - enddo - enddo - endif - end subroutine GFS_suite_interstitial_4_run end module GFS_suite_interstitial_4 diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 0c1189f19..fe13b3452 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1695,14 +1695,6 @@ type = logical intent = in optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F [tracers_total] standard_name = number_of_total_tracers long_name = total number of tracers @@ -1989,15 +1981,6 @@ kind = kind_phys intent = inout optional = F -[dqdti] - 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_dimension) - type = real - kind = kind_phys - intent = inout - optional = F [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 diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 48a4b7808..7db8d6c19 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -29,32 +29,32 @@ end subroutine GFS_surface_composites_pre_finalize !! subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm, lsm_noahmp, lsm_ruc, frac_grid, & flag_cice, cplflx, cplwav2atm, landfrac, lakefrac, lakedepth, oceanfrac, frland, & - dry, icy, use_flake, ocean, wet, hice, cice, zorlo, zorll, zorli, & - snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + dry, icy, lake, use_flake, ocean, 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_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & + weasd, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat, & tsfc_lnd, tsfc_ice, tisfc, tice, tsurf_wat, tsurf_lnd, tsurf_ice, & gflx_ice, tgice, islmsk, islmsk_cice, slmsk, semis_rad, semis_wat, semis_lnd, semis_ice, & emis_lnd, emis_ice, qss, qss_wat, qss_lnd, qss_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, & - min_lakeice, min_seaice, errmsg, errflg) + min_lakeice, min_seaice, kdt, errmsg, errflg) implicit none ! Interface variables - integer, intent(in ) :: im, lkm + integer, intent(in ) :: im, lkm, kdt integer, intent(in ) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in ) :: flag_init, flag_restart, frac_grid, cplflx, cplwav2atm logical, dimension(:), intent(inout) :: flag_cice - logical, dimension(:), intent(inout) :: dry, icy, use_flake, ocean, wet + logical, dimension(:), intent(inout) :: dry, icy, lake, use_flake, ocean, wet 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 real(kind=kind_phys), dimension(:), intent(in ) :: snowd, tprcp, uustar, weasd, qss, hflx real(kind=kind_phys), dimension(:), intent(inout) :: tsfc, tsfco, tsfcl, tisfc - real(kind=kind_phys), dimension(:), intent(inout) :: snowd_wat, snowd_lnd, snowd_ice, tprcp_wat, & + real(kind=kind_phys), dimension(:), intent(inout) :: snowd_lnd, snowd_ice, tprcp_wat, & tprcp_lnd, tprcp_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat,tsurf_lnd, tsurf_ice, & - uustar_wat, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, & + uustar_wat, uustar_lnd, uustar_ice, weasd_lnd, weasd_ice, & qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(:), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice @@ -68,6 +68,8 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm ! real(kind=kind_phys), parameter :: timin = 173.0_kind_phys ! minimum temperature allowed for snow/ice + real(kind=kind_phys) :: tem + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -93,6 +95,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm flag_cice(i) = .true. else islmsk_cice(i) = 2 + flag_cice(i) = .false. endif islmsk(i) = 2 else @@ -101,6 +104,7 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm flag_cice(i) = .false. islmsk_cice(i) = 0 islmsk(i) = 0 + icy(i) = .false. endif if (cice(i) < one) then wet(i) = .true. ! some open ocean @@ -108,15 +112,17 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm endif else if (cice(i) >= min_lakeice) then - icy(i) = .true. + icy(i) = .true. islmsk(i) = 2 - tisfc(i) = max(timin, min(tisfc(i), tgice)) + tisfc(i) = max(timin, min(tisfc(i), tgice)) else cice(i) = zero hice(i) = zero islmsk(i) = 0 + icy(i) = .false. endif islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. if (cice(i) < one) then wet(i) = .true. ! some open lake if (icy(i)) tsfco(i) = max(tisfc(i), tgice) @@ -127,6 +133,9 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm hice(i) = zero islmsk_cice(i) = 1 islmsk(i) = 1 + wet(i) = .false. + icy(i) = .false. + flag_cice(i) = .false. endif enddo @@ -139,18 +148,28 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm frland(i) = one cice(i) = zero hice(i) = zero + icy(i) = .false. else frland(i) = zero if (oceanfrac(i) > zero) then if (cice(i) >= min_seaice) then icy(i) = .true. tisfc(i) = max(timin, min(tisfc(i), tgice)) + if (cplflx) then + islmsk_cice(i) = 4 + flag_cice(i) = .true. + else + islmsk_cice(i) = 2 + flag_cice(i) = .false. + endif + islmsk(i) = 2 else cice(i) = zero hice(i) = zero flag_cice(i) = .false. islmsk(i) = 0 islmsk_cice(i) = 0 + icy(i) = .false. endif if (cice(i) < one) then wet(i) = .true. ! some open ocean @@ -160,13 +179,15 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm if (cice(i) >= min_lakeice) then icy(i) = .true. tisfc(i) = max(timin, min(tisfc(i), tgice)) + islmsk(i) = 2 else cice(i) = zero hice(i) = zero - flag_cice(i) = .false. islmsk(i) = 0 + icy(i) = .false. endif islmsk_cice(i) = islmsk(i) + flag_cice(i) = .false. if (cice(i) < one) then wet(i) = .true. ! some open lake if (icy(i)) tsfco(i) = max(tisfc(i), tgice) @@ -184,21 +205,11 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm uustar_wat(i) = uustar(i) tsfc_wat(i) = tsfco(i) tsurf_wat(i) = tsfco(i) -! weasd_wat(i) = weasd(i) -! snowd_wat(i) = snowd(i) - weasd_wat(i) = zero - snowd_wat(i) = zero !-- reference emiss value for surface emissivity in setemis ! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, ! 4-sandy desert, 5-rocky desert, 6-forest, 7-ice, 8-snow !data emsref / 0.97, 0.95, 0.94, 0.90, 0.93, 0.96, 0.96, 0.99 / - if(iemsflg == 2) then semis_wat(i) = 0.97_kind_phys ! consistent with setemis - else - semis_wat(i) = 0.984_kind_phys - endif - qss_wat(i) = qss(i) - hflx_wat(i) = hflx(i) ! DH* else zorlo(i) = huge @@ -209,26 +220,22 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm weasd_lnd(i) = weasd(i) tsfc_lnd(i) = tsfcl(i) tsurf_lnd(i) = tsfcl(i) - snowd_lnd(i) = snowd(i) if (iemsflg == 2 .and. .not. flag_init) then !-- use land emissivity from the LSM semis_lnd(i) = emis_lnd(i) else semis_lnd(i) = semis_rad(i) endif - qss_lnd(i) = qss(i) - hflx_lnd(i) = hflx(i) ! DH* else zorll(i) = huge ! *DH - end if + endif if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) weasd_ice(i) = weasd(i) tsfc_ice(i) = tisfc(i) tsurf_ice(i) = tisfc(i) - snowd_ice(i) = snowd(i) ep1d_ice(i) = zero gflx_ice(i) = zero if (iemsflg == 2 .and. (.not.flag_init .or. flag_restart) .and. lsm == lsm_ruc) then @@ -237,28 +244,65 @@ subroutine GFS_surface_composites_pre_run (im, flag_init, flag_restart, lkm, lsm else semis_ice(i) = 0.95_kind_phys endif - qss_ice(i) = qss(i) - hflx_ice(i) = hflx(i) ! DH* else zorli(i) = huge ! *DH - end if + endif 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) .and. lkm == 1) then - if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then - use_flake(i) = .true. - else - use_flake(i) = .false. - endif + if(wet(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 - use_flake(i) = .false. + lake(i) = .false. + use_flake(i) = .false. endif enddo +! + if (.not. cplflx .or. kdt == 1) then + if (frac_grid) then + do i=1,im + if (dry(i)) then + if (icy(i)) then + tem = one / (cice(i)*(one-frland(i))) + snowd_ice(i) = max(zero, (snowd(i) - snowd_lnd(i)*frland(i)) * tem) + weasd_ice(i) = max(zero, (weasd(i) - weasd_lnd(i)*frland(i)) * tem) + endif + elseif (icy(i)) then + tem = one / cice(i) + snowd_lnd(i) = zero + snowd_ice(i) = snowd(i) * tem + weasd_lnd(i) = zero + weasd_ice(i) = weasd(i) * tem + endif + enddo + else + do i=1,im + if (dry(i)) then + snowd_lnd(i) = snowd(i) + weasd_lnd(i) = weasd(i) + snowd_ice(i) = zero + weasd_ice(i) = zero + elseif (icy(i)) then + snowd_lnd(i) = zero + weasd_lnd(i) = zero + tem = one / cice(i) + snowd_ice(i) = snowd(i) * tem + weasd_ice(i) = weasd(i) * tem + endif + enddo + endif + endif + +! write(0,*)' minmax of ice snow=',minval(snowd_ice),maxval(snowd_ice) ! Assign sea ice temperature to interstitial variable do i = 1, im @@ -375,35 +419,39 @@ end subroutine GFS_surface_composites_post_finalize !! 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, & + landfrac, lakefrac, oceanfrac, zorl, zorlo, zorll, zorli, garea, & 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, & cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & - ep1d_lnd, ep1d_ice, weasd, weasd_wat, weasd_lnd, weasd_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & + 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, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, stc, & + qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, & + sigmaf, zvfun, lheatstrg, h0facu, h0facs, hflxq, hffac, stc, & grav, prsik1, prslk1, prslki, z1, ztmax_wat, ztmax_lnd, ztmax_ice, errmsg, errflg) implicit none 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 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, & stress_lnd, stress_ice, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh_wat, ffhh_lnd, ffhh_ice, uustar_wat, uustar_lnd, uustar_ice, & fm10_wat, fm10_lnd, fm10_ice, fh2_wat, fh2_lnd, fh2_ice, tsurf_wat, tsurf_lnd, tsurf_ice, cmm_wat, cmm_lnd, cmm_ice, & - chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_wat, weasd_lnd, weasd_ice, & - snowd_wat, snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & - hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice, zorlo, zorll, zorli + chh_wat, chh_lnd, chh_ice, gflx_wat, gflx_lnd, gflx_ice, ep1d_wat, ep1d_lnd, ep1d_ice, weasd_lnd, weasd_ice, & + snowd_lnd, snowd_ice, tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & + hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice, zorlo, zorll, zorli, garea real(kind=kind_phys), dimension(:), intent(inout) :: zorl, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & fh2, cmm, chh, gflx, ep1d, weasd, snowd, tprcp, evap, hflx, qss, tsfc, tsfco, tsfcl, tisfc real(kind=kind_phys), dimension(:), intent(in ) :: tice ! interstitial sea ice temperature real(kind=kind_phys), dimension(:), intent(inout) :: hice, cice + real(kind=kind_phys), dimension(:), intent(inout) :: sigmaf, zvfun, hflxq, hffac + real(kind=kind_phys), intent(in ) :: h0facu, h0facs real(kind=kind_phys), intent(in ) :: min_seaice real(kind=kind_phys), intent(in ) :: rd, rvrdm1 @@ -424,6 +472,10 @@ subroutine GFS_surface_composites_post_run ( real(kind=kind_phys) :: txl, txi, txo, wfrac, q0, rho ! For calling "stability" real(kind=kind_phys) :: tsurf, virtfac, tv1, thv1, tvs, z0max, ztmax +! + real(kind=kind_phys) :: tem1, tem2, gdx + real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 +! ! Initialize CCPP error handling variables errmsg = '' @@ -443,17 +495,24 @@ subroutine GFS_surface_composites_post_run ( !gflx(i) = txl*gflx_lnd(i) + txi*gflx_ice(i) + txo*gflx_wat(i) ep1d(i) = txl*ep1d_lnd(i) + txi*ep1d_ice(i) + txo*ep1d_wat(i) - !weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) + txo*weasd_wat(i) - !snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) + txo*snowd_wat(i) weasd(i) = txl*weasd_lnd(i) + txi*weasd_ice(i) snowd(i) = txl*snowd_lnd(i) + txi*snowd_ice(i) !tprcp(i) = txl*tprcp_lnd(i) + txi*tprcp_ice(i) + txo*tprcp_wat(i) - - if (.not. flag_cice(i) .and. islmsk(i) == 2) then - evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) - hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) - qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) - gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) +! + sigmaf(i) = txl*sigmaf(i) + + if (.not. flag_cice(i)) then + if (islmsk(i) == 2) then + evap(i) = txl*evap_lnd(i) + wfrac*evap_ice(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_ice(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_ice(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_ice(i) + else + evap(i) = txl*evap_lnd(i) + wfrac*evap_wat(i) + hflx(i) = txl*hflx_lnd(i) + wfrac*hflx_wat(i) + qss(i) = txl*qss_lnd(i) + wfrac*qss_wat(i) + gflx(i) = txl*gflx_lnd(i) + wfrac*gflx_wat(i) + endif else evap(i) = txl*evap_lnd(i) + txi*evap_ice(i) + txo*evap_wat(i) hflx(i) = txl*hflx_lnd(i) + txi*hflx_ice(i) + txo*hflx_wat(i) @@ -524,8 +583,32 @@ subroutine GFS_surface_composites_post_run ( stress(i) = stress_ice(i) uustar(i) = uustar_ice(i) else ! Mix of multiple surface types (land, water, and/or ice) - call stability(z1(i), snowd(i), thv1, wind(i), z0max, ztmax, tvs, grav, & ! inputs - tv1, thsfc_loc, & ! inputs +! +! re-compute zvfun with composite surface roughness & green vegetation fraction +! + tem1 = (z0max - z0lo) / (z0up - z0lo) + tem1 = min(max(tem1, zero), one) + tem2 = max(sigmaf(i), 0.1) + zvfun(i) = sqrt(tem1 * tem2) + gdx = sqrt(garea(i)) +! +! re-compute variables for canopy heat storage parameterization with the updated zvfun +! in the fractional grid +! + hflxq(i) = hflx(i) + hffac(i) = 1.0 + if (lheatstrg) then + if(hflx(i) > 0.) then + hffac(i) = h0facu * zvfun(i) + else + hffac(i) = h0facs * zvfun(i) + endif + hffac(i) = 1. + hffac(i) + hflxq(i) = hflx(i) / hffac(i) + endif +! + call stability(z1(i), zvfun(i), gdx, tv1, thv1, wind(i), & ! inputs + z0max, ztmax, tvs, grav, thsfc_loc, & ! inputs rb(i), ffmm(i), ffhh(i), fm10(i), fh2(i), cd(i), cdq(i), & ! outputs stress(i), uustar(i)) endif ! Checking to see if point is one or multiple surface types @@ -606,7 +689,6 @@ subroutine GFS_surface_composites_post_run ( ep1d(i) = ep1d_lnd(i) weasd(i) = weasd_lnd(i) snowd(i) = snowd_lnd(i) - !tprcp(i) = tprcp_lnd(i) evap(i) = evap_lnd(i) hflx(i) = hflx_lnd(i) qss(i) = qss_lnd(i) @@ -631,9 +713,8 @@ subroutine GFS_surface_composites_post_run ( chh(i) = chh_wat(i) gflx(i) = gflx_wat(i) ep1d(i) = ep1d_wat(i) - weasd(i) = weasd_wat(i) - snowd(i) = snowd_wat(i) - !tprcp(i) = tprcp_wat(i) + weasd(i) = zero + snowd(i) = zero evap(i) = evap_wat(i) hflx(i) = hflx_wat(i) qss(i) = qss_wat(i) @@ -654,21 +735,17 @@ 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) - snowd(i) = snowd_ice(i) - !tprcp(i) = cice(i)*tprcp_ice(i) + (one-cice(i))*tprcp_wat(i) + weasd(i) = weasd_ice(i) * cice(i) + snowd(i) = snowd_ice(i) * cice(i) qss(i) = qss_ice(i) tsfc(i) = tsfc_ice(i) evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) - qss(i) = qss_ice(i) - tisfc(i) = tice(i) - if (.not. flag_cice(i)) then -! tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - zorl(i) = cice(i) * zorli(i) + (one - cice(i)) * zorlo(i) - tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) - elseif (wet(i)) then - if (cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice + tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + tsfc(i) = tsfc_ice(i) ! over lake (and ocean when uncoupled) +! + if (flag_cice(i)) then + if (wet(i) .and. cice(i) >= min_seaice) then ! this was already done for lake ice in sfc_sice txi = cice(i) txo = one - txi evap(i) = txi * evap_ice(i) + txo * evap_wat(i) @@ -677,17 +754,12 @@ subroutine GFS_surface_composites_post_run ( 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) - zorl(i) = txi * zorli(i) + txo * zorlo(i) - else - evap(i) = evap_wat(i) - hflx(i) = hflx_wat(i) - tsfc(i) = tsfc_wat(i) - stress(i) = stress_wat(i) - qss(i) = qss_wat(i) - ep1d(i) = ep1d_wat(i) - zorl(i) = zorlo(i) + zorl(i) = exp(txi*log(zorli(i)) + txo*log(zorlo(i))) endif + elseif (wet(i)) then ! return updated lake ice thickness & concentration to global array + zorl(i) = exp(cice(i)*log(zorli(i)) + (one-cice(i))*log(zorlo(i))) endif +! if (wet(i)) then tsfco(i) = tsfc_wat(i) else @@ -696,7 +768,7 @@ subroutine GFS_surface_composites_post_run ( 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) - end do + enddo endif enddo diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 9caf9db04..c08bc3a78 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -156,7 +156,7 @@ type = logical intent = inout optional = F -[use_flake] +[lake] standard_name = flag_nonzero_lake_surface_fraction long_name = flag indicating presence of some lake surface area fraction units = flag @@ -164,6 +164,14 @@ type = logical intent = inout optional = F +[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 + intent = inout + optional = F [ocean] standard_name = flag_nonzero_ocean_surface_fraction long_name = flag indicating presence of some ocean surface area fraction @@ -234,15 +242,6 @@ kind = kind_phys intent = in optional = F -[snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [snowd_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land @@ -342,15 +341,6 @@ kind = kind_phys intent = in optional = F -[weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = inout - optional = F [weasd_lnd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land @@ -664,6 +654,14 @@ kind = kind_phys intent = in optional = F +[kdt] + standard_name = index_of_time_step + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -1559,15 +1557,6 @@ kind = kind_phys intent = inout optional = F -[weasd_wat] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [weasd_lnd] standard_name = water_equivalent_accumulated_snow_depth_over_land long_name = water equiv of acc snow depth over land @@ -1595,15 +1584,6 @@ kind = kind_phys intent = inout optional = F -[snowd_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [snowd_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land @@ -1927,6 +1907,77 @@ kind = kind_phys intent = in optional = F +[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 + optional = F +[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 = inout + optional = F +[lheatstrg] + standard_name = flag_for_canopy_heat_storage + long_name = flag for canopy heat storage parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[h0facu] + standard_name = canopy_heat_storage_factor_for_sensible_heat_flux_in_unstable_surface_layer + long_name = canopy heat storage factor for sensible heat flux in unstable surface layer + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[h0facs] + standard_name = canopy_heat_storage_factor_for_sensible_heat_flux_in_stable_surface_layer + long_name = canopy heat storage factor for sensible heat flux in stable surface layer + units = none + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[hflxq] + 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 = inout + optional = F +[hffac] + standard_name = surface_upward_sensible_heat_flux_reduction_factor + long_name = surface upward sensible heat flux reduction factor from canopy heat storage + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F +[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 = inout + optional = F [ztmax_wat] standard_name = bounded_surface_roughness_length_for_heat_over_water long_name = bounded surface roughness length for heat over water diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index d405b3821..b6dd30cfe 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -31,7 +31,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, 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, sfc_wts_inv, & - cplflx, flag_cice, islmsk_cice, slimskin_cpl, tisfc, tsfco, fice, hice, & + cplflx, flag_cice, islmsk_cice, slimskin_cpl, & wind, u1, v1, cnvwind, smcwlt2, smcref2, errmsg, errflg) use surface_perturbation, only: cdfnor @@ -56,8 +56,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(:), intent(out) :: dsnow_cpl real(kind=kind_phys), dimension(:), intent(in) :: rain_cpl real(kind=kind_phys), dimension(:), intent(in) :: snow_cpl - integer, intent(in) :: lndp_type - integer, intent(in) :: n_var_lndp + integer, intent(in) :: lndp_type, n_var_lndp character(len=3), dimension(:), intent(in) :: lndp_var_list real(kind=kind_phys), dimension(:), intent(in) :: lndp_prt_list real(kind=kind_phys), dimension(:,:), intent(in) :: sfc_wts @@ -67,21 +66,19 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(:), intent(out) :: xlai1d real(kind=kind_phys), dimension(:), intent(out) :: vegf1d real(kind=kind_phys), intent(out) :: lndp_vgf - real(kind=kind_phys), dimension(:,:), intent(inout) :: sfc_wts_inv + real(kind=kind_phys), dimension(:,:), intent(inout) :: sfc_wts_inv - logical, intent(in) :: cplflx - real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl - logical, dimension(:), intent(inout) :: flag_cice - integer, dimension(:), intent(out) :: islmsk_cice - real(kind=kind_phys), dimension(:), intent(in) :: & - tisfc, tsfco, fice, hice + logical, intent(in) :: cplflx + real(kind=kind_phys), dimension(:), intent(in) :: slimskin_cpl + logical, dimension(:), intent(inout) :: flag_cice + integer, dimension(:), intent(out) :: islmsk_cice - real(kind=kind_phys), dimension(:), intent(out) :: wind - real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 + real(kind=kind_phys), dimension(:), intent(out) :: wind + real(kind=kind_phys), dimension(:), intent(in ) :: u1, v1 ! surface wind enhancement due to convection - real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind + real(kind=kind_phys), dimension(:), intent(inout ) :: cnvwind ! - real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 + real(kind=kind_phys), dimension(:), intent(out) :: smcwlt2, smcref2 ! CCPP error handling character(len=*), intent(out) :: errmsg @@ -89,8 +86,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! Local variables integer :: i, k - real(kind=kind_phys) :: onebg - real(kind=kind_phys) :: cdfz + real(kind=kind_phys) :: onebg, cdfz ! Set constants onebg = 1.0/con_g @@ -99,7 +95,6 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, errmsg = '' errflg = 0 - ! Scale random patterns for surface perturbations with perturbation size ! Turn vegetation fraction pattern into percentile pattern lndp_vgf=-999. @@ -108,25 +103,25 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, sfc_wts_inv(:,:)=sfc_wts(:,:) endif if (lndp_type==1) then - do k =1,n_var_lndp - select case(lndp_var_list(k)) - case ('rz0') + do k =1,n_var_lndp + select case(lndp_var_list(k)) + case ('rz0') z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('rzt') - zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('shc') - bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) - case ('lai') + case ('rzt') + zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('shc') + bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) + case ('lai') xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) - case ('vgf') + case ('vgf') ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff do i=1,im call cdfnor(sfc_wts(i,k),cdfz) vegf1d(i) = cdfz enddo lndp_vgf = lndp_prt_list(k) - end select - enddo + end select + enddo endif ! End of stochastic physics / surface perturbation @@ -136,20 +131,20 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, islmsk_cice(i) = islmsk(i) if (islmsk(i) == 2) then if (isot == 1) then - soiltyp(i) = 16 + soiltyp(i) = 16 else - soiltyp(i) = 9 + soiltyp(i) = 9 endif if (ivegsrc == 0 .or. ivegsrc == 4) then - vegtype(i) = 24 + vegtype(i) = 24 elseif (ivegsrc == 1) then - vegtype(i) = 15 + vegtype(i) = 15 elseif (ivegsrc == 2) then - vegtype(i) = 13 + vegtype(i) = 13 elseif (ivegsrc == 3 .or. ivegsrc == 5) then - vegtype(i) = 15 + vegtype(i) = 15 endif - slopetyp(i) = 9 + slopetyp(i) = 9 else soiltyp(i) = int( stype(i)+0.5_kind_phys ) vegtype(i) = int( vtype(i)+0.5_kind_phys ) @@ -167,9 +162,9 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) - !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & - ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & - ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) + !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & + ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & + ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) cnvwind(i) = zero enddo @@ -209,20 +204,21 @@ end subroutine GFS_surface_generic_post_finalize !> \section arg_table_GFS_surface_generic_post_run Argument Table !! \htmlinclude GFS_surface_generic_post_run.html !! - subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1,& + subroutine GFS_surface_generic_post_run (im, cplflx, cplchm, cplwav, lssav, dry, icy, wet, & + dtf, ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, & adjsfcdlw, adjsfcdsw, adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd, adjsfculw, adjsfculw_wat, adjnirbmu, adjnirdfu, & adjvisbmu, adjvisdfu,t2m, q2m, u10m, v10m, tsfc, tsfc_wat, pgr, xcosz, evbs, evcw, trans, sbsno, snowc, snohf, & epi, gfluxi, t1, q1, u1, v1, dlwsfci_cpl, dswsfci_cpl, dlwsfc_cpl, dswsfc_cpl, dnirbmi_cpl, dnirdfi_cpl, dvisbmi_cpl, & dvisdfi_cpl, dnirbm_cpl, dnirdf_cpl, dvisbm_cpl, dvisdf_cpl, nlwsfci_cpl, nlwsfc_cpl, t2mi_cpl, q2mi_cpl, u10mi_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, ep, & - runoff, srunoff, runof, drain, lheatstrg, z0fac, e0fac, zorl, hflx, evap, hflxq, evapq, hffac, hefac, errmsg, errflg) + runoff, srunoff, runof, drain, lheatstrg, h0facu, h0facs, zvfun, hflx, evap, hflxq, hffac, errmsg, errflg) implicit none integer, intent(in) :: im - logical, intent(in) :: cplflx, cplwav, lssav - logical, dimension(:), intent(in) :: icy, wet + logical, intent(in) :: cplflx, cplchm, cplwav, lssav + logical, dimension(:), intent(in) :: dry, icy, wet real(kind=kind_phys), intent(in) :: dtf real(kind=kind_phys), dimension(:), intent(in) :: ep1d, gflx, tgrs_1, qgrs_1, ugrs_1, vgrs_1, adjsfcdlw, adjsfcdsw, & @@ -240,11 +236,11 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt ! For canopy heat storage logical, intent(in) :: lheatstrg - real(kind=kind_phys), intent(in) :: z0fac, e0fac - real(kind=kind_phys), dimension(:), intent(in) :: zorl + real(kind=kind_phys), intent(in) :: h0facu, h0facs + real(kind=kind_phys), dimension(:), intent(in) :: zvfun real(kind=kind_phys), dimension(:), intent(in) :: hflx, evap - real(kind=kind_phys), dimension(:), intent(out) :: hflxq, evapq - real(kind=kind_phys), dimension(:), intent(out) :: hffac, hefac + real(kind=kind_phys), dimension(:), intent(out) :: hflxq + real(kind=kind_phys), dimension(:), intent(out) :: hffac ! CCPP error handling variables character(len=*), intent(out) :: errmsg @@ -253,13 +249,8 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt ! Local variables real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys - ! Parameters for canopy heat storage parametrization - real(kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 - real(kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 - integer :: i real(kind=kind_phys) :: xcosz_loc, ocalnirdf_cpl, ocalnirbm_cpl, ocalvisdf_cpl, ocalvisbm_cpl - real(kind=kind_phys) :: tem, tem1, tem2 ! Initialize CCPP error handling variables errmsg = '' @@ -274,13 +265,19 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt v1(i) = vgrs_1(i) enddo - if (cplflx .or. cplwav) then + if (cplflx .or. cplchm .or. cplwav) then do i=1,im u10mi_cpl(i) = u10m(i) v10mi_cpl(i) = v10m(i) enddo endif + if (cplflx .or. cplchm) then + do i=1,im + tsfci_cpl(i) = tsfc(i) + enddo + endif + if (cplflx) then do i=1,im dlwsfci_cpl (i) = adjsfcdlw(i) @@ -302,8 +299,6 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt nlwsfc_cpl (i) = nlwsfc_cpl(i) + nlwsfci_cpl(i)*dtf t2mi_cpl (i) = t2m(i) q2mi_cpl (i) = q2m(i) - tsfci_cpl (i) = tsfc(i) -! tsfci_cpl (i) = tsfc_wat(i) psurfi_cpl (i) = pgr(i) enddo @@ -312,7 +307,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt do i=1,im ! if (Sfcprop%landfrac(i) < one) then ! Not 100% land - if (wet(i)) then ! some open water + if (wet(i)) then ! some open water ! --- compute open water albedo xcosz_loc = max( zero, min( one, xcosz(i) )) ocalnirdf_cpl = 0.06_kind_phys @@ -360,32 +355,28 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt enddo endif -! --- ... Boundary Layer and Free atmospheic turbulence parameterization ! -! in order to achieve heat storage within canopy layer, in the canopy heat -! storage parameterization the kinematic sensible and latent heat fluxes -! (hflx & evap) as surface boundary forcings to the pbl scheme are -! reduced as a function of surface roughness +! in order to achieve heat storage within canopy layer, in the canopy +! 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) ! do i=1,im hflxq(i) = hflx(i) - evapq(i) = evap(i) hffac(i) = 1.0 - hefac(i) = 1.0 enddo if (lheatstrg) then do i=1,im - tem = 0.01 * zorl(i) ! change unit from cm to m - tem1 = (tem - z0min) / (z0max - z0min) - hffac(i) = z0fac * min(max(tem1, 0.0), 1.0) - tem = sqrt(u10m(i)**2+v10m(i)**2) - tem1 = (tem - u10min) / (u10max - u10min) - tem2 = 1.0 - min(max(tem1, 0.0), 1.0) - hffac(i) = tem2 * hffac(i) - hefac(i) = 1. + e0fac * hffac(i) - hffac(i) = 1. + hffac(i) - hflxq(i) = hflx(i) / hffac(i) - evapq(i) = evap(i) / hefac(i) + if (dry(i)) then + if(hflx(i) > 0.) then + hffac(i) = h0facu * zvfun(i) + else + hffac(i) = h0facs * zvfun(i) + endif + hffac(i) = 1. + hffac(i) + hflxq(i) = hflx(i) / hffac(i) + endif enddo endif diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index 2cdb1dbbe..3d7021b03 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -190,7 +190,7 @@ optional = F [dsnow_cpl] standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling - long_name = change in show_cpl (coupling_type) + long_name = change in snow_cpl (coupling_type) units = m dimensions = (horizontal_loop_extent) type = real @@ -354,42 +354,6 @@ kind = kind_phys intent = in optional = F -[tisfc] - standard_name = sea_ice_temperature - long_name = sea-ice surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[tsfco] - standard_name = sea_surface_temperature - long_name = sea surface temperature - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[fice] - standard_name = sea_ice_concentration - long_name = sea-ice concentration [0,1] - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[hice] - standard_name = sea_ice_thickness - long_name = sea-ice thickness - units = m - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level @@ -488,6 +452,14 @@ type = logical intent = in optional = F +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F [cplwav] standard_name = flag_for_wave_coupling long_name = flag controlling cplwav collection (default off) @@ -504,6 +476,14 @@ type = logical intent = in optional = F +[dry] + standard_name = flag_nonzero_land_surface_fraction + long_name = flag indicating presence of some land surface area fraction + units = flag + dimensions = (horizontal_loop_extent) + type = logical + intent = in + optional = F [icy] standard_name = flag_nonzero_sea_ice_surface_fraction long_name = flag indicating presence of some sea ice surface area fraction @@ -1257,33 +1237,24 @@ type = logical intent = in optional = F -[z0fac] - standard_name = surface_roughness_fraction_factor - long_name = surface roughness fraction factor for canopy heat storage parameterization +[h0facu] + standard_name = canopy_heat_storage_factor_for_sensible_heat_flux_in_unstable_surface_layer + long_name = canopy heat storage factor for sensible heat flux in unstable surface layer units = none dimensions = () type = real kind = kind_phys intent = in optional = F -[e0fac] - standard_name = latent_heat_flux_fraction_factor_relative_to_sensible_heat_flux - long_name = latent heat flux fraction factor relative to sensible heat flux for canopy heat storage parameterization +[h0facs] + standard_name = canopy_heat_storage_factor_for_sensible_heat_flux_in_stable_surface_layer + long_name = canopy heat storage factor for sensible heat flux in stable surface layer units = none dimensions = () type = real kind = kind_phys intent = in optional = F -[zorl] - standard_name = surface_roughness_length - long_name = surface roughness length - units = cm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [hflx] standard_name = kinematic_surface_upward_sensible_heat_flux long_name = kinematic surface upward sensible heat flux @@ -1303,22 +1274,22 @@ intent = in optional = F [hflxq] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness + 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 = out optional = F -[evapq] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness - units = kg kg-1 m s-1 +[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 = out + intent = in optional = F [hffac] standard_name = surface_upward_sensible_heat_flux_reduction_factor @@ -1329,15 +1300,6 @@ kind = kind_phys intent = out optional = F -[hefac] - standard_name = surface_upward_latent_heat_flux_reduction_factor - long_name = surface upward latent heat flux reduction factor from canopy heat storage - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = out - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 98ac6a07f..4b7648c38 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -66,7 +66,7 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_timestep_init Argument Table !! \htmlinclude GFS_time_vary_pre_timestep_init.html !! - subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, & + subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & nslwr, nhfrad, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, & kdt, julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) @@ -76,8 +76,7 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lkm, lsm, lsm_noahm integer, intent(in) :: idate(:) integer, intent(in) :: jdat(:), idat(:) - integer, intent(in) :: lkm, lsm, lsm_noahmp, & - nsswr, nslwr, me, & + integer, intent(in) :: nsswr, nslwr, me, & master, nscyc, nhfrad logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta index 6266889aa..16a124c12 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -76,30 +76,6 @@ kind = kind_phys intent = in optional = F -[lkm] - standard_name = flag_for_lake_surface_scheme - long_name = flag for lake surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm] - standard_name = flag_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm_noahmp] - standard_name = flag_for_noahmp_land_surface_scheme - long_name = flag for NOAH MP land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls diff --git a/physics/GFS_time_vary_pre.scm.F90 b/physics/GFS_time_vary_pre.scm.F90 index c9ee9f946..0c34ca735 100644 --- a/physics/GFS_time_vary_pre.scm.F90 +++ b/physics/GFS_time_vary_pre.scm.F90 @@ -65,7 +65,7 @@ end subroutine GFS_time_vary_pre_finalize !> \section arg_table_GFS_time_vary_pre_timestep_init Argument Table !! \htmlinclude GFS_time_vary_pre_timestep_init.html !! - subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lsm, lsm_noahmp, nsswr, & + subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, nsswr, & nslwr, idate, debug, me, master, nscyc, sec, phour, zhour, fhour, kdt, & julian, yearlen, ipt, lprnt, lssav, lsswr, lslwr, solhr, errmsg, errflg) @@ -75,8 +75,7 @@ subroutine GFS_time_vary_pre_timestep_init (jdat, idat, dtp, lsm, lsm_noahmp, ns integer, intent(in) :: idate(:) integer, intent(in) :: jdat(:), idat(:) - integer, intent(in) :: lsm, lsm_noahmp, & - nsswr, nslwr, me, & + integer, intent(in) :: nsswr, nslwr, me, & master, nscyc logical, intent(in) :: debug real(kind=kind_phys), intent(in) :: dtp diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/GFS_time_vary_pre.scm.meta index 5033f7988..5b6648a96 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/GFS_time_vary_pre.scm.meta @@ -76,22 +76,6 @@ kind = kind_phys intent = in optional = F -[lsm] - standard_name = flag_for_land_surface_scheme - long_name = flag for land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F -[lsm_noahmp] - standard_name = flag_for_noahmp_land_surface_scheme - long_name = flag for NOAH MP land surface model - units = flag - dimensions = () - type = integer - intent = in - optional = F [nsswr] standard_name = number_of_timesteps_between_shortwave_radiation_calls long_name = number of timesteps between shortwave radiation calls diff --git a/physics/aerinterp.F90 b/physics/aerinterp.F90 index 25472632f..dbcf73603 100644 --- a/physics/aerinterp.F90 +++ b/physics/aerinterp.F90 @@ -98,7 +98,7 @@ END SUBROUTINE read_aerdata ! !********************************************************************** SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & - me, master, iflip, idate, errmsg, errflg) + me, master, iflip, idate, errmsg, errflg) use machine, only: kind_phys, kind_io4, kind_io8 use aerclm_def use netcdf @@ -172,23 +172,23 @@ SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & call nf_get_var(ncid, varid, buffx) do j = jamin, jamax - do k = 1, levsaer + do k = 1, levsaer ! input is from toa to sfc - if ( iflip == 0 ) then ! data from toa to sfc - klev = k - else ! data from sfc to top - klev = ( levsw - k ) + 1 - endif - do i = iamin, iamax - aerin(i,j,k,ii,imon) = 1.d0*buffx(i,j,klev,1) - if(aerin(i,j,k,ii,imon)<0.or.aerin(i,j,k,ii,imon)>1.) then - aerin(i,j,k,ii,imon) = 1.e-15 - end if - enddo !i-loop (lon) - enddo !k-loop (lev) - enddo !j-loop (lat) - - ENDDO ! ii-loop (ntracaerm) + if ( iflip == 0 ) then ! data from toa to sfc + klev = k + else ! data from sfc to top + klev = ( levsw - k ) + 1 + endif + do i = iamin, iamax + aerin(i,j,k,ii,imon) = 1.d0*buffx(i,j,klev,1) + if(aerin(i,j,k,ii,imon) < 0 .or. aerin(i,j,k,ii,imon) > 1.) then + aerin(i,j,k,ii,imon) = 1.e-15 + endif + enddo !i-loop (lon) + enddo !k-loop (lev) + enddo !j-loop (lat) + + ENDDO ! ii-loop (ntracaerm) ! close the file call nf_close(ncid) @@ -199,7 +199,7 @@ SUBROUTINE read_aerdataf (iamin, iamax, jamin, jamax, & END SUBROUTINE read_aerdataf ! SUBROUTINE setindxaer(npts,dlat,jindx1,jindx2,ddy,dlon, & - iindx1,iindx2,ddx,me,master) + iindx1,iindx2,ddx,me,master) ! USE MACHINE, ONLY: kind_phys use aerclm_def, only: aer_lat, jaero=>latsaer, & @@ -257,16 +257,17 @@ END SUBROUTINE setindxaer !********************************************************************** ! SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & - ddy,iindx1,iindx2,ddx,lev,prsl,aerout) + ddy,iindx1,iindx2,ddx,lev,prsl,aerout) ! USE MACHINE, ONLY : kind_phys use aerclm_def implicit none integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i,ii - real(kind=kind_phys) fhour,temj, tx1, tx2,temi + real(kind=kind_phys) fhour,temj, tx1, tx2,temi, tem + real(kind=kind_phys), dimension(npts) :: temij,temiy,temjx,ddxy ! - integer JINDX1(npts), JINDX2(npts),iINDX1(npts),iINDX2(npts) + integer JINDX1(npts), JINDX2(npts), iINDX1(npts), iINDX2(npts) integer me,idate(4), master, nthrds integer IDAT(8),JDAT(8) ! @@ -279,16 +280,16 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & 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 + 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 + if(w3kindreal == 4) then + rinc4 = rinc CALL W3MOVDAT(RINC4,IDAT,JDAT) else CALL W3MOVDAT(RINC,IDAT,JDAT) @@ -299,11 +300,11 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & jday = 0 call w3doxdat(jdat,jdow,jdoy,jday) rjday = jdoy + jdat(5) / 24. - IF (RJDAY .LT. aer_time(1)) RJDAY = RJDAY+365. + IF (RJDAY < aer_time(1)) RJDAY = RJDAY+365. ! n2 = 13 do j=2, 12 - if (rjday .lt. aer_time(j)) then + if (rjday < aer_time(j)) then n2 = j exit endif @@ -314,37 +315,45 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & tx2 = 1.0 - tx1 if (n2 > 12) n2 = n2 -12 + do j=1,npts + TEMJ = 1.0 - DDY(J) + TEMI = 1.0 - DDX(J) + temij(j) = TEMI*TEMJ + temiy(j) = TEMI*DDY(j) + temjx(j) = TEMJ*DDX(j) + ddxy(j) = DDX(j)*DDY(J) + enddo + #ifndef __GFORTRAN__ !$OMP parallel num_threads(nthrds) default(none) & !$OMP shared(npts,ntrcaer,aerin,aer_pres,prsl) & !$OMP shared(ddx,ddy,jindx1,jindx2,iindx1,iindx2) & !$OMP shared(aerpm,aerpres,aerout,n1,n2,lev,nthrds) & -!$OMP private(l,j,k,ii,i1,i2,j1,j2,temj,temi) & +!$OMP shared(temij,temiy,temjx,ddxy) & +!$OMP private(l,j,k,ii,i1,i2,j1,j2,tem) & !$OMP copyin(tx1,tx2) firstprivate(tx1,tx2) !$OMP do #endif DO L=1,levsaer DO J=1,npts - J1 = JINDX1(J) - J2 = JINDX2(J) - TEMJ = 1.0 - DDY(J) - I1 = IINDX1(J) - I2 = IINDX2(J) - TEMI = 1.0 - DDX(J) + J1 = JINDX1(J) + J2 = JINDX2(J) + I1 = IINDX1(J) + I2 = IINDX2(J) DO ii=1,ntrcaer - aerpm(j,L,ii) = & - tx1*(TEMI*TEMJ*aerin(I1,J1,L,ii,n1)+DDX(j)*DDY(J)*aerin(I2,J2,L,ii,n1)& - +TEMI*DDY(j)*aerin(I1,J2,L,ii,n1)+DDX(j)*TEMJ*aerin(I2,J1,L,ii,n1))& - +tx2*(TEMI*TEMJ*aerin(I1,J1,L,ii,n2)+DDX(j)*DDY(J)*aerin(I2,J2,L,ii,n2) & - +TEMI*DDY(j)*aerin(I1,J2,L,ii,n2)+DDX(j)*TEMJ*aerin(I2,J1,L,ii,n2)) + aerpm(j,L,ii) = & + tx1*(TEMIJ(j)*aerin(I1,J1,L,ii,n1)+DDXY(j)*aerin(I2,J2,L,ii,n1) & + +TEMIY(j)*aerin(I1,J2,L,ii,n1)+temjx(j)*aerin(I2,J1,L,ii,n1))& + +tx2*(TEMIJ(j)*aerin(I1,J1,L,ii,n2)+DDXY(j)*aerin(I2,J2,L,ii,n2) & + +TEMIY(j)*aerin(I1,J2,L,ii,n2)+temjx(j)*aerin(I2,J1,L,ii,n2)) ENDDO - aerpres(j,L) = & - tx1*(TEMI*TEMJ*aer_pres(I1,J1,L,n1)+DDX(j)*DDY(J)*aer_pres(I2,J2,L,n1)& - +TEMI*DDY(j)*aer_pres(I1,J2,L,n1)+DDX(j)*TEMJ*aer_pres(I2,J1,L,n1))& - +tx2*(TEMI*TEMJ*aer_pres(I1,J1,L,n2)+DDX(j)*DDY(J)*aer_pres(I2,J2,L,n2) & - +TEMI*DDY(j)*aer_pres(I1,J2,L,n2)+DDX(j)*TEMJ*aer_pres(I2,J1,L,n2)) + aerpres(j,L) = & + tx1*(TEMIJ(j)*aer_pres(I1,J1,L,n1)+DDXY(j)*aer_pres(I2,J2,L,n1) & + +TEMIY(j)*aer_pres(I1,J2,L,n1)+temjx(j)*aer_pres(I2,J1,L,n1))& + +tx2*(TEMIJ(j)*aer_pres(I1,J1,L,n2)+DDXY(j)*aer_pres(I2,J2,L,n2) & + +TEMIY(j)*aer_pres(I1,J2,L,n2)+temjx(j)*aer_pres(I2,J1,L,n2)) ENDDO ENDDO #ifndef __GFORTRAN__ @@ -355,28 +364,27 @@ SUBROUTINE aerinterpol(me,master,nthrds,npts,IDATE,FHOUR,jindx1,jindx2, & #endif DO J=1,npts DO L=1,lev - if(prsl(j,L).ge.aerpres(j,1)) then + if(prsl(j,L) >= aerpres(j,1)) then DO ii=1, ntrcaer - aerout(j,L,ii)=aerpm(j,1,ii) !! sfc level + aerout(j,L,ii) = aerpm(j,1,ii) !! sfc level ENDDO - else if(prsl(j,L).le.aerpres(j,levsaer)) then + else if(prsl(j,L) <= aerpres(j,levsaer)) then DO ii=1, ntrcaer - aerout(j,L,ii)=aerpm(j,levsaer,ii) !! toa top + aerout(j,L,ii) = aerpm(j,levsaer,ii) !! toa top ENDDO else DO k=1, levsaer-1 !! from sfc to toa - IF(prsl(j,L)aerpres(j,k+1)) then - i1=k - i2=min(k+1,levsaer) + IF(prsl(j,L) < aerpres(j,k) .and. prsl(j,L)>aerpres(j,k+1)) then + i1 = k + i2 = min(k+1,levsaer) exit ENDIF ENDDO - temi = prsl(j,L)-aerpres(j,i2) - temj = aerpres(j,i1) - prsl(j,L) - tx1 = temi/(aerpres(j,i1) - aerpres(j,i2)) - tx2 = temj/(aerpres(j,i1) - aerpres(j,i2)) + tem = 1.0 / (aerpres(j,i1) - aerpres(j,i2)) + tx1 = (prsl(j,L) - aerpres(j,i2)) * tem + tx2 = (aerpres(j,i1) - prsl(j,L)) * tem DO ii = 1, ntrcaer - aerout(j,L,ii)= aerpm(j,i1,ii)*tx1 + aerpm(j,i2,ii)*tx2 + aerout(j,L,ii) = aerpm(j,i1,ii)*tx1 + aerpm(j,i2,ii)*tx2 ENDDO endif ENDDO !L-loop diff --git a/physics/cs_conv.F90 b/physics/cs_conv.F90 index d47dcd457..8ed33f0d3 100644 --- a/physics/cs_conv.F90 +++ b/physics/cs_conv.F90 @@ -13,7 +13,7 @@ end subroutine cs_conv_pre_finalize !! \section arg_table_cs_conv_pre_run Argument Table !! \htmlinclude cs_conv_pre_run.html !! - subroutine cs_conv_pre_run(im, levs, ntrac, ncld, q, clw1, clw2, & + subroutine cs_conv_pre_run(im, levs, ntrac, q, clw1, clw2, & & work1, work2, cs_parm1, cs_parm2, wcbmax, & & fswtr, fscav, save_q1, save_q2, save_q3, & & errmsg, errflg) @@ -24,7 +24,7 @@ subroutine cs_conv_pre_run(im, levs, ntrac, ncld, q, clw1, clw2, & implicit none ! --- inputs - integer, intent(in) :: im, levs, ntrac, ncld + integer, intent(in) :: im, levs, ntrac real(kind_phys), dimension(:,:), intent(in) :: q real(kind_phys), dimension(:,:), intent(in) :: clw1,clw2 real(kind_phys), dimension(:), intent(in) :: work1, work2 diff --git a/physics/cs_conv.meta b/physics/cs_conv.meta index 14a0d5bf2..5766cc3c2 100644 --- a/physics/cs_conv.meta +++ b/physics/cs_conv.meta @@ -31,14 +31,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [q] standard_name = water_vapor_specific_humidity_updated_by_physics long_name = water vapor specific humidity updated by physics diff --git a/physics/cs_conv_aw_adj.F90 b/physics/cs_conv_aw_adj.F90 index 74cac9184..4b54290bd 100644 --- a/physics/cs_conv_aw_adj.F90 +++ b/physics/cs_conv_aw_adj.F90 @@ -27,7 +27,7 @@ end subroutine cs_conv_aw_adj_finalize !! !\section gen_cs_conv_aw_adj_run CPT cs_conv_aw_adj_run General Algorithm subroutine cs_conv_aw_adj_run(im, levs, do_cscnv, do_aw, do_shoc, & - ntrac, ncld, ntcw, ntclamt, nncl, con_g, sigmafrac, & + ntrac, ntcw, ntclamt, nncl, con_g, sigmafrac, & gt0, gq0, save_t, save_q, prsi, cldfrac, subcldfrac, & prcp, imp_physics, imp_physics_mg, errmsg, errflg) @@ -38,7 +38,7 @@ subroutine cs_conv_aw_adj_run(im, levs, do_cscnv, do_aw, do_shoc, & ! --- interface variables integer, intent(in) :: im, levs logical, intent(in) :: do_cscnv, do_aw, do_shoc - integer, intent(in) :: ntrac, ncld, ntcw, ntclamt, nncl + integer, intent(in) :: ntrac, ntcw, ntclamt, nncl real(kind_phys), intent(in) :: con_g real(kind_phys), dimension(:,:), intent(inout) :: sigmafrac real(kind_phys), dimension(:,:), intent(inout) :: gt0 diff --git a/physics/cs_conv_aw_adj.meta b/physics/cs_conv_aw_adj.meta index 720330c50..b0b8e6244 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/cs_conv_aw_adj.meta @@ -55,14 +55,6 @@ type = integer intent = in optional = F -[ncld] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors - units = count - dimensions = () - type = integer - intent = in - optional = F [ntcw] standard_name = index_for_liquid_cloud_condensate long_name = tracer index for cloud condensate (or liquid water) @@ -80,8 +72,8 @@ intent = in optional = F [nncl] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index e1121863b..2aa3f3614 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -310,8 +310,8 @@ intent = in optional = F [hfx2] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness + 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 @@ -319,8 +319,8 @@ intent = in optional = F [qfx2] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) type = real diff --git a/physics/cu_ntiedtke.meta b/physics/cu_ntiedtke.meta index 4d4c6597a..235168f83 100644 --- a/physics/cu_ntiedtke.meta +++ b/physics/cu_ntiedtke.meta @@ -204,8 +204,8 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) type = real @@ -213,8 +213,8 @@ intent = in optional = F [hfx] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness + 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 diff --git a/physics/dcyc2.f b/physics/dcyc2.f index ad9365851..7cc14b389 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -178,7 +178,7 @@ subroutine dcyc2t3_run & & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & & im, levs, deltim, fhswr, & - & dry, icy, wet, & + & dry, icy, wet, damp_LW_fluxadj, lfnc_k, lfnc_p0, & & minGPpres, use_LW_jacobian, sfculw, fluxlwUP_jac, & & t_lay, t_lev, p_lay, p_lev, flux2D_lwUP, flux2D_lwDOWN, & & pert_radtend, do_sppt,ca_global, & @@ -213,10 +213,11 @@ subroutine dcyc2t3_run & ! integer, intent(in) :: ipr ! logical lprnt logical, dimension(:), intent(in) :: dry, icy, wet - logical, intent(in) :: use_LW_jacobian, pert_radtend + logical, intent(in) :: use_LW_jacobian, damp_LW_fluxadj, & + & pert_radtend logical, intent(in) :: do_sppt,ca_global real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & - & deltim, fhswr, minGPpres + & deltim, fhswr, minGPpres, lfnc_k, lfnc_p0 real(kind=kind_phys), dimension(:), intent(in) :: & & sinlat, coslat, xlon, coszen, tf, tsflw, sfcdlw, & @@ -253,11 +254,19 @@ subroutine dcyc2t3_run & integer, intent(out) :: errflg ! --- locals: - integer :: i, k, nstp, nstl, it, istsun(im),iSFC + integer :: i, k, nstp, nstl, it, istsun(im),iSFC,iTOA real(kind=kind_phys) :: cns, coszn, tem1, tem2, anginc, & & rstl, solang, dT real(kind=kind_phys), dimension(im,levs+1) :: flxlwup_adj, & & flxlwdn_adj, t_lev2 + real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,dT_sfc, & + &fluxlwDOWN_jac,lfnc,c1 + ! Length scale for flux-adjustment scaling + real(kind=kind_phys), parameter :: & + & L = 1. + ! Scaling factor for downwelling LW Jacobian profile. + real(kind=kind_phys), parameter :: & + & gamma = 0.2 ! !===> ... begin here ! @@ -267,9 +276,11 @@ subroutine dcyc2t3_run & ! Vertical ordering? if (p_lev(1,1) .lt. p_lev(1, levs)) then - iSFC = levs + iSFC = levs + 1 + iTOA = 1 else iSFC = 1 + iTOA = levs + 1 endif tem1 = fhswr / deltim @@ -310,15 +321,15 @@ subroutine dcyc2t3_run & ! do i = 1, im - tem1 = tf(i) / tsflw(i) - tem2 = tem1 * tem1 - adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 !> - LW time-step adjustment: if (use_LW_Jacobian) then ! F_adj = F_o + (dF/dT) * dT dT = tf(i) - tsflw(i) adjsfculw(i) = sfculw(i) + fluxlwUP_jac(i,iSFC) * dT else + tem1 = tf(i) / tsflw(i) + tem2 = tem1 * tem1 + adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 !! - adjust \a sfc downward LW flux to account for t changes in the lowest model layer. !! compute 4th power of the ratio of \c tf in the lowest model layer over the mean value \c tsflw. if (dry(i)) then @@ -375,32 +386,47 @@ subroutine dcyc2t3_run & call cmp_tlev(im, levs, minGPpres, p_lay, t_lay, p_lev, tsfc, & & t_lev2) + ! Compute adjusted net LW flux foillowing Hogan and Bozzo 2015 (10.1002/2015MS000455) + ! Here we assume that the profile of the downwelling LW Jaconiam has the same shape + ! as the upwelling, but scaled and offset. + ! The scaling factor is 0.2 + ! The profile of the downwelling Jacobian (J) is offset so that + ! J_dn_sfc / J_up_sfc = scaling_factor + ! J_dn_toa / J_up_sfc = 0 ! - ! Adjust up/downward fluxes (at layer interfaces). - ! - do k = 1, levs+1 - do i = 1, im - dT = t_lev2(i,k) - t_lev(i,k) - flxlwup_adj(i,k) = flux2D_lwUP(i,k) + & - & fluxlwUP_jac(i,k)*dT - enddo - enddo - ! - ! Compute new heating rate (within each layer). - ! - do k = 1, levs - htrlw(1:im,k) = & - & (flxlwup_adj(1:im,k+1) - flxlwup_adj(1:im,k) - & - & flux2D_lwDOWN(1:im,k+1) + flux2D_lwDOWN(1:im,k)) * & - & con_g / (con_cp * (p_lev(1:im,k+1) - p_lev(1:im,k))) - enddo - - ! - ! Add radiative heating rates to physics heating rate - ! - do k = 1, levs - do i = 1, im - dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + htrlw(i,k) + ! Optionally, the flux adjustment can be damped with height using a logistic function + ! fx ~ L / (1 + exp(-k*dp)), where dp = p - p0 + ! L = 1, fix scale between 0-1. - Fixed + ! k = 1 / pressure decay length (Pa) - Controlled by namelist + ! p0 = Transition pressure (Pa) - Controlled by namelsit + do i = 1, im + c1 = fluxlwUP_jac(i,iTOA) / fluxlwUP_jac(i,iSFC) + dT_sfc = t_lev2(i,iSFC) - t_lev(i,iSFC) + do k = 1, levs + ! LW net flux + fluxlwnet = (flux2D_lwUP(i, k+1) - flux2D_lwUP(i, k) - & + & flux2D_lwDOWN(i,k+1) + flux2D_lwDOWN(i,k)) + ! Downward LW Jacobian (Eq. 9) + fluxlwDOWN_jac = gamma * & + & (fluxlwUP_jac(i,k)/fluxlwUP_jac(i,iSFC) - c1) / & + & (1 - c1) + ! Adjusted LW net flux(Eq. 10) + fluxlwnet_adj = fluxlwnet + dT_sfc* & + & (fluxlwUP_jac(i,k)/fluxlwUP_jac(i,iSFC) - & + & fluxlwDOWN_jac) + ! Adjusted LW heating rate + htrlw(i,k) = fluxlwnet_adj * con_g / & + & (con_cp * (p_lev(i,k+1) - p_lev(i,k))) + + ! Add radiative heating rates to physics heating rate. Optionally, scaled w/ height + ! using a logistic function + if (damp_LW_fluxadj) then + lfnc = L / (1+exp(-(p_lev(i,k) - lfnc_p0)/lfnc_k)) + else + lfnc = 1. + endif + dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + & + & htrlw(i,k)*lfnc + (1.-lfnc)*hlw(i,k) enddo enddo else diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index a460db7ab..91e01a2d2 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -370,6 +370,32 @@ type = logical intent = in optional = F +[damp_LW_fluxadj] + standard_name = flag_to_damp_RRTMGP_LW_jacobian_flux_adjustment + long_name = logical flag to control RRTMGP LW calculation + units = flag + dimensions = () + type = logical + intent = in + optional = F +[lfnc_k] + standard_name = transition_pressure_length_scale_for_flux_damping + long_name = depth of transition layer in logistic function for LW flux adjustment damping + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[lfnc_p0] + standard_name = transition_pressure_for_flux_damping + long_name = transition pressure for LW flux adjustment damping + units = Pa + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [sfculw] standard_name = surface_upwelling_longwave_flux_on_radiation_time_step long_name = total sky sfc upward lw flux diff --git a/physics/flake_driver.F90 b/physics/flake_driver.F90 index 1e8714461..94fe8286b 100644 --- a/physics/flake_driver.F90 +++ b/physics/flake_driver.F90 @@ -62,13 +62,13 @@ SUBROUTINE flake_driver_run ( & ! ! Declarations ! use module_flake_ini, only:flake_init - use module_FLake + use module_FLake ! use flake_albedo_ref ! use data_parameters ! use flake_derivedtypes -! use flake_paramoptic_ref +! use flake_paramoptic_ref ! use flake_parameters - use machine , only : kind_phys + use machine , only : kind_phys ! use funcphys, only : fpvs ! use physcons, only : grav => con_g, cp => con_cp, & ! & hvap => con_hvap, rd => con_rd, & @@ -76,10 +76,10 @@ SUBROUTINE flake_driver_run ( & ! & rvrdm1 => con_fvirt !============================================================================== -IMPLICIT NONE + implicit none integer, intent(in) :: im, imon,yearlen -! integer, dimension(im), intent(in) :: islmsk +! integer, dimension(im), intent(in) :: islmsk real (kind=kind_phys), dimension(:), intent(in) :: ps, wind, & & t1, q1, dlwflx, dswsfc, zlvl, elev @@ -91,7 +91,7 @@ SUBROUTINE flake_driver_run ( & real (kind=kind_phys),dimension(:),intent(inout) :: & & snwdph, hice, tsurf, t_sfc, hflx, evap, fice, ustar, qsfc, & - & ch, cm, chh, cmm + & ch, cm, chh, cmm real (kind=kind_phys), intent(in) :: julian @@ -116,184 +116,190 @@ SUBROUTINE flake_driver_run ( & h_ML , & ! Thickness of the mixed-layer [m] H_B1 , & ! Thickness of the upper layer of bottom sediments [m] w_albedo , & ! - w_extinc + w_extinc ! Input (procedure arguments) -REAL (KIND = kind_phys) :: & - - dMsnowdt_in , & ! The rate of snow accumulation [kg m^{-2} s^{-1}] - I_atm_in , & ! Solar radiation flux at the surface [W m^{-2}] - Q_atm_lw_in , & ! Long-wave radiation flux from the atmosphere [W m^{-2}] - height_u_in , & ! Height above the lake surface where the wind speed is measured [m] - height_tq_in , & ! Height where temperature and humidity are measured [m] - U_a_in , & ! Wind speed at z=height_u_in [m s^{-1}] - T_a_in , & ! Air temperature at z=height_tq_in [K] - q_a_in , & ! Air specific humidity at z=height_tq_in - P_a_in ! Surface air pressure [N m^{-2} = kg m^{-1} s^{-2}] - -REAL (KIND = kind_phys) :: & - depth_w , & ! The lake depth [m] - fetch_in , & ! Typical wind fetch [m] - depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] - T_bs_in , & ! Temperature at the outer edge of + REAL (KIND = kind_phys) :: & + + dMsnowdt_in , & ! The rate of snow accumulation [kg m^{-2} s^{-1}] + I_atm_in , & ! Solar radiation flux at the surface [W m^{-2}] + Q_atm_lw_in , & ! Long-wave radiation flux from the atmosphere [W m^{-2}] + height_u_in , & ! Height above the lake surface where the wind speed is measured [m] + height_tq_in , & ! Height where temperature and humidity are measured [m] + U_a_in , & ! Wind speed at z=height_u_in [m s^{-1}] + T_a_in , & ! Air temperature at z=height_tq_in [K] + q_a_in , & ! Air specific humidity at z=height_tq_in + P_a_in ! Surface air pressure [N m^{-2} = kg m^{-1} s^{-2}] + + REAL (KIND = kind_phys) :: & + depth_w , & ! The lake depth [m] + fetch_in , & ! Typical wind fetch [m] + depth_bs_in , & ! Depth of the thermally active layer of the bottom sediments [m] + T_bs_in , & ! Temperature at the outer edge of ! the thermally active layer of the bottom sediments [K] - par_Coriolis , & ! The Coriolis parameter [s^{-1}] - del_time ! The model time step [s] - -REAL (KIND = kind_phys) :: & - T_snow_in , & ! Temperature at the air-snow interface [K] - T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] - 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] - C_T_in , & ! Shape factor (thermocline) - h_snow_in , & ! Snow thickness [m] - h_ice_in , & ! Ice thickness [m] - h_ML_in , & ! Thickness of the mixed-layer [m] - H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_in , & ! Surface temperature at the previous time step [K] - ch_in , & - cm_in , & - albedo_water , & - water_extinc - -REAL (KIND = kind_phys) :: & - T_snow_out , & ! Temperature at the air-snow interface [K] - T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] - 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] - C_T_out , & ! Shape factor (thermocline) - h_snow_out , & ! Snow thickness [m] - h_ice_out , & ! Ice thickness [m] - h_ML_out , & ! Thickness of the mixed-layer [m] - H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] - T_sfc_out , & ! surface temperature [K] - T_sfc_n , & ! Updated surface temperature [K] - u_star , & - q_sfc , & - chh_out , & - cmm_out - -REAL (KIND = kind_phys) :: & - 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}] - -REAL (KIND = kind_phys) :: & - lake_depth_max, T_bot_2_in, T_bot_2_out, dxlat,tb,tr,tt,temp,Kbar, DelK - - -REAL (KIND = kind_phys) :: x, y !temperarory variables used for Tbot and Tsfc - !initilizations - -INTEGER :: i,ipr,iter - -LOGICAL :: lflk_botsed_use -logical :: flag(im) -CHARACTER(LEN=*), PARAMETER :: FMT2 = "(1x,8(F12.4,1x))" + par_Coriolis , & ! The Coriolis parameter [s^{-1}] + del_time ! The model time step [s] + + REAL (KIND = kind_phys) :: & + T_snow_in , & ! Temperature at the air-snow interface [K] + T_ice_in , & ! Temperature at the snow-ice or air-ice interface [K] + 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] + C_T_in , & ! Shape factor (thermocline) + h_snow_in , & ! Snow thickness [m] + h_ice_in , & ! Ice thickness [m] + h_ML_in , & ! Thickness of the mixed-layer [m] + H_B1_in , & ! Thickness of the upper layer of bottom sediments [m] + T_sfc_in , & ! Surface temperature at the previous time step [K] + ch_in , & + cm_in , & + albedo_water , & + water_extinc + + REAL (KIND = kind_phys) :: & + T_snow_out , & ! Temperature at the air-snow interface [K] + T_ice_out , & ! Temperature at the snow-ice or air-ice interface [K] + 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] + C_T_out , & ! Shape factor (thermocline) + h_snow_out , & ! Snow thickness [m] + h_ice_out , & ! Ice thickness [m] + h_ML_out , & ! Thickness of the mixed-layer [m] + H_B1_out , & ! Thickness of the upper layer of bottom sediments [m] + T_sfc_out , & ! surface temperature [K] + T_sfc_n , & ! Updated surface temperature [K] + u_star , & + q_sfc , & + chh_out , & + cmm_out + + REAL (KIND = kind_phys) :: & + 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}] + + REAL (KIND = kind_phys) :: & + 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 !temperarory variables used for Tbot and Tsfc + !initilizations + + INTEGER :: i,ipr,iter + + LOGICAL :: lflk_botsed_use, do_flake + logical :: flag(im) +! CHARACTER(LEN=*), PARAMETER :: FMT2 = "(1x,8(F12.4,1x))" !============================================================================== ! Start calculations !------------------------------------------------------------------------------ -! FLake_write need to assign original value to make the model somooth - - lake_depth_max = 60.0 - ipr = min(im,10) +! FLake_write need to assign original value to make the model somooth ! --- ... set flag for lake points + do_flake = .false. do i = 1, im - flag(i) = (wet(i) .and. flag_iter(i)) + flag(i) = wet(i) .and. flag_iter(i) .and. use_flake(i) + do_flake = flag(i) .or. do_flake enddo - Kbar=3.5 - DelK=3.0 + if (.not. do_flake) return + + lake_depth_max = 60.0 + ipr = min(im,10) + + x = 0.03279*julian + y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 + + temp = (pi+pi)*(julian-1)/float(yearlen) + temp = 0.006918-0.399912*cos(temp)+0.070257*sin(temp) & + - 0.006758*cos(2.0*temp)+0.000907*sin(2.0*temp) & + - 0.002697*cos(3.0*temp)+0.00148*sin(3.0*temp) + + temp2 = sin((pi+pi)*(julian-151)/244) do i = 1, im if (flag(i)) then - if( use_flake(i) ) then - T_ice(i) = 273.15 - T_snow(i) = 273.15 - fetch(i) = 2.0E+03 - C_T(i) = 0.50 - - dxlat = 57.29578*abs(xlat(i)) - tt = 29.275+0.0813*dxlat-0.0052*dxlat*dxlat-0.0038*elev(i)+273.15 - tb = 29.075-0.7566*dxlat+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 + 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 - if(snwdph(i).gt.0.0 .or. hice(i).gt.0.0) then - if(tsurf(i).lt.T_ice(i)) then - T_sfc(i) = T_ice(i) - else - T_sfc(i) = tsurf(i) - endif - else -! if(tsurf(i).lt.tt) then -! T_sfc(i) = tt -! else -! T_sfc(i) = tsurf(i) -! endif - T_sfc(i) = 0.1*tt + 0.9* 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 - x = 0.03279*julian - if(xlat(i) .ge. 0.0) then - y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 - T_sfc(i) = T_sfc(i) + 0.3*y - tb = tb + 0.05*y - else - y = ((((0.0034*x-0.1241)*x+1.6231)*x-8.8666)*x+17.206)*x-4.2929 - 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).lt.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 - -! compute albedo as a function of julian day and latitute - temp = 2*3.14159265*(julian-1)/float(yearlen) - temp = 0.006918-0.399912*cos(temp)+0.070257*sin(temp)- & - 0.006758*cos(2.0*temp)+0.000907*sin(2.0*temp) - & - 0.002697*cos(3.0*temp)+0.00148*sin(3.0*temp) - w_albedo(I) = 0.06/cos((xlat(i)-temp)/1.2) -! w_albedo(I) = 0.06 + 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 + +! compute albedo as a function of julian day and latitude + 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 - if(julian.lt.90 .or. julian .gt. 333) then - w_extinc(i) = Kbar-Kbar/DelK - else - w_extinc(i) = Kbar+Kbar/DelK*sin(2*3.14159265*(julian-151)/244) - endif -! w_extinc(i) = 3.0 + if (julian < 90 .or. julian > 333) then + w_extinc(i) = Kbar - KbaroDelK + else + w_extinc(i) = Kbar + KbaroDelK*temp2 + 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) - endif !lake endif !flag enddo 1001 format ( 'At icount=', i5, ' x = ', f5.2,5x, 'y = ', & @@ -302,55 +308,54 @@ SUBROUTINE flake_driver_run ( & 1002 format (I4,1x,3(f8.4,1x),6(f11.4,1x)) -! +! ! call lake interface do i=1,im - if (flag(i)) then - if( use_flake(i) ) then - dMsnowdt_in = weasd(i)/delt - I_atm_in = dswsfc(i) - Q_atm_lw_in = dlwflx(i) - height_u_in = zlvl(i) - height_tq_in = zlvl(i) - U_a_in = wind(i) - T_a_in = t1(i) - q_a_in = q1(i) - P_a_in = ps(i) - ch_in = ch(i) - cm_in = cm(i) - albedo_water= w_albedo(i) - water_extinc= w_extinc(i) - - 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) - par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) - del_time = delt - - 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_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_B1(i) - T_sfc_in = T_sfc(i) - - T_bot_2_in = T_bot(i) - Q_SHT_flx = hflx(i) - Q_watvap = evap(i) + 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) + height_tq_in = zlvl(i) + U_a_in = wind(i) + T_a_in = t1(i) + q_a_in = q1(i) + P_a_in = ps(i) + ch_in = ch(i) + cm_in = cm(i) + albedo_water = w_albedo(i) + water_extinc = w_extinc(i) + + 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) + par_Coriolis = 2 * 7.2921 / 100000. * sin ( xlat(i) ) + del_time = delt + + 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_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_B1(i) + T_sfc_in = T_sfc(i) + + T_bot_2_in = T_bot(i) + Q_SHT_flx = hflx(i) + Q_watvap = evap(i) !------------------------------------------------------------------------------ ! Set the rate of snow accumulation !------------------------------------------------------------------------------ - CALL flake_interface(dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, & + CALL flake_interface(dMsnowdt_in, I_atm_in, Q_atm_lw_in, height_u_in, & 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, & @@ -362,45 +367,45 @@ SUBROUTINE flake_driver_run ( & 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 ) + T_bot_2_in, T_bot_2_out,u_star, q_sfc,chh_out,cmm_out ) !------------------------------------------------------------------------------ ! Update output and values for previous time step ! - T_snow(i) = T_snow_out - T_ice(i) = T_ice_out - T_mnw(i) = T_mnw_out - 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 - C_T(i) = C_T_out - h_ML(i) = h_ML_out - H_B1(i) = H_B1_out - ustar(i) = u_star - qsfc(i) = q_sfc - chh(i) = chh_out - cmm(i) = cmm_out - snwdph(i) = h_snow_out - hice(i) = h_ice_out - evap(i) = Q_watvap - hflx(i) = Q_SHT_flx - - if(hice(i) .gt. 0.0 .or. snwdph(i) .gt. 0.0) then - fice(i) = 1.0 - else - fice(i) = 0.0 - endif - enddo !iter loop - endif !endif of lake - endif !endif of flag - - ENDDO - - 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)) + T_snow(i) = T_snow_out + T_ice(i) = T_ice_out + T_mnw(i) = T_mnw_out + 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 + C_T(i) = C_T_out + h_ML(i) = h_ML_out + H_B1(i) = H_B1_out + ustar(i) = u_star + qsfc(i) = q_sfc + chh(i) = chh_out + cmm(i) = cmm_out + snwdph(i) = h_snow_out + 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 + enddo !iter loop + + endif !endif of flag + + enddo + +!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 !============================================================================== diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index 74fb6b7e6..959b5b43f 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -114,8 +114,8 @@ intent = in optional = F [weasd] - standard_name = water_equivalent_accumulated_snow_depth_over_water - long_name = water equiv of acc snow depth over water + 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 @@ -132,8 +132,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical @@ -217,8 +217,8 @@ intent = in optional = F [snwdph] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water + 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 diff --git a/physics/gcm_shoc.meta b/physics/gcm_shoc.meta index b021fa306..f44560890 100644 --- a/physics/gcm_shoc.meta +++ b/physics/gcm_shoc.meta @@ -288,8 +288,8 @@ intent = in optional = F [hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 @@ -297,7 +297,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index 558a65860..718b375af 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -15,17 +15,17 @@ 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, & - input_nml_file, lsoil, lsoil_lsm, kice, idate, ialb, isot, ivegsrc, & - use_ufo, nst_anl, fhcyc, phour, 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, & + subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & + 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) ! ! - use machine, only: kind_phys + use machine, only: kind_phys, kind_io8 implicit none integer, intent(in) :: me, nthrds, nx, ny, isc, jsc, nsst, & @@ -33,8 +33,8 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & integer, intent(in) :: idate(:), ialb, isot, ivegsrc character(len=*), intent(in) :: input_nml_file(:) logical, intent(in) :: use_ufo, nst_anl, frac_grid - real(kind=kind_phys), intent(in) :: fhcyc, phour, lakefrac(:), & - min_seaice, min_lakeice, & + real(kind=kind_phys), intent(in) :: fhcyc, phour, landfrac(:), lakefrac(:), & + min_seaice, min_lakeice, & xlat_d(:), xlon_d(:) real(kind=kind_phys), intent(inout) :: smc(:,:), & slc(:,:), & @@ -80,8 +80,10 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & ! ! Local variables ! --------------- - real(kind=kind_phys) :: & - SLMASK (nx*ny), & +! real(kind=kind_phys) :: & + real(kind=kind_io8) :: & + slmskl (nx*ny), & + slmskw (nx*ny), & TSFFCS (nx*ny), & ZORFCS (nx*ny), & AISFCS (nx*ny), & @@ -92,9 +94,10 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & SLCFC1 (nx*ny*max(lsoil,lsoil_lsm)) - logical :: lake(nx*ny) + real (kind=kind_io8) :: min_ice(nx*ny) + integer :: i_indx(nx*ny), j_indx(nx*ny) character(len=6) :: tile_num_ch - real(kind=kind_phys) :: sig1t, dt_warm + real(kind=kind_phys) :: sig1t integer :: npts, nb, ix, jx, ls, ios, ll logical :: exists ! @@ -116,17 +119,59 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & if ( nsst > 0 ) then TSFFCS = tref else - TSFFCS = tsfc + TSFFCS = tsfco end if ! + if (frac_grid) then + do ix=1,npts + if (landfrac(ix) > -1.0e-8_kind_phys) then + slmskl(ix) = ceiling(landfrac(ix)-1.0e-8_kind_phys) + slmskw(ix) = floor(landfrac(ix)+1.0e-8_kind_phys) + else + if (nint(slmsk(ix)) == 1) then + slmskl(ix) = 1.0_kind_phys + slmskw(ix) = 1.0_kind_phys + else + slmskl(ix) = 0.0_kind_phys + slmskw(ix) = 0.0_kind_phys + endif + endif + ZORFCS(ix) = zorll(ix) + if (nint(slmskl(ix)) == 0) then + if (slmsk(ix) > 1.99_kind_phys) then + ZORFCS(ix) = zorli(ix) + else + ZORFCS(ix) = zorlo(ix) + endif + endif + enddo + else + do ix=1,npts + if (nint(slmsk(ix)) == 1) then + slmskl(ix) = 1.0_kind_phys + slmskw(ix) = 1.0_kind_phys + else + slmskl(ix) = 0.0_kind_phys + slmskw(ix) = 0.0_kind_phys + endif + ZORFCS(ix) = zorll(ix) + if (slmsk(ix) > 1.99_kind_phys) then + ZORFCS(ix) = zorli(ix) + elseif (slmsk(ix) < 0.1_kind_phys) then + ZORFCS(ix) = zorlo(ix) + endif + enddo + endif do ix=1,npts - ZORFCS(ix) = zorll (ix) - if (slmsk(ix) > 1.9_kind_phys .and. .not. frac_grid) then - ZORFCS(ix) = zorli (ix) - elseif (slmsk(ix) < 0.1_kind_phys .and. .not. frac_grid) then - ZORFCS(ix) = zorlo (ix) + i_indx(ix) = imap(ix) + isc - 1 + j_indx(ix) = jmap(ix) + jsc - 1 + + if (lakefrac(ix) > 0.0_kind_phys) then + min_ice(ix) = min_lakeice + else + min_ice(ix) = min_seaice endif - ! DH* Why not 1.9 as for ZORFCS? + IF (slmsk(ix) > 1.99_kind_phys) THEN AISFCS(ix) = 1.0_kind_phys ELSE @@ -153,19 +198,8 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & SLCFC1(ll) = sh2o(ix,ls) endif enddo - ! - IF (slmsk(ix) < 0.1_kind_phys .OR. slmsk(ix) > 1.5_kind_phys) THEN - SLMASK(ix) = 0.0_kind_phys - ELSE - SLMASK(ix) = 1.0_kind_phys - ENDIF - ! - if (lakefrac(ix) > 0.0_kind_phys) then - lake(ix) = .true. - else - lake(ix) = .false. - endif - end do +! + enddo ! #ifndef INTERNAL_FILE_NML inquire (file=trim(Model%fn_nml),exist=exists) @@ -179,7 +213,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & #endif CALL SFCCYCLE (9998, npts, max(lsoil,lsoil_lsm), sig1t, fhcyc, & idate(4), idate(2), idate(3), idate(1), & - phour, xlat_d, xlon_d, slmask, & + phour, xlat_d, xlon_d, slmskl, slmskw, & oro, oro_uf, use_ufo, nst_anl, & hice, fice, tisfc, snowd, slcfc1, & shdmin, shdmax, slope, snoalb, tsffcs, & @@ -188,9 +222,8 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & vfrac, vtype, stype, alffc1, cv, & cvb, cvt, me, nthrds, & nlunit, size(input_nml_file), input_nml_file, & - lake, min_lakeice, min_seaice, & - ialb, isot, ivegsrc, & - trim(tile_num_ch), imap, jmap) + min_ice, ialb, isot, ivegsrc, & + trim(tile_num_ch), i_indx, j_indx) #ifndef INTERNAL_FILE_NML close (Model%nlunit) #endif @@ -200,14 +233,16 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & else tsfc = TSFFCS tsfco = TSFFCS - end if + endif ! do ix=1,npts zorll(ix) = ZORFCS(ix) - if (slmsk(ix) > 1.9_kind_phys .and. .not. frac_grid) then - zorli(ix) = ZORFCS(ix) - elseif (slmsk(ix) < 0.1_kind_phys .and. .not. frac_grid) then - zorlo(ix) = ZORFCS(ix) + if (nint(slmskl(ix)) == 0) then + if (slmsk(ix) > 1.99_kind_phys) then + zorli(ix) = ZORFCS(ix) + elseif (slmsk(ix) < 0.1_kind_phys) then + zorlo(ix) = ZORFCS(ix) + endif endif ! facsf(ix) = ALFFC1(ix ) @@ -229,7 +264,7 @@ subroutine gcycle (me, nthrds, nx, ny, isc, jsc, nsst, tile_num, nlunit, & tslb(ix,ls) = STCFC1(ll) sh2o(ix,ls) = SLCFC1(ll) endif - if (ls<=kice) tiice(ix,ls) = STCFC1(ll) +! if (ls<=kice) tiice(ix,ls) = STCFC1(ll) enddo enddo ! diff --git a/physics/gfdl_cloud_microphys.F90 b/physics/gfdl_cloud_microphys.F90 index 9574fe59e..fd9a23489 100644 --- a/physics/gfdl_cloud_microphys.F90 +++ b/physics/gfdl_cloud_microphys.F90 @@ -118,7 +118,8 @@ subroutine gfdl_cloud_microphys_run( & gt0, gu0, gv0, vvl, prsl, phii, del, & rain0, ice0, snow0, graupel0, prcp0, sr, & dtp, hydrostatic, phys_hydrostatic, lradar, refl_10cm, & - reset, effr_in, rew, rei, rer, res, reg, errmsg, errflg) + reset, effr_in, rew, rei, rer, res, reg, & + cplchm, pfi_lsan, pfl_lsan, errmsg, errflg) use machine, only: kind_phys @@ -158,6 +159,9 @@ subroutine gfdl_cloud_microphys_run( & real(kind=kind_phys), intent(inout), dimension(:,:) :: refl_10cm logical, intent (in) :: reset, effr_in real(kind=kind_phys), intent(inout), dimension(:,:) :: rew, rei, rer, res, reg + logical, intent (in) :: cplchm + ! ice and liquid water 3d precipitation fluxes - only allocated if cplchm is .true. + real(kind=kind_phys), intent(inout), dimension(:,:) :: pfi_lsan, pfl_lsan character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -168,6 +172,7 @@ subroutine gfdl_cloud_microphys_run( & real(kind=kind_phys), dimension(1:im,1:levs) :: delp, dz, uin, vin, pt, qv1, ql1, qr1, qg1, qa1, qn1, qi1, & qs1, pt_dt, qa_dt, u_dt, v_dt, w, qv_dt, ql_dt, qr_dt, qi_dt, & qs_dt, qg_dt, p123, refl + real(kind=kind_phys), dimension(1:im,1,1:levs) :: pfils, pflls real(kind=kind_phys), dimension(:,:), allocatable :: den real(kind=kind_phys) :: onebg real(kind=kind_phys) :: tem @@ -202,6 +207,8 @@ subroutine gfdl_cloud_microphys_run( & u_dt(i,k) = 0.0 v_dt(i,k) = 0.0 qn1(i,k) = 0.0 + pfils(i,1,k) = 0.0 + pflls(i,1,k) = 0.0 ! flip vertical (k) coordinate qv1(i,k) = gq0(i,kk) ql1(i,k) = gq0_ntcw(i,kk) @@ -232,7 +239,7 @@ subroutine gfdl_cloud_microphys_run( & qv1, ql1, qr1, qi1, qs1, qg1, qa1, qn1, qv_dt, ql_dt, qr_dt, qi_dt, & qs_dt, qg_dt, qa_dt, pt_dt, pt, w, uin, vin, u_dt, v_dt, dz, delp, & garea, dtp, frland, rain0, snow0, ice0, graupel0, hydrostatic, & - phys_hydrostatic, p123, lradar, refl, reset) + phys_hydrostatic, p123, lradar, refl, reset, pfils, pflls) tem = dtp*con_p001/con_day ! fix negative values @@ -291,6 +298,17 @@ subroutine gfdl_cloud_microphys_run( & enddo enddo + ! output ice and liquid water 3d precipitation fluxes if requested + if (cplchm) then + do k=1,levs + kk = levs-k+1 + do i=1,im + pfi_lsan(i,k) = pfils(i,1,kk) + pfl_lsan(i,k) = pflls(i,1,kk) + enddo + enddo + endif + if(effr_in) then allocate(den(1:im,1:levs)) do k=1,levs diff --git a/physics/gfdl_cloud_microphys.meta b/physics/gfdl_cloud_microphys.meta index 961a3e33f..e2a5a5292 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/gfdl_cloud_microphys.meta @@ -486,6 +486,32 @@ kind = kind_phys intent = inout optional = F +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[pfi_lsan] + standard_name = ice_flux_due_to_large_scale_precipitation + long_name = instantaneous 3D flux of ice from nonconvective precipitation + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[pfl_lsan] + standard_name = liquid_flux_due_to_large_scale_precipitation + long_name = instantaneous 3D flux of liquid water from nonconvective precipitation + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/gfs_phy_tracer_config.F b/physics/gfs_phy_tracer_config.F index 8ed7443d3..0e1185a50 100644 --- a/physics/gfs_phy_tracer_config.F +++ b/physics/gfs_phy_tracer_config.F @@ -66,7 +66,7 @@ subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, c implicit none ! input - integer, intent(in) :: me, ntoz,ntcw,ncld,ntke, + integer, intent(in) :: me, ntoz,ntcw,ntke, & ntiw,ntlnc,ntinc,nto,nto2, & fprcp,ntrw,ntsw,ntrnc,ntsnc ! output @@ -83,19 +83,7 @@ subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, ! initialize chem tracers call gocart_tracer_config(me) -! call gocart_tracer_config(gfs_phy_tracer,me) - -! ntrac_met = number of met tracers -!hmhj if ( ntoz < ntcw ) then -!hmhj gfs_phy_tracer%ntrac_met = ntcw + ncld - 1 -!hmhj else -!hmhj gfs_phy_tracer%ntrac_met = ntoz -!hmhj endif -!hmhj if ( gfs_phy_tracer%ntrac_met /= ntrac ) then -!hmhj print *,'LU_TRC: ERROR ! inconsistency in ntrac:', -!hmhj& ntrac, gfs_phy_tracer%ntrac_met -!hmhj stop 222 -!hmhj endif + ! input ntrac is meteorological tracers gfs_phy_tracer%ntrac_met = ntrac @@ -230,7 +218,7 @@ subroutine fixchar(name_in, name_out, option) endif enddo - name_out=trim(name_out) + name_out = trim(name_out) return end subroutine fixchar diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index 7624d7e3e..f9b793239 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -180,10 +180,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & real (kind=kind_phys), dimension(:,:),intent(in) :: & & prsl_i,u_i,v_i,phil, omega_i, QLLS_i,QILS_i, & & lwheat_i,swheat_i - real (kind=kind_phys), dimension(:,:),intent(in):: prsi_i, phii -! GJF* These variables are conditionally allocated depending on whether the -! Morrison-Gettelman microphysics is used, so they must be declared -! using assumed shape. + real (kind=kind_phys), dimension(:,0:),intent(in):: prsi_i, phii real (kind=kind_phys), dimension(:,:), intent(in) :: & & CNV_DQLDT_i, CLCN_i, QLCN_i, QICN_i, & & CNV_MFD_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & @@ -210,9 +207,6 @@ subroutine m_micro_run( im, lm, flipv, dt_i & integer, dimension(:), intent(inout):: KCBL real (kind=kind_phys),dimension(:,:),intent(inout):: q_io, t_io, & & ncpl_io,ncpi_io,CLLS_io -! GJF* These variables are conditionally allocated depending on whether the -! Morrison-Gettelman microphysics is used, so they must be declared -! using assumed shape. real (kind=kind_phys),dimension(:,:),intent(inout):: rnw_io,snw_io,& & ncpr_io, ncps_io, & & qgl_io, ncgl_io @@ -442,7 +436,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & END DO END DO DO K=0, LM - ll = lm-k+1 + ll = lm-k DO I = 1,IM PLE(i,k) = prsi_i(i,ll) * 0.01_kp ! interface pressure in hPa zet(i,k+1) = phii(i,ll) * onebg diff --git a/physics/maximum_hourly_diagnostics.F90 b/physics/maximum_hourly_diagnostics.F90 index 615c49bed..1486ac027 100644 --- a/physics/maximum_hourly_diagnostics.F90 +++ b/physics/maximum_hourly_diagnostics.F90 @@ -30,7 +30,8 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, imp_physics_fer_hires,con_g, phil, & gt0, refl_10cm, refdmax, refdmax263k, u10m, v10m, & u10max, v10max, spd10max, pgr, t2m, q2m, t02max, & - t02min, rh02max, rh02min, errmsg, errflg) + t02min, rh02max, rh02min, dtp, rain, pratemax, & + errmsg, errflg) ! Interface variables integer, intent(in) :: im, levs @@ -54,6 +55,9 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, real(kind_phys), intent(inout) :: t02min(:) 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) character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -96,6 +100,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, t02min(i) = 999. rh02max(i) = -999. rh02min(i) = 999. + pratemax(i) = 0. enddo endif do i=1,im @@ -119,6 +124,7 @@ subroutine maximum_hourly_diagnostics_run(im, levs, reset, lradar, imp_physics, rh02min(i) = min(rh02min(i),rh02) t02max(i) = max(t02max(i),t2m(i)) !<--- hourly max 2m t t02min(i) = min(t02min(i),t2m(i)) !<--- hourly min 2m t + pratemax(i) = max(pratemax(i),(3.6E6/dtp)*rain(i)) enddo end subroutine maximum_hourly_diagnostics_run diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 67b3df039..0f87c86af 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -233,6 +233,33 @@ kind = kind_phys intent = inout optional = F +[dtp] + standard_name = time_step_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[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 = inout + optional = F +[pratemax] + standard_name = maximum_precipitation_rate_over_maximum_hourly_time_interval + long_name = maximum precipitation rate over maximum hourly time interval + units = mm h-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/mfpbltq.f b/physics/mfpbltq.f index a6fc22cef..b906052cd 100644 --- a/physics/mfpbltq.f +++ b/physics/mfpbltq.f @@ -40,12 +40,13 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, c local variables and arrays ! integer i, j, k, n, ndc + integer kpblx(im), kpbly(im) ! real(kind=kind_phys) dt2, dz, ce0, cm, & factor, gocp, & g, b1, f1, & bb1, bb2, - & a1, pgcon, + & alp, vpertmax,a1, pgcon, & qmin, qlmin, xmmx, rbint, & tem, tem1, tem2, & ptem, ptem1, ptem2 @@ -54,7 +55,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & tlu, gamma, qlu, & thup, thvu, dq ! - real(kind=kind_phys) rbdn(im), rbup(im), xlamuem(im,km-1) + real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im), + & xlamuem(im,km-1) real(kind=kind_phys) delz(im), xlamax(im) ! real(kind=kind_phys) wu2(im,km), thlu(im,km), @@ -71,7 +73,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) parameter(ce0=0.4,cm=1.0) parameter(qmin=1.e-8,qlmin=1.e-12) - parameter(pgcon=0.55) + parameter(alp=1.5,vpertmax=3.0,pgcon=0.55) parameter(b1=0.5,f1=0.15) ! !************************************************************************ @@ -99,9 +101,11 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! do i=1,im if(cnvflg(i)) then - thlu(i,1)= thlx(i,1) + vpert(i) + ptem = alp * vpert(i) + ptem = min(ptem, vpertmax) + thlu(i,1)= thlx(i,1) + ptem qtu(i,1) = qtx(i,1) - buo(i,1) = g * vpert(i) / thvx(i,1) + buo(i,1) = g * ptem / thvx(i,1) endif enddo ! @@ -213,6 +217,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! do i=1,im flg(i) = .true. + kpblx(i) = 1 + kpbly(i) = kpbl(i) if(cnvflg(i)) then flg(i) = .false. rbup(i) = wu2(i,1) @@ -223,14 +229,14 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, if(.not.flg(i)) then rbdn(i) = rbup(i) rbup(i) = wu2(i,k) - kpbl(i)= k + kpblx(i)= k flg(i) = rbup(i).le.0. endif enddo enddo do i = 1,im if(cnvflg(i)) then - k = kpbl(i) + k = kpblx(i) if(rbdn(i) <= 0.) then rbint = 0. elseif(rbup(i) >= 0.) then @@ -238,7 +244,17 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, else rbint = rbdn(i)/(rbdn(i)-rbup(i)) endif - hpbl(i) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1)) + hpblx(i) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1)) + endif + enddo +! + do i = 1,im + if(cnvflg(i)) then + if(kpblx(i) < kpbl(i)) then + kpbl(i) = kpblx(i) + hpbl(i) = hpblx(i) + endif + if(kpbl(i) <= 1) cnvflg(i)=.false. endif enddo ! @@ -255,7 +271,8 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! do k = 1, kmpbl do i=1,im - if(cnvflg(i)) then + if(cnvflg(i) .and. kpblx(i) < kpbly(i)) then +! if(cnvflg(i)) then if(k < kpbl(i)) then ptem = 1./(zm(i,k)+delz(i)) tem = max((hpbl(i)-zm(i,k)+delz(i)) ,delz(i)) diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/module_MYJPBL_wrapper.meta index e9509d66c..e4e76434e 100644 --- a/physics/module_MYJPBL_wrapper.meta +++ b/physics/module_MYJPBL_wrapper.meta @@ -474,7 +474,7 @@ intent = inout optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) @@ -483,8 +483,8 @@ intent = in optional = F [hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 1b77d101e..4e3384e12 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -343,8 +343,8 @@ intent = out optional = F [hflx] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux reduced by surface roughness + 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 @@ -352,8 +352,8 @@ intent = in optional = F [qflx] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward latent heat flux reduced by surface roughness + standard_name = kinematic_surface_upward_latent_heat_flux + long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) type = real diff --git a/physics/module_MYNNSFC_wrapper.F90 b/physics/module_MYNNSFC_wrapper.F90 index a27b02e0d..271ca5a24 100644 --- a/physics/module_MYNNSFC_wrapper.F90 +++ b/physics/module_MYNNSFC_wrapper.F90 @@ -69,7 +69,7 @@ SUBROUTINE mynnsfc_wrapper_run( & & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) & qsfc_wat, qsfc_lnd, qsfc_ice, & !intent(in) - & snowh_wat, snowh_lnd, snowh_ice, & !intent(in) + & snowh_lnd, snowh_ice, & !intent(in) & znt_wat, znt_lnd, znt_ice, & !intent(inout) & ust_wat, ust_lnd, ust_ice, & !intent(inout) & cm_wat, cm_lnd, cm_ice, & !intent(inout) @@ -163,7 +163,7 @@ SUBROUTINE mynnsfc_wrapper_run( & real(kind=kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snowh_wat, snowh_lnd, snowh_ice + & snowh_lnd, snowh_ice real(kind=kind_phys), dimension(:), intent(inout) :: & & znt_wat, znt_lnd, znt_ice, & @@ -194,7 +194,7 @@ SUBROUTINE mynnsfc_wrapper_run( & real, dimension(im) :: & & hfx, znt, psim, psih, & & chs, ck, cd, mavail, xland, GZ1OZ0, & - & cpm, qgh, qfx, qsfc_ruc + & cpm, qgh, qfx, qsfc_ruc, snowh_wat real(kind=kind_phys), dimension(im,levs) :: & & pattern_spp_pbl, dz, th, qv @@ -233,13 +233,14 @@ SUBROUTINE mynnsfc_wrapper_run( & else xland(i)=2.0 endif - qgh(i)=0.0 - mavail(i)=1.0 - !snowh(i)=snowd(i)*800. !mm -> m - !znt_lnd(i)=znt_lnd(i)*0.01 !cm -> m - !znt_wat(i)=znt_wat(i)*0.01 !cm -> m - !znt_ice(i)=znt_ice(i)*0.01 !cm -> m - cpm(i)=cp + qgh(i) = 0.0 + mavail(i) = 1.0 + !snowh(i) = snowd(i)*800. !mm -> m + !znt_lnd(i) = znt_lnd(i)*0.01 !cm -> m + !znt_wat(i) = znt_wat(i)*0.01 !cm -> m + !znt_ice(i) = znt_ice(i)*0.01 !cm -> m + cpm(i) = cp + snowh_wat(i) = 0.0 enddo ! cm -> m diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index d082752c4..94393057b 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -391,15 +391,6 @@ kind = kind_phys intent = inout optional = F -[snowh_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [snowh_lnd] standard_name = surface_snow_thickness_water_equivalent_over_land long_name = water equivalent snow depth over land diff --git a/physics/module_gfdl_cloud_microphys.F90 b/physics/module_gfdl_cloud_microphys.F90 index 1fa33fc18..7f00d9bca 100644 --- a/physics/module_gfdl_cloud_microphys.F90 +++ b/physics/module_gfdl_cloud_microphys.F90 @@ -361,7 +361,7 @@ subroutine gfdl_cloud_microphys_mod_driver ( qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & uin, vin, udt, vdt, dz, delp, area, dt_in, land, & rain, snow, ice, graupel, hydrostatic, phys_hydrostatic, & - p, lradar, refl_10cm,reset) + p, lradar, refl_10cm, reset, pfils, pflls) implicit none @@ -392,6 +392,7 @@ subroutine gfdl_cloud_microphys_mod_driver ( logical, intent (in) :: lradar real, intent (out), dimension (iis:iie, jjs:jje, kks:kke) :: refl_10cm logical, intent (in) :: reset + real, intent (out), dimension (iis:iie, jjs:jje, kks:kke) :: pfils, pflls ! Local variables logical :: melti = .false. @@ -483,6 +484,9 @@ subroutine gfdl_cloud_microphys_mod_driver ( enddo enddo + pfils = 0. + pflls = 0. + ! ----------------------------------------------------------------------- ! major cloud microphysics ! ----------------------------------------------------------------------- @@ -494,6 +498,12 @@ subroutine gfdl_cloud_microphys_mod_driver ( m2_sol, cond (:, j), area (:, j), land (:, j), udt, vdt, pt_dt, & qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, w_var, vt_r, & vt_s, vt_g, vt_i, qn2) + do k = ktop, kbot + do i = is, ie + pfils(i, j, k) = m2_sol (i, k) + pflls(i, j, k) = m2_rain(i, k) + enddo + enddo enddo ! ----------------------------------------------------------------------- diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index dfe31f375..b1301d744 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -63,7 +63,7 @@ MODULE module_mp_thompson USE module_mp_radar -#if !defined(SION) && defined(MPI) +#ifdef MPI use mpi #endif @@ -421,8 +421,7 @@ MODULE module_mp_thompson !..MPI communicator INTEGER:: mpi_communicator -!..If SIONlib isn't used, write Thompson tables with master MPI task -!.. after computing them in thompson_init +!..Write tables with master MPI task after computing them in thompson_init LOGICAL:: thompson_table_writer !+---+ @@ -453,12 +452,7 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & INTEGER:: i, j, k, l, m, n LOGICAL:: micro_init real :: stime, etime -#ifdef SION - INTEGER :: ierr - LOGICAL :: precomputed_tables -#else LOGICAL, PARAMETER :: precomputed_tables = .FALSE. -#endif ! Set module variable is_aerosol_aware is_aerosol_aware = is_aerosol_aware_in @@ -766,18 +760,7 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & ! Assign mpicomm to module variable mpi_communicator = mpicomm -#ifdef SION - call cpu_time(stime) - call readwrite_tables(thomp_table_file, "read", mpicomm, mpirank, mpiroot, ierr) - call cpu_time(etime) - if (ierr==0) then - precomputed_tables = .true. - if (mpirank==mpiroot) print '("Reading and broadcasting precomputed Thompson tables took ",f10.3," seconds.")', etime-stime - else - precomputed_tables = .false. - if (mpirank==mpiroot) write(0,*) "An error occurred reading Thompson tables from disk, recalculate" - end if -#endif + ! Standard tables are only written by master MPI task; ! (physics init cannot be called by multiple threads, ! hence no need to test for a specific thread number) @@ -899,9 +882,6 @@ 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 - ! This computation is cheap compared to the others below, and - ! doing it always ensures that the correct data is in the SIONlib - ! file containing the precomputed tables *DH if (mpirank==mpiroot) write(0,*) ' calling table_ccnAct routine' call table_ccnAct(errmsg,errflg) if (.not. errflg==0) return @@ -971,17 +951,6 @@ SUBROUTINE thompson_init(is_aerosol_aware_in, & call cpu_time(etime) if (mpirank==mpiroot) print '("Calculating Thompson tables part 2 took ",f10.3," seconds.")', etime-stime -#ifdef SION - call cpu_time(stime) - call readwrite_tables(thomp_table_file, "write", mpicomm, mpirank, mpiroot, ierr) - if (ierr/=0) then - write(0,*) "An error occurred writing Thompson tables to disk" - stop 1 - end if - call cpu_time(etime) - if (mpirank==mpiroot) print '("Writing Thompson tables took ",f10.3," seconds.")', etime-stime -#endif - end if precomputed_tables_2 endif if_not_iiwarm @@ -1018,7 +987,25 @@ 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 - errmsg, errflg, reset) + reset_dBZ, istep, nsteps, & + errmsg, errflg, & + ! Extended diagnostics, array pointers + ! only associated if ext_diag flag is .true. + ext_diag, & + !vts1, txri, txrc, & + prw_vcdc, & + prw_vcde, tpri_inu, tpri_ide_d, & + tpri_ide_s, tprs_ide, tprs_sde_d, & + tprs_sde_s, tprg_gde_d, & + tprg_gde_s, tpri_iha, tpri_wfz, & + tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & + tprg_rcs, tprs_rcs, & + tprr_rci, tprg_rcg, & + tprw_vcd_c, tprw_vcd_e, tprr_sml, & + tprr_gml, tprr_rcg, & + tprr_rcs, tprv_rev, tten3, qvten3, & + qrten3, qsten3, qgten3, qiten3, niten3, & + nrten3, ncten3, qcten3) implicit none @@ -1058,15 +1045,51 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & refl_10cm REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & vt_dbz_wt - LOGICAL, OPTIONAL, INTENT(IN) :: first_time_step + LOGICAL, INTENT(IN) :: first_time_step REAL, INTENT(IN):: dt_in - LOGICAL, INTENT (IN) :: reset + ! To support subcycling: current step and maximum number of steps + INTEGER, INTENT (IN) :: istep, nsteps + LOGICAL, INTENT (IN) :: reset_dBZ + ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. + LOGICAL, INTENT (IN) :: ext_diag + REAL, DIMENSION(:,:,:), INTENT(INOUT):: & + !vts1, txri, txrc, & + prw_vcdc, & + prw_vcde, tpri_inu, tpri_ide_d, & + tpri_ide_s, tprs_ide, & + tprs_sde_d, tprs_sde_s, tprg_gde_d, & + tprg_gde_s, tpri_iha, tpri_wfz, & + tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & + tprg_rcs, tprs_rcs, & + tprr_rci, tprg_rcg, & + tprw_vcd_c, tprw_vcd_e, tprr_sml, & + tprr_gml, tprr_rcg, & + tprr_rcs, tprv_rev, tten3, qvten3, & + qrten3, qsten3, qgten3, qiten3, niten3, & + nrten3, ncten3, qcten3 !..Local variables REAL, DIMENSION(kts:kte):: & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ +!..Extended diagnostics, single column arrays + REAL, DIMENSION(:), ALLOCATABLE:: & + !vtsk1, txri1, txrc1, & + prw_vcdc1, & + prw_vcde1, tpri_inu1, tpri_ide1_d, & + tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & + tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& + tprg_rcs1, tprs_rcs1, & + tprr_rci1, tprg_rcg1, & + tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & + tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, tten1, qvten1, & + qrten1, qsten1, qgten1, qiten1, niten1, & + nrten1, ncten1, qcten1 + REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte):: & @@ -1093,63 +1116,110 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & if (present(errmsg)) errmsg = '' if (present(errflg)) errflg = 0 - ! DH* 2020-06-05: The stochastic perturbations code was retrofitted - ! from a newer version of the Thompson MP scheme, but it has not been - ! tested yet. - if (rand_perturb_on .ne. 0) then - errmsg = 'Logic error in mp_gt_driver: the stochastic perturbations code ' // & - 'has not been tested yet with this version of the Thompson scheme' - errflg = 1 - return - end if - ! Activate this code when removing the guard above - !if (rand_perturb_on .ne. 0 .and. .not. present(rand_pert)) then - ! errmsg = 'Logic error in mp_gt_driver: random perturbations are on, ' // & - ! 'but optional argument rand_pert is not present' - ! errflg = 1 - ! return - !end if - ! *DH 2020-06-05 - - if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & - (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then - if (present(errmsg)) then - write(errmsg, '(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' - else - write(*,'(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' - end if - if (present(errflg)) then - errflg = 1 - return - else - stop + ! No need to test for every subcycling step + test_only_once: if (first_time_step .and. istep==1) then + ! DH* 2020-06-05: The stochastic perturbations code was retrofitted + ! from a newer version of the Thompson MP scheme, but it has not been + ! tested yet. + if (rand_perturb_on .ne. 0) then + errmsg = 'Logic error in mp_gt_driver: the stochastic perturbations code ' // & + 'has not been tested yet with this version of the Thompson scheme' + errflg = 1 + return end if - end if - - if (is_aerosol_aware .and. (.not.present(nc) .or. & - .not.present(nwfa) .or. & - .not.present(nifa) .or. & - .not.present(nwfa2d) .or. & - .not.present(nifa2d) )) then - if (present(errmsg)) then - write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & - ' and nifa2d for aerosol-aware version of Thompson microphysics' - else - write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & - ' and nifa2d for aerosol-aware version of Thompson microphysics' + ! Activate this code when removing the guard above + !if (rand_perturb_on .ne. 0 .and. .not. present(rand_pert)) then + ! errmsg = 'Logic error in mp_gt_driver: random perturbations are on, ' // & + ! 'but optional argument rand_pert is not present' + ! errflg = 1 + ! return + !end if + ! *DH 2020-06-05 + + if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & + (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then + if (present(errmsg)) then + write(errmsg, '(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' + else + write(*,'(a)') 'Logic error in mp_gt_driver: provide either tt or th+pii' + end if + if (present(errflg)) then + errflg = 1 + return + else + stop + end if end if - if (present(errflg)) then - errflg = 1 - return - else - stop + + if (is_aerosol_aware .and. (.not.present(nc) .or. & + .not.present(nwfa) .or. & + .not.present(nifa) .or. & + .not.present(nwfa2d) .or. & + .not.present(nifa2d) )) then + if (present(errmsg)) then + write(errmsg, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & + ' and nifa2d for aerosol-aware version of Thompson microphysics' + else + write(*, '(*(a))') 'Logic error in mp_gt_driver: provide nc, nwfa, nifa, nwfa2d', & + ' and nifa2d for aerosol-aware version of Thompson microphysics' + end if + if (present(errflg)) then + errflg = 1 + return + else + stop + end if + else if (.not.is_aerosol_aware .and. (present(nwfa) .or. & + present(nifa) .or. & + present(nwfa2d) .or. & + present(nifa2d) )) then + write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware is FALSE' end if - else if (.not.is_aerosol_aware .and. (present(nwfa) .or. & - present(nifa) .or. & - present(nwfa2d) .or. & - present(nifa2d) )) then - write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware is FALSE' - end if + end if test_only_once + + ! These must be alwyas allocated + !allocate (vtsk1(kts:kte)) + !allocate (txri1(kts:kte)) + !allocate (txrc1(kts:kte)) + allocate_extended_diagnostics: if (ext_diag) then + allocate (prw_vcdc1(kts:kte)) + allocate (prw_vcde1(kts:kte)) + allocate (tpri_inu1(kts:kte)) + allocate (tpri_ide1_d(kts:kte)) + allocate (tpri_ide1_s(kts:kte)) + allocate (tprs_ide1(kts:kte)) + allocate (tprs_sde1_d(kts:kte)) + allocate (tprs_sde1_s(kts:kte)) + allocate (tprg_gde1_d(kts:kte)) + allocate (tprg_gde1_s(kts:kte)) + allocate (tpri_iha1(kts:kte)) + allocate (tpri_wfz1(kts:kte)) + allocate (tpri_rfz1(kts:kte)) + allocate (tprg_rfz1(kts:kte)) + allocate (tprs_scw1(kts:kte)) + allocate (tprg_scw1(kts:kte)) + allocate (tprg_rcs1(kts:kte)) + allocate (tprs_rcs1(kts:kte)) + allocate (tprr_rci1(kts:kte)) + allocate (tprg_rcg1(kts:kte)) + allocate (tprw_vcd1_c(kts:kte)) + allocate (tprw_vcd1_e(kts:kte)) + allocate (tprr_sml1(kts:kte)) + allocate (tprr_gml1(kts:kte)) + allocate (tprr_rcg1(kts:kte)) + allocate (tprr_rcs1(kts:kte)) + allocate (tprv_rev1(kts:kte)) + allocate (tten1(kts:kte)) + allocate (qvten1(kts:kte)) + allocate (qrten1(kts:kte)) + allocate (qsten1(kts:kte)) + allocate (qgten1(kts:kte)) + allocate (qiten1(kts:kte)) + allocate (niten1(kts:kte)) + allocate (nrten1(kts:kte)) + allocate (ncten1(kts:kte)) + allocate (qcten1(kts:kte)) + end if allocate_extended_diagnostics !+---+ i_start = its @@ -1260,6 +1330,50 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ni1d(k) = ni(i,k,j) nr1d(k) = nr(i,k,j) rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + + ! These arrays are always allocated and must be initialized + !vtsk1(k) = 0. + !txrc1(k) = 0. + !txri1(k) = 0. + initialize_extended_diagnostics: if (ext_diag) then + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. + tpri_inu1(k) = 0. + tpri_ide1_d(k) = 0. + tpri_ide1_s(k) = 0. + tprs_ide1(k) = 0. + tprs_sde1_d(k) = 0. + tprs_sde1_s(k) = 0. + tprg_gde1_d(k) = 0. + tprg_gde1_s(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprs_scw1(k) = 0. + tprg_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1(k) = 0. + tprw_vcd1_c(k) = 0. + tprw_vcd1_e(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1(k) = 0. + tprr_rcs1(k) = 0. + tprv_rev1(k) = 0. + tten1(k) = 0. + qvten1(k) = 0. + qrten1(k) = 0. + qsten1(k) = 0. + qgten1(k) = 0. + qiten1(k) = 0. + niten1(k) = 0. + nrten1(k) = 0. + ncten1(k) = 0. + qcten1(k) = 0. + endif initialize_extended_diagnostics enddo if (is_aerosol_aware) then do k = kts, kte @@ -1283,7 +1397,20 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & rainprod1d, evapprod1d, & #endif rand1, rand2, rand3, & - kts, kte, dt, i, j) + kts, kte, dt, i, j, & + ext_diag, & + !vtsk1, txri1, txrc1, & + prw_vcdc1, prw_vcde1, & + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, & + tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & + tprg_rcs1, tprs_rcs1, tprr_rci1, & + tprg_rcg1, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, & + tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, qcten1) pcp_ra(i,j) = pptrain pcp_sn(i,j) = pptsnow @@ -1421,49 +1548,100 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & endif enddo + assign_extended_diagnostics: if (ext_diag) then + do k=kts,kte + !vts1(i,k,j) = vtsk1(k) + !txri(i,k,j) = txri(i,k,j) + txri1(k) + !txrc(i,k,j) = txrc(i,k,j) + txrc1(k) + prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) + prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) + tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) + tpri_ide_d(i,k,j) = tpri_ide_d(i,k,j) + tpri_ide1_d(k) + tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) + tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k) + tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) + tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) + tprg_gde_d(i,k,j) = tprg_gde_d(i,k,j) + tprg_gde1_d(k) + tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) + tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) + tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) + tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) + tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) + tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) + tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) + tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) + tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k) + tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) + tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k) + tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) + tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) + tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) + tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) + tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) + tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) + tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) + tten3(i,k,j) = tten3(i,k,j) + tten1(k) + qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) + qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) + qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k) + qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k) + qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k) + niten3(i,k,j) = niten3(i,k,j) + niten1(k) + nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k) + ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k) + qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k) + + enddo + endif assign_extended_diagnostics + + ! Diagnostic calculations only for last step + ! if Thompson MP is called multiple times + last_step_only: IF (istep == nsteps) THEN + !> - Call calc_refl10cm() - IF ( PRESENT (diagflag) ) THEN - if (diagflag .and. do_radar_ref == 1) then + diagflag_present: IF ( PRESENT (diagflag) ) THEN + if (diagflag .and. do_radar_ref == 1) then ! - ! Only set melti to true at the output times - if (reset) then + ! Only set melti to true at the output times + if (reset_dBZ) then melti=.true. - else + else melti=.false. - endif + endif ! - if (present(vt_dbz_wt) .and. present(first_time_step)) then - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, i, j, & - melti, vt_dbz_wt(i,:,j), & - first_time_step) - else - call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & - t1d, p1d, dBZ, rand1, kts, kte, i, j, & - melti) - end if - do k = kts, kte - refl_10cm(i,k,j) = MAX(-35., dBZ(k)) - enddo - endif - ENDIF + if (present(vt_dbz_wt)) then + call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + t1d, p1d, dBZ, rand1, kts, kte, i, j, & + melti, vt_dbz_wt(i,:,j), & + first_time_step) + else + call calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & + t1d, p1d, dBZ, rand1, kts, kte, i, j, & + melti) + end if + do k = kts, kte + refl_10cm(i,k,j) = MAX(-35., dBZ(k)) + enddo + endif + ENDIF diagflag_present - IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN - do k = kts, kte - re_qc1d(k) = re_qc_min - re_qi1d(k) = re_qi_min - re_qs1d(k) = re_qs_min - enddo + IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN + do k = kts, kte + re_qc1d(k) = re_qc_min + re_qi1d(k) = re_qi_min + re_qs1d(k) = re_qs_min + enddo !> - Call calc_effectrad() - call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & - re_qc1d, re_qi1d, re_qs1d, kts, kte) - do k = kts, kte - re_cloud(i,k,j) = MAX(re_qc_min, MIN(re_qc1d(k), re_qc_max)) - re_ice(i,k,j) = MAX(re_qi_min, MIN(re_qi1d(k), re_qi_max)) - re_snow(i,k,j) = MAX(re_qs_min, MIN(re_qs1d(k), re_qs_max)) - enddo - ENDIF + call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & + re_qc1d, re_qi1d, re_qs1d, kts, kte) + do k = kts, kte + re_cloud(i,k,j) = MAX(re_qc_min, MIN(re_qc1d(k), re_qc_max)) + re_ice(i,k,j) = MAX(re_qi_min, MIN(re_qi1d(k), re_qi_max)) + re_snow(i,k,j) = MAX(re_qs_min, MIN(re_qs1d(k), re_qs_max)) + enddo + ENDIF + ENDIF last_step_only enddo i_loop enddo j_loop @@ -1479,6 +1657,50 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ! 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' ! END DEBUG - GT + ! These are always allocated + !deallocate (vtsk1) + !deallocate (txri1) + !deallocate (txrc1) + deallocate_extended_diagnostics: if (ext_diag) then + deallocate (prw_vcdc1) + deallocate (prw_vcde1) + deallocate (tpri_inu1) + deallocate (tpri_ide1_d) + deallocate (tpri_ide1_s) + deallocate (tprs_ide1) + deallocate (tprs_sde1_d) + deallocate (tprs_sde1_s) + deallocate (tprg_gde1_d) + deallocate (tprg_gde1_s) + deallocate (tpri_iha1) + deallocate (tpri_wfz1) + deallocate (tpri_rfz1) + deallocate (tprg_rfz1) + deallocate (tprs_scw1) + deallocate (tprg_scw1) + deallocate (tprg_rcs1) + deallocate (tprs_rcs1) + deallocate (tprr_rci1) + deallocate (tprg_rcg1) + deallocate (tprw_vcd1_c) + deallocate (tprw_vcd1_e) + deallocate (tprr_sml1) + deallocate (tprr_gml1) + deallocate (tprr_rcg1) + deallocate (tprr_rcs1) + deallocate (tprv_rev1) + deallocate (tten1) + deallocate (qvten1) + deallocate (qrten1) + deallocate (qsten1) + deallocate (qgten1) + deallocate (qiten1) + deallocate (niten1) + deallocate (nrten1) + deallocate (ncten1) + deallocate (qcten1) + end if deallocate_extended_diagnostics + END SUBROUTINE mp_gt_driver !> @} @@ -1543,14 +1765,30 @@ END SUBROUTINE thompson_finalize !! Thompson et al. (2004, 2008)\cite Thompson_2004 \cite Thompson_2008. !>\section gen_mp_thompson mp_thompson General Algorithm !> @{ - subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & - nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & - pptrain, pptsnow, pptgraul, pptice, & + subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & + pptrain, pptsnow, pptgraul, pptice, & #if ( WRF_CHEM == 1 ) - rainprod, evapprod, & + rainprod, evapprod, & #endif - rand1, rand2, rand3, & - kts, kte, dt, ii, jj) + rand1, rand2, rand3, & + kts, kte, dt, ii, jj, & + ! Extended diagnostics, most arrays only + ! allocated if ext_diag flag is .true. + ext_diag, & + !vtsk1, txri1, txrc1, & + prw_vcdc1, prw_vcde1, & + tpri_inu1, tpri_ide1_d, tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, & + tprg_gde1_d, tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1, & + tprg_rcs1, tprs_rcs1, tprr_rci1, & + tprg_rcg1, tprw_vcd1_c, & + tprw_vcd1_e, tprr_sml1, tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, & + tten1, qvten1, qrten1, qsten1, & + qgten1, qiten1, niten1, nrten1, ncten1, qcten1) + #ifdef MPI use mpi #endif @@ -1565,6 +1803,23 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt REAL, INTENT(IN):: rand1, rand2, rand3 + ! Extended diagnostics, most arrays only allocated if ext_diag is true + LOGICAL, INTENT(IN) :: ext_diag + REAL, DIMENSION(:), INTENT(OUT):: & + !vtsk1, txri1, txrc1, & + prw_vcdc1, & + prw_vcde1, tpri_inu1, tpri_ide1_d, & + tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & + tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& + tprg_rcs1, tprs_rcs1, & + tprr_rci1, tprg_rcg1, & + tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & + tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, tten1, qvten1, & + qrten1, qsten1, qgten1, qiten1, niten1, & + nrten1, ncten1, qcten1 #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & @@ -1774,6 +2029,52 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo #endif +!Diagnostics + if (ext_diag) then + do k = kts, kte + !vtsk1(k) = 0. + !txrc1(k) = 0. + !txri1(k) = 0. + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. + tpri_inu1(k) = 0. + tpri_ide1_d(k) = 0. + tpri_ide1_s(k) = 0. + tprs_ide1(k) = 0. + tprs_sde1_d(k) = 0. + tprs_sde1_s(k) = 0. + tprg_gde1_d(k) = 0. + tprg_gde1_s(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprg_scw1(k) = 0. + tprs_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1(k) = 0. + tprw_vcd1_c(k) = 0. + tprw_vcd1_e(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1(k) = 0. + tprr_rcs1(k) = 0. + tprv_rev1(k) = 0. + tten1(k) = 0. + qvten1(k) = 0. + qrten1(k) = 0. + qsten1(k) = 0. + qgten1(k) = 0. + qiten1(k) = 0. + niten1(k) = 0. + nrten1(k) = 0. + ncten1(k) = 0. + qcten1(k) = 0. + enddo + endif + !..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments. do k = kts, kte smo0(k) = 0. @@ -3469,6 +3770,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nstep = 0 do k = kte, kts, -1 vts = 0. + !vtsk1(k)=0. if (rs(k).gt. R1) then xDs = smoc(k) / smob(k) @@ -3487,11 +3789,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ! & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) SR = rs(k)/(rs(k)+rr(k)) vtsk(k) = vts*SR + (1.-SR)*vtrk(k) + !vtsk1(k)=vtsk(k) else vtsk(k) = vts*vts_boost(k) + !vtsk1(k)=vtsk(k) endif else vtsk(k) = vtsk(k+1) + !vtsk1(k)=0 endif if (vtsk(k) .gt. 1.E-3) then @@ -3689,6 +3994,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qiten(k) = qiten(k) - xri*odt niten(k) = -ni1d(k)*odt tten(k) = tten(k) - lfus*ocp(k)*xri*odt*(1-IFDRY) +!diag + !txri1(k) = lfus*ocp(k)*xri*odt*(1-IFDRY) endif xrc = MAX(0.0, qc1d(k) + qcten(k)*DT) @@ -3700,6 +4007,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qcten(k) = qcten(k) - xrc*odt ncten(k) = ncten(k) - xnc*odt tten(k) = tten(k) + lfus2*ocp(k)*xrc*odt*(1-IFDRY) +!diag + !txrc1(k) = lfus2*ocp(k)*xrc*odt*(1-IFDRY)*DT endif enddo endif @@ -3778,6 +4087,89 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (qg1d(k) .le. R1) qg1d(k) = 0.0 enddo +! Diagnostics + calculate_extended_diagnostics: if (ext_diag) then + do k = kts, kte + if(prw_vcd(k).gt.0)then + prw_vcdc1(k) = prw_vcd(k)*dt + elseif(prw_vcd(k).lt.0)then + prw_vcde1(k) = -1*prw_vcd(k)*dt + endif +!heating/cooling diagnostics + tpri_inu1(k) = pri_inu(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + + if(pri_ide(k).gt.0)then + tpri_ide1_d(k) = pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tpri_ide1_s(k) = -pri_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(temp(k).lt.T_0)then + tprs_ide1(k) = prs_ide(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(prs_sde(k).gt.0)then + tprs_sde1_d(k) = prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tprs_sde1_s(k) = -prs_sde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(prg_gde(k).gt.0)then + tprg_gde1_d(k) = prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + else + tprg_gde1_s(k) = -prg_gde(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + endif + + tpri_iha1(k) = pri_iha(k)*lsub*ocp(k)*orho * (1-IFDRY)*DT + tpri_wfz1(k) = pri_wfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tpri_rfz1(k) = pri_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_rfz1(k) = prg_rfz(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprs_scw1(k) = prs_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_scw1(k) = prg_scw(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + tprg_rcs1(k) = prg_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + + if(temp(k).lt.T_0)then + tprs_rcs1(k) = prs_rcs(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + endif + + tprr_rci1(k) = prr_rci(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + + if(temp(k).lt.T_0)then + tprg_rcg1(k) = prg_rcg(k)*lfus2*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(prw_vcd(k).gt.0)then + tprw_vcd1_c(k) = lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT + else + tprw_vcd1_e(k) = -lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY)*DT + endif + +! cooling terms + tprr_sml1(k) = prr_sml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + tprr_gml1(k) = prr_gml(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + + if(temp(k).ge.T_0)then + tprr_rcg1(k) = -prr_rcg(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + endif + + if(temp(k).ge.T_0)then + tprr_rcs1(k) = -prr_rcs(k)*lfus*ocp(k)*orho * (1-IFDRY)*DT + endif + + tprv_rev1(k) = lvap(k)*ocp(k)*prv_rev(k)*(1-IFDRY)*DT + tten1(k) = tten(k)*DT + qvten1(k) = qvten(k)*DT + qiten1(k) = qiten(k)*DT + qrten1(k) = qrten(k)*DT + qsten1(k) = qsten(k)*DT + qgten1(k) = qgten(k)*DT + niten1(k) = niten(k)*DT + nrten1(k) = nrten(k)*DT + ncten1(k) = ncten(k)*DT + qcten1(k) = qcten(k)*DT + enddo + endif calculate_extended_diagnostics + end subroutine mp_thompson !>@} @@ -3853,10 +4245,10 @@ subroutine qr_acr_qg ENDIF IF (.NOT. good .EQ. 1 ) THEN -#ifndef SION - if (thompson_table_writer) write_thompson_tables = .true. -#endif - if (thompson_table_writer) write(0,*) "ThompMP: computing qr_acr_qg" + if (thompson_table_writer) then + write_thompson_tables = .true. + write(0,*) "ThompMP: computing qr_acr_qg" + endif do n2 = 1, nbr ! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & @@ -4035,10 +4427,10 @@ subroutine qr_acr_qs ENDIF IF (.NOT. good .EQ. 1 ) THEN -#ifndef SION - if (thompson_table_writer) write_thompson_tables = .true. -#endif - if (thompson_table_writer) write(0,*) "ThompMP: computing qr_acr_qs" + if (thompson_table_writer) then + write_thompson_tables = .true. + write(0,*) "ThompMP: computing qr_acr_qs" + endif do n2 = 1, nbr ! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & @@ -4290,10 +4682,10 @@ subroutine freezeH2O(threads) ENDIF IF (.NOT. good .EQ. 1 ) THEN -#ifndef SION - if (thompson_table_writer) write_thompson_tables = .true. -#endif - if (thompson_table_writer) write(0,*) "ThompMP: computing freezeH2O" + if (thompson_table_writer) then + write_thompson_tables = .true. + write(0,*) "ThompMP: computing freezeH2O" + endif orho_w = 1./rho_w @@ -5613,300 +6005,6 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & end subroutine calc_refl10cm ! - -#ifdef SION -!>\ingroup aathompson - subroutine readwrite_tables(filename, mode, mpicomm, mpirank, mpiroot, ierr) - -#ifdef MPI - use mpi -#endif - use sion_f90 - - implicit none - - ! Interface variables - character(len=*), intent(in) :: filename - character(len=*), intent(in) :: mode - integer, intent(in) :: mpicomm - integer, intent(in) :: mpirank - integer, intent(in) :: mpiroot - integer, intent(out) :: ierr - -#ifdef MPI - ! MPI variables - integer :: mpierr -#endif - - ! SIONlib variables - integer :: SIONLIB_fsblksize - integer :: SIONLIB_numfiles - character*2 :: SIONLIB_filemode - ! - integer :: nprocs - integer, dimension(:), allocatable :: procs - integer*8, dimension(:), allocatable :: chunksizes - ! - integer*8 :: brw - integer :: sid - integer :: f_endian, s_endian - logical :: exists - integer*8 :: tables_size - real*8 :: checksum - - integer :: i - - continue - - ierr = 0 - - ! Test if SIONlib file containing pre-computed tables exists - inquire(file=trim(filename), exist=exists) - if (trim(mode)=="read") then - SIONLIB_filemode = "rb" - if (.not.exists) then - if (mpirank==mpiroot) write(0,*) "SIONlib file " // trim(filename) // & - " with precomputed Thompson MP tables not found" - ierr = 1 - return - end if - else if (trim(mode)=="write") then - SIONLIB_filemode = "wb" - SIONLIB_numfiles = 1 - if (exists) then - if (mpirank==mpiroot) write(0,*) "SIONlib file " // trim(filename) // & - " with precomputed Thompson MP tables already exists" - ierr = 1 - return - end if - end if - -#ifdef MPI - ! To avoid that MPI master task creates the file before - ! other tasks pass the inquire test above - call MPI_BARRIER(mpicomm, mpierr) -#endif - - mpi_master_io_only: if (mpirank==mpiroot) then - tables_size = sizeof(tcg_racg) - tables_size = tables_size + sizeof(tmr_racg) - tables_size = tables_size + sizeof(tcr_gacr) - tables_size = tables_size + sizeof(tmg_gacr) - tables_size = tables_size + sizeof(tnr_racg) - tables_size = tables_size + sizeof(tnr_gacr) - tables_size = tables_size + sizeof(tcs_racs1) - tables_size = tables_size + sizeof(tmr_racs1) - tables_size = tables_size + sizeof(tcs_racs2) - tables_size = tables_size + sizeof(tmr_racs2) - tables_size = tables_size + sizeof(tcr_sacr1) - tables_size = tables_size + sizeof(tms_sacr1) - tables_size = tables_size + sizeof(tcr_sacr2) - tables_size = tables_size + sizeof(tms_sacr2) - tables_size = tables_size + sizeof(tnr_racs1) - tables_size = tables_size + sizeof(tnr_racs2) - tables_size = tables_size + sizeof(tnr_sacr1) - tables_size = tables_size + sizeof(tnr_sacr2) - tables_size = tables_size + sizeof(tpi_qcfz) - tables_size = tables_size + sizeof(tni_qcfz) - tables_size = tables_size + sizeof(tpi_qrfz) - tables_size = tables_size + sizeof(tpg_qrfz) - tables_size = tables_size + sizeof(tni_qrfz) - tables_size = tables_size + sizeof(tnr_qrfz) - tables_size = tables_size + sizeof(tps_iaus) - tables_size = tables_size + sizeof(tni_iaus) - tables_size = tables_size + sizeof(tpi_ide) - tables_size = tables_size + sizeof(t_Efrw) - tables_size = tables_size + sizeof(t_Efsw) - tables_size = tables_size + sizeof(tnr_rev) - tables_size = tables_size + sizeof(tpc_wev) - tables_size = tables_size + sizeof(tnc_wev) - tables_size = tables_size + sizeof(tnccn_act) - - ! Autodetect SIONlib filesystem block size - SIONLIB_fsblksize = -1 - - nprocs = 1 - allocate (procs(1:nprocs)) - allocate (chunksizes(1:nprocs)) - do i=1,nprocs - procs(i) = i - chunksizes(i) = sizeof(checksum) + tables_size - end do - - write(0,'(a)') "Opening file " // trim(filename) - call fsion_open(trim(filename), SIONLIB_filemode, nprocs, SIONLIB_numfiles, chunksizes(1), SIONLIB_fsblksize, procs(1), sid) - if (sid<0) write(0,'(a)') "Error opening " // trim(filename) // " in " // trim(mode) // " mode" - - call fsion_seek(sid, mpirank, SION_CURRENT_BLK, SION_CURRENT_POS, ierr) - ! fsion_seek returns ierr=1 if cursor could be positioned as requested and 0 otherwise - if (ierr==1) ierr=0 - - if (trim(mode)=="read") then - ! Check that file endianness is identical to system endianness - call fsion_get_file_endianness(sid, f_endian) - call fsion_get_endianess(s_endian) - if (f_endian .ne. s_endian) then - write(0,'(a)') "Error, endianness of SIONlib file " // trim(filename) // " differs " // & - "from filesystem endianness; please delete file and recalculate tables!" - ierr = 1 - end if - if (ierr==0) then - ! Read checksum - call fsion_read(checksum, int(kind(checksum),8), int(1,8), sid, brw) - ! Read arrays tcg_racg through tnccn_act - call fsion_read(tcg_racg(1,1,1,1), int(kind(tcg_racg(1,1,1,1)),8), int(size(tcg_racg),8), sid, brw) - call fsion_read(tmr_racg(1,1,1,1), int(kind(tmr_racg(1,1,1,1)),8), int(size(tmr_racg),8), sid, brw) - call fsion_read(tcr_gacr(1,1,1,1), int(kind(tcr_gacr(1,1,1,1)),8), int(size(tcr_gacr),8), sid, brw) - call fsion_read(tmg_gacr(1,1,1,1), int(kind(tmg_gacr(1,1,1,1)),8), int(size(tmg_gacr),8), sid, brw) - call fsion_read(tnr_racg(1,1,1,1), int(kind(tnr_racg(1,1,1,1)),8), int(size(tnr_racg),8), sid, brw) - call fsion_read(tnr_gacr(1,1,1,1), int(kind(tnr_gacr(1,1,1,1)),8), int(size(tnr_gacr),8), sid, brw) - call fsion_read(tcs_racs1(1,1,1,1), int(kind(tcs_racs1(1,1,1,1)),8), int(size(tcs_racs1),8), sid, brw) - call fsion_read(tmr_racs1(1,1,1,1), int(kind(tmr_racs1(1,1,1,1)),8), int(size(tmr_racs1),8), sid, brw) - call fsion_read(tcs_racs2(1,1,1,1), int(kind(tcs_racs2(1,1,1,1)),8), int(size(tcs_racs2),8), sid, brw) - call fsion_read(tmr_racs2(1,1,1,1), int(kind(tmr_racs2(1,1,1,1)),8), int(size(tmr_racs2),8), sid, brw) - call fsion_read(tcr_sacr1(1,1,1,1), int(kind(tcr_sacr1(1,1,1,1)),8), int(size(tcr_sacr1),8), sid, brw) - call fsion_read(tms_sacr1(1,1,1,1), int(kind(tms_sacr1(1,1,1,1)),8), int(size(tms_sacr1),8), sid, brw) - call fsion_read(tcr_sacr2(1,1,1,1), int(kind(tcr_sacr2(1,1,1,1)),8), int(size(tcr_sacr2),8), sid, brw) - call fsion_read(tms_sacr2(1,1,1,1), int(kind(tms_sacr2(1,1,1,1)),8), int(size(tms_sacr2),8), sid, brw) - call fsion_read(tnr_racs1(1,1,1,1), int(kind(tnr_racs1(1,1,1,1)),8), int(size(tnr_racs1),8), sid, brw) - call fsion_read(tnr_racs2(1,1,1,1), int(kind(tnr_racs2(1,1,1,1)),8), int(size(tnr_racs2),8), sid, brw) - call fsion_read(tnr_sacr1(1,1,1,1), int(kind(tnr_sacr1(1,1,1,1)),8), int(size(tnr_sacr1),8), sid, brw) - call fsion_read(tnr_sacr2(1,1,1,1), int(kind(tnr_sacr2(1,1,1,1)),8), int(size(tnr_sacr2),8), sid, brw) - call fsion_read(tpi_qcfz(1,1,1,1), int(kind(tpi_qcfz(1,1,1,1)),8), int(size(tpi_qcfz),8), sid, brw) - call fsion_read(tni_qcfz(1,1,1,1), int(kind(tni_qcfz(1,1,1,1)),8), int(size(tni_qcfz),8), sid, brw) - call fsion_read(tpi_qrfz(1,1,1,1), int(kind(tpi_qrfz(1,1,1,1)),8), int(size(tpi_qrfz),8), sid, brw) - call fsion_read(tpg_qrfz(1,1,1,1), int(kind(tpg_qrfz(1,1,1,1)),8), int(size(tpg_qrfz),8), sid, brw) - call fsion_read(tni_qrfz(1,1,1,1), int(kind(tni_qrfz(1,1,1,1)),8), int(size(tni_qrfz),8), sid, brw) - call fsion_read(tnr_qrfz(1,1,1,1), int(kind(tnr_qrfz(1,1,1,1)),8), int(size(tnr_qrfz),8), sid, brw) - call fsion_read(tps_iaus(1,1), int(kind(tps_iaus(1,1)),8), int(size(tps_iaus),8), sid, brw) - call fsion_read(tni_iaus(1,1), int(kind(tni_iaus(1,1)),8), int(size(tni_iaus),8), sid, brw) - call fsion_read(tpi_ide(1,1), int(kind(tpi_ide(1,1)),8), int(size(tpi_ide),8), sid, brw) - call fsion_read(t_Efrw(1,1), int(kind(t_Efrw(1,1)),8), int(size(t_Efrw),8), sid, brw) - call fsion_read(t_Efsw(1,1), int(kind(t_Efsw(1,1)),8), int(size(t_Efsw),8), sid, brw) - call fsion_read(tnr_rev(1,1,1), int(kind(tnr_rev(1,1,1)),8), int(size(tnr_rev),8), sid, brw) - call fsion_read(tpc_wev(1,1,1), int(kind(tpc_wev(1,1,1)),8), int(size(tpc_wev),8), sid, brw) - call fsion_read(tnc_wev(1,1,1), int(kind(tnc_wev (1,1,1)),8), int(size(tnc_wev),8), sid, brw) - call fsion_read(tnccn_act(1,1,1,1,1), int(kind(tnccn_act(1,1,1,1,1)),8), int(size(tnccn_act),8), sid, brw) - else - ! Wrong endianness (ierr/=0) will force checksum match to fail - checksum = -1 - end if - else if (trim(mode)=="write") then - ! Calculate and write checksum - checksum = calculate_checksum() - call fsion_write(checksum, int(kind(checksum),8), int(1,8), sid, brw) - ! Write arrays tcg_racg through tnccn_act - call fsion_write(tcg_racg(1,1,1,1), int(kind(tcg_racg(1,1,1,1)),8), int(size(tcg_racg),8), sid, brw) - call fsion_write(tmr_racg(1,1,1,1), int(kind(tmr_racg(1,1,1,1)),8), int(size(tmr_racg),8), sid, brw) - call fsion_write(tcr_gacr(1,1,1,1), int(kind(tcr_gacr(1,1,1,1)),8), int(size(tcr_gacr),8), sid, brw) - call fsion_write(tmg_gacr(1,1,1,1), int(kind(tmg_gacr(1,1,1,1)),8), int(size(tmg_gacr),8), sid, brw) - call fsion_write(tnr_racg(1,1,1,1), int(kind(tnr_racg(1,1,1,1)),8), int(size(tnr_racg),8), sid, brw) - call fsion_write(tnr_gacr(1,1,1,1), int(kind(tnr_gacr(1,1,1,1)),8), int(size(tnr_gacr),8), sid, brw) - call fsion_write(tcs_racs1(1,1,1,1), int(kind(tcs_racs1(1,1,1,1)),8), int(size(tcs_racs1),8), sid, brw) - call fsion_write(tmr_racs1(1,1,1,1), int(kind(tmr_racs1(1,1,1,1)),8), int(size(tmr_racs1),8), sid, brw) - call fsion_write(tcs_racs2(1,1,1,1), int(kind(tcs_racs2(1,1,1,1)),8), int(size(tcs_racs2),8), sid, brw) - call fsion_write(tmr_racs2(1,1,1,1), int(kind(tmr_racs2(1,1,1,1)),8), int(size(tmr_racs2),8), sid, brw) - call fsion_write(tcr_sacr1(1,1,1,1), int(kind(tcr_sacr1(1,1,1,1)),8), int(size(tcr_sacr1),8), sid, brw) - call fsion_write(tms_sacr1(1,1,1,1), int(kind(tms_sacr1(1,1,1,1)),8), int(size(tms_sacr1),8), sid, brw) - call fsion_write(tcr_sacr2(1,1,1,1), int(kind(tcr_sacr2(1,1,1,1)),8), int(size(tcr_sacr2),8), sid, brw) - call fsion_write(tms_sacr2(1,1,1,1), int(kind(tms_sacr2(1,1,1,1)),8), int(size(tms_sacr2),8), sid, brw) - call fsion_write(tnr_racs1(1,1,1,1), int(kind(tnr_racs1(1,1,1,1)),8), int(size(tnr_racs1),8), sid, brw) - call fsion_write(tnr_racs2(1,1,1,1), int(kind(tnr_racs2(1,1,1,1)),8), int(size(tnr_racs2),8), sid, brw) - call fsion_write(tnr_sacr1(1,1,1,1), int(kind(tnr_sacr1(1,1,1,1)),8), int(size(tnr_sacr1),8), sid, brw) - call fsion_write(tnr_sacr2(1,1,1,1), int(kind(tnr_sacr2(1,1,1,1)),8), int(size(tnr_sacr2),8), sid, brw) - call fsion_write(tpi_qcfz(1,1,1,1), int(kind(tpi_qcfz(1,1,1,1)),8), int(size(tpi_qcfz),8), sid, brw) - call fsion_write(tni_qcfz(1,1,1,1), int(kind(tni_qcfz(1,1,1,1)),8), int(size(tni_qcfz),8), sid, brw) - call fsion_write(tpi_qrfz(1,1,1,1), int(kind(tpi_qrfz(1,1,1,1)),8), int(size(tpi_qrfz),8), sid, brw) - call fsion_write(tpg_qrfz(1,1,1,1), int(kind(tpg_qrfz(1,1,1,1)),8), int(size(tpg_qrfz),8), sid, brw) - call fsion_write(tni_qrfz(1,1,1,1), int(kind(tni_qrfz(1,1,1,1)),8), int(size(tni_qrfz),8), sid, brw) - call fsion_write(tnr_qrfz(1,1,1,1), int(kind(tnr_qrfz(1,1,1,1)),8), int(size(tnr_qrfz),8), sid, brw) - call fsion_write(tps_iaus(1,1), int(kind(tps_iaus(1,1)),8), int(size(tps_iaus),8), sid, brw) - call fsion_write(tni_iaus(1,1), int(kind(tni_iaus(1,1)),8), int(size(tni_iaus),8), sid, brw) - call fsion_write(tpi_ide(1,1), int(kind(tpi_ide(1,1)),8), int(size(tpi_ide),8), sid, brw) - call fsion_write(t_Efrw(1,1), int(kind(t_Efrw(1,1)),8), int(size(t_Efrw),8), sid, brw) - call fsion_write(t_Efsw(1,1), int(kind(t_Efsw(1,1)),8), int(size(t_Efsw),8), sid, brw) - call fsion_write(tnr_rev(1,1,1), int(kind(tnr_rev(1,1,1)),8), int(size(tnr_rev),8), sid, brw) - call fsion_write(tpc_wev(1,1,1), int(kind(tpc_wev(1,1,1)),8), int(size(tpc_wev),8), sid, brw) - call fsion_write(tnc_wev(1,1,1), int(kind(tnc_wev (1,1,1)),8), int(size(tnc_wev),8), sid, brw) - call fsion_write(tnccn_act(1,1,1,1,1), int(kind(tnccn_act(1,1,1,1,1)),8), int(size(tnccn_act),8), sid, brw) - end if - - write(0,'(a)') "Closing file " // trim(filename) - call fsion_close(sid, ierr) - - ierr = 0 - ! Test if checksum matches, this fails if wrong endianness (checksum=-1, see above) - if (trim(mode)=="read" .and. checksum/=calculate_checksum()) then - write(0,'(2(a,e20.9))') "Checksum mismatch, expected", calculate_checksum(), " but got", checksum - call system('rm -f ' // trim(filename)) - ierr = 1 - end if - - deallocate (procs) - deallocate (chunksizes) - - else - - ierr = 0 - - end if mpi_master_io_only - -#ifdef MPI - if (trim(mode)=="read") then - ! After reading the tables, broadcast the information to all MPI tasks. - ! First, broadcast the current error code from MPI master (0 = success) - call MPI_BCAST(ierr, 1, MPI_INTEGER, mpiroot, mpicomm, mpierr) - if (ierr/=0) return - call MPI_BCAST(tcg_racg, size(tcg_racg), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tmr_racg, size(tmr_racg), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcr_gacr, size(tcr_gacr), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tmg_gacr, size(tmg_gacr), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_racg, size(tnr_racg), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_gacr, size(tnr_gacr), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcs_racs1, size(tcs_racs1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tmr_racs1, size(tmr_racs1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcs_racs2, size(tcs_racs2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tmr_racs2, size(tmr_racs2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcr_sacr1, size(tcr_sacr1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tms_sacr1, size(tms_sacr1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tcr_sacr2, size(tcr_sacr2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tms_sacr2, size(tms_sacr2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_racs1, size(tnr_racs1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_racs2, size(tnr_racs2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_sacr1, size(tnr_sacr1), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_sacr2, size(tnr_sacr2), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpi_qcfz, size(tpi_qcfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tni_qcfz, size(tni_qcfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpi_qrfz, size(tpi_qrfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpg_qrfz, size(tpg_qrfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tni_qrfz, size(tni_qrfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_qrfz, size(tnr_qrfz), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tps_iaus, size(tps_iaus), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tni_iaus, size(tni_iaus), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpi_ide, size(tpi_ide), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(t_Efrw, size(t_Efrw), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(t_Efsw, size(t_Efsw), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnr_rev, size(tnr_rev), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tpc_wev, size(tpc_wev), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnc_wev, size(tnc_wev), MPI_DOUBLE_PRECISION, mpiroot, mpicomm, mpierr) - call MPI_BCAST(tnccn_act, size(tnccn_act), MPI_REAL, mpiroot, mpicomm, mpierr) - else if (trim(mode)=="write") then - call MPI_BARRIER(mpicomm, mpierr) - end if -#endif - - return - - contains - - function calculate_checksum() result(checksum) - real*8 :: checksum - checksum = real(tables_size,8)*sum(tcg_racg) - end function calculate_checksum - - end subroutine readwrite_tables -#endif - !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ END MODULE module_mp_thompson diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index ac1d5006c..9e100228e 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -250,8 +250,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 @@ -259,7 +259,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) diff --git a/physics/moninshoc.meta b/physics/moninshoc.meta index aeb337a95..adb4207ef 100644 --- a/physics/moninshoc.meta +++ b/physics/moninshoc.meta @@ -70,8 +70,8 @@ intent = in optional = F [ncnd] - standard_name = number_of_tracers_for_cloud_condensate - long_name = number of tracers for cloud condensate + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer @@ -248,8 +248,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 @@ -257,7 +257,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) diff --git a/physics/mp_thompson.F90 b/physics/mp_thompson.F90 index 1ad4b2d4b..06497a60a 100644 --- a/physics/mp_thompson.F90 +++ b/physics/mp_thompson.F90 @@ -22,6 +22,8 @@ module mp_thompson logical :: is_initialized = .False. + integer, parameter :: ext_ndiag3d = 37 + contains !> This subroutine is a wrapper around the actual thompson_init(). @@ -36,7 +38,8 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & nwfa, nifa, tgrs, prsl, phil, area, & re_cloud, re_ice, re_snow, & mpicomm, mpirank, mpiroot, & - threads, errmsg, errflg) + threads, ext_diag, diag3d, & + errmsg, errflg) implicit none @@ -79,6 +82,9 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & integer, intent(in ) :: mpiroot ! Threading/blocking information integer, intent(in ) :: threads + ! Extended diagnostics + logical, intent(in ) :: ext_diag + real(kind_phys), intent(in ) :: diag3d(:,:,:) ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg @@ -99,14 +105,6 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & if (is_initialized) return - ! DH* temporary - if (mpirank==mpiroot) then - write(0,*) ' ----------------------------------------------------------------------------------------------------------------' - write(0,*) ' --- WARNING --- the CCPP Thompson MP scheme is currently under development, use at your own risk --- WARNING ---' - write(0,*) ' ----------------------------------------------------------------------------------------------------------------' - end if - ! *DH temporary - ! Consistency checks if (imp_physics/=imp_physics_thompson) then write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from Thompson MP" @@ -114,6 +112,14 @@ subroutine mp_thompson_init(ncol, nlev, con_g, con_rd, con_eps, & return end if + if (ext_diag) then + if (size(diag3d,dim=3) /= ext_ndiag3d) then + write(errmsg,'(*(a))') "Logic error: number of diagnostic 3d arrays from model does not match requirements" + errflg = 1 + return + end if + end if + ! Call Thompson init call thompson_init(is_aerosol_aware_in=is_aerosol_aware, mpicomm=mpicomm, & mpirank=mpirank, mpiroot=mpiroot, threads=threads, & @@ -328,11 +334,13 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & spechum, qc, qr, qi, qs, qg, ni, nr, & is_aerosol_aware, nc, nwfa, nifa, & nwfa2d, nifa2d, & - tgrs, prsl, phii, omega, dtp, & + tgrs, prsl, phii, omega, & + dtp, first_time_step, istep, nsteps, & prcp, rain, graupel, ice, snow, sr, & - refl_10cm, reset, do_radar_ref, & + refl_10cm, reset_dBZ, do_radar_ref, & re_cloud, re_ice, re_snow, & - mpicomm, mpirank, mpiroot, & + mpicomm, mpirank, mpiroot, blkno, & + ext_diag, diag3d, reset_diag3d, & errmsg, errflg) implicit none @@ -356,7 +364,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 + logical, intent(in) :: is_aerosol_aware, reset_dBZ ! The following arrays are not allocated if is_aerosol_aware is false real(kind_phys), optional, intent(inout) :: nc(:,:) real(kind_phys), optional, intent(inout) :: nwfa(:,:) @@ -369,6 +377,8 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), intent(in ) :: phii(:,:) real(kind_phys), intent(in ) :: omega(:,:) real(kind_phys), intent(in ) :: dtp + logical, intent(in ) :: first_time_step + integer, intent(in ) :: istep, nsteps ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip real(kind_phys), intent(inout) :: prcp(:) real(kind_phys), intent(inout) :: rain(:) @@ -383,16 +393,24 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & real(kind_phys), optional, intent( out) :: re_cloud(:,:) real(kind_phys), optional, intent( out) :: re_ice(:,:) real(kind_phys), optional, intent( out) :: re_snow(:,:) - ! MPI information + ! MPI and block information + integer, intent(in) :: blkno integer, intent(in) :: mpicomm integer, intent(in) :: mpirank integer, intent(in) :: mpiroot + ! Extended diagnostic output + logical, intent(in) :: ext_diag + real(kind_phys), target, intent(inout) :: diag3d(:,:,:) + logical, intent(in) :: reset_diag3d + ! CCPP error handling character(len=*), intent( out) :: errmsg integer, intent( out) :: errflg ! Local variables + ! Reduced time step if subcycling is used + real(kind_phys) :: dtstep ! Air density real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 ! Water vapor mixing ratio (instead of specific humidity) @@ -427,6 +445,47 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & integer :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte + ! Pointer arrays for extended diagnostics + !real(kind_phys), dimension(:,:,:), pointer :: vts1 => null() + !real(kind_phys), dimension(:,:,:), pointer :: txri => null() + !real(kind_phys), dimension(:,:,:), pointer :: txrc => null() + real(kind_phys), dimension(:,:,:), pointer :: prw_vcdc => null() + real(kind_phys), dimension(:,:,:), pointer :: prw_vcde => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_inu => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_ide_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_ide_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_ide => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_sde_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_sde_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_gde_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_gde_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_iha => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_wfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_rfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_scw => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_scw => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rcs => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_rcs => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rci => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rcg => null() + real(kind_phys), dimension(:,:,:), pointer :: tprw_vcd_c => null() + real(kind_phys), dimension(:,:,:), pointer :: tprw_vcd_e => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_sml => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_gml => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rcg => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rcs => null() + real(kind_phys), dimension(:,:,:), pointer :: tprv_rev => null() + real(kind_phys), dimension(:,:,:), pointer :: tten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qvten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qrten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qsten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qgten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qiten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: niten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: nrten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: ncten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qcten3 => null() ! Initialize the CCPP error handling variables errmsg = '' @@ -439,23 +498,39 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & return end if - if (is_aerosol_aware .and. .not. (present(nc) .and. & - present(nwfa) .and. & - present(nifa) .and. & - present(nwfa2d) .and. & - present(nifa2d) )) then - write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_run:', & - ' aerosol-aware microphysics require all of the', & - ' following optional arguments:', & - ' nc, nwfa, nifa, nwfa2d, nifa2d' - errflg = 1 - return + ! Set reduced time step if subcycling is used + if (nsteps>1) then + dtstep = dtp/real(nsteps, kind=kind_phys) + else + dtstep = dtp + end if + if (first_time_step .and. istep==1 .and. mpirank==mpiroot .and. blkno==1) then + write(*,'(a,i0,a,a,f6.2,a)') 'Thompson MP is using ', nsteps, ' substep(s) per time step', & + ' with an effective time step of ', dtstep, ' seconds' + end if + + if (first_time_step .and. istep==1) then + if (is_aerosol_aware .and. .not. (present(nc) .and. & + present(nwfa) .and. & + present(nifa) .and. & + present(nwfa2d) .and. & + present(nifa2d) )) then + write(errmsg,fmt='(*(a))') 'Logic error in mp_thompson_run:', & + ' aerosol-aware microphysics require all of the', & + ' following optional arguments:', & + ' nc, nwfa, nifa, nwfa2d, nifa2d' + errflg = 1 + return + end if end if !> - 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). + ! DH* - do this only if istep == 1? Would be ok if it was + ! guaranteed that nothing else in the same subcycle group + ! was using these arrays, but it is somewhat dangerous. qv = spechum/(1.0_kind_phys-spechum) if (convert_dry_rho) then @@ -473,6 +548,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & nifa = nifa/(1.0_kind_phys-spechum) end if end if + ! *DH !> - Density of air in kg m-3 rho = con_eps*prsl/(con_rd*tgrs*(qv+con_eps)) @@ -545,12 +621,59 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & kme = nlev kte = nlev + ! Set pointers for extended diagnostics + set_extended_diagnostic_pointers: if (ext_diag) then + if (reset_diag3d) then + diag3d = 0.0 + end if + !vts1 => diag3d(:,:,X:X) + !txri => diag3d(:,:,X:X) + !txrc => diag3d(:,:,X:X) + prw_vcdc => diag3d(:,:,1:1) + prw_vcde => diag3d(:,:,2:2) + tpri_inu => diag3d(:,:,3:3) + tpri_ide_d => diag3d(:,:,4:4) + tpri_ide_s => diag3d(:,:,5:5) + tprs_ide => diag3d(:,:,6:6) + tprs_sde_d => diag3d(:,:,7:7) + tprs_sde_s => diag3d(:,:,8:8) + tprg_gde_d => diag3d(:,:,9:9) + tprg_gde_s => diag3d(:,:,10:10) + tpri_iha => diag3d(:,:,11:11) + tpri_wfz => diag3d(:,:,12:12) + tpri_rfz => diag3d(:,:,13:13) + tprg_rfz => diag3d(:,:,14:14) + tprs_scw => diag3d(:,:,15:15) + tprg_scw => diag3d(:,:,16:16) + tprg_rcs => diag3d(:,:,17:17) + tprs_rcs => diag3d(:,:,18:18) + tprr_rci => diag3d(:,:,19:19) + tprg_rcg => diag3d(:,:,20:20) + tprw_vcd_c => diag3d(:,:,21:21) + tprw_vcd_e => diag3d(:,:,22:22) + tprr_sml => diag3d(:,:,23:23) + tprr_gml => diag3d(:,:,24:24) + tprr_rcg => diag3d(:,:,25:25) + tprr_rcs => diag3d(:,:,26:26) + tprv_rev => diag3d(:,:,27:27) + tten3 => diag3d(:,:,28:28) + qvten3 => diag3d(:,:,29:29) + qrten3 => diag3d(:,:,30:30) + qsten3 => diag3d(:,:,31:31) + qgten3 => diag3d(:,:,32:32) + qiten3 => diag3d(:,:,33:33) + niten3 => diag3d(:,:,34:34) + nrten3 => diag3d(:,:,35:35) + ncten3 => diag3d(:,:,36:36) + qcten3 => diag3d(:,:,37:37) + end if set_extended_diagnostic_pointers + !> - Call mp_gt_driver() with or without aerosols if (is_aerosol_aware) then if (do_effective_radii) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -566,11 +689,31 @@ 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, & - errmsg=errmsg, errflg=errflg, reset=reset) + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, & + ! vts1=vts1, txri=txri, txrc=txrc, & + prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs=tprs_rcs, & + tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + tprv_rev=tprv_rev, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -585,12 +728,32 @@ 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, & - errmsg=errmsg, errflg=errflg, reset=reset) + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, & + ! vts1=vts1, txri=txri, txrc=txrc, & + prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs=tprs_rcs, & + tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + tprv_rev=tprv_rev, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3) end if else if (do_effective_radii) then call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -606,10 +769,30 @@ 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, & - errmsg=errmsg, errflg=errflg, reset=reset) + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, & + ! vts1=vts1, txri=txri, txrc=txrc, & + prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs=tprs_rcs, & + tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + tprv_rev=tprv_rev, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3) else call mp_gt_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & - tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtp, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, & rainnc=rain_mp, rainncv=delta_rain_mp, & snownc=snow_mp, snowncv=delta_snow_mp, & icenc=ice_mp, icencv=delta_ice_mp, & @@ -624,11 +807,35 @@ 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, & - errmsg=errmsg, errflg=errflg, reset=reset) + reset_dBZ=reset_dBZ, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, & + ! vts1=vts1, txri=txri, txrc=txrc, & + prw_vcdc=prw_vcdc, & + prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + tprs_sde_d=tprs_sde_d, & + tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + tprs_rcs=tprs_rcs, & + tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + tprv_rev=tprv_rev, tten3=tten3, & + qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + qcten3=qcten3) end if end if if (errflg/=0) return + ! DH* - do this only if istep == nsteps? Would be ok if it was + ! guaranteed that nothing else in the same subcycle group + ! was using these arrays, but it is somewhat dangerous. + !> - Convert water vapor mixing ratio back to specific humidity spechum = qv/(1.0_kind_phys+qv) @@ -647,6 +854,7 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & nifa = nifa/(1.0_kind_phys+qv) end if end if + ! *DH !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables ! "rain" in Thompson MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) @@ -656,6 +864,55 @@ subroutine mp_thompson_run(ncol, nlev, con_g, con_rd, & snow = snow + max(0.0, delta_snow_mp/1000.0_kind_phys) rain = rain + max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) + ! Recompute sr at last subcycling step + if (nsteps>1 .and. istep == nsteps) then + ! Unlike inside mp_gt_driver, rain does not contain frozen precip + sr = (snow + graupel + ice)/(rain + snow + graupel + ice +1.e-12) + end if + + unset_extended_diagnostic_pointers: if (ext_diag) then + !vts1 => null() + !txri => null() + !txrc => null() + prw_vcdc => null() + prw_vcde => null() + tpri_inu => null() + tpri_ide_d => null() + tpri_ide_s => null() + tprs_ide => null() + tprs_sde_d => null() + tprs_sde_s => null() + tprg_gde_d => null() + tprg_gde_s => null() + tpri_iha => null() + tpri_wfz => null() + tpri_rfz => null() + tprg_rfz => null() + tprs_scw => null() + tprg_scw => null() + tprg_rcs => null() + tprs_rcs => null() + tprr_rci => null() + tprg_rcg => null() + tprw_vcd_c => null() + tprw_vcd_e => null() + tprr_sml => null() + tprr_gml => null() + tprr_rcg => null() + tprr_rcs => null() + tprv_rev => null() + tten3 => null() + qvten3 => null() + qrten3 => null() + qsten3 => null() + qgten3 => null() + qiten3 => null() + niten3 => null() + nrten3 => null() + ncten3 => null() + qcten3 => null() + end if unset_extended_diagnostic_pointers + end subroutine mp_thompson_run !>@} diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 237890024..1ab496c25 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -302,6 +302,23 @@ type = integer intent = in optional = F +[ext_diag] + standard_name = flag_for_extended_diagnostic_output_from_thompson_microphysics + long_name = flag for extended diagnostic output from thompson microphysics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[diag3d] + standard_name = extended_diagnostics_output_from_thompson_microphysics + long_name = set of 3d arrays for extended diagnostics output from thompson microphysics + units = none + dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -545,6 +562,30 @@ kind = kind_phys intent = in optional = F +[first_time_step] + standard_name = flag_for_first_time_step + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in + optional = F +[istep] + standard_name = ccpp_loop_counter + long_name = loop counter for subcycling loops in CCPP + units = index + dimensions = () + type = integer + intent = in + optional = F +[nsteps] + standard_name = ccpp_loop_extent + long_name = loop extent for subcycling loops in CCPP + units = count + dimensions = () + type = integer + intent = in + optional = F [prcp] standard_name = lwe_thickness_of_explicit_precipitation_amount long_name = explicit precipitation (rain, ice, snow, graupel) on physics timestep @@ -608,7 +649,7 @@ kind = kind_phys intent = out optional = F -[reset] +[reset_dBZ] standard_name = flag_for_resetting_radar_reflectivity_calculation long_name = flag for resetting radar reflectivity calculation units = flag @@ -675,6 +716,39 @@ type = integer intent = in optional = F +[blkno] + standard_name = ccpp_block_number + long_name = number of block for explicit data blocking in CCPP + units = index + dimensions = () + type = integer + intent = in + optional = F +[ext_diag] + standard_name = flag_for_extended_diagnostic_output_from_thompson_microphysics + long_name = flag for extended diagnostic output from thompson microphysics + units = flag + dimensions = () + type = logical + intent = in + optional = F +[diag3d] + standard_name = extended_diagnostics_output_from_thompson_microphysics + long_name = set of 3d arrays for extended diagnostics output from thompson microphysics + units = none + dimensions = (horizontal_loop_extent,vertical_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) + type = real + kind = kind_phys + intent = inout + optional = F +[reset_diag3d] + standard_name = flag_reset_extended_diagnostics_output_arrays_from_thompson_microphysics + long_name = flag for resetting extended diagnostics output arrays from thompson microphysics + units = flag + dimensions = () + type = logical + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index ab7d33e44..3ec34513c 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -334,7 +334,7 @@ end subroutine sfc_init subroutine setalb & & ( slmsk,lsm,lsm_noahmp,lsm_ruc,snowf, & ! --- inputs: & sncovr,sncovr_ice,snoalb,zorlf,coszf, & - & tsknf,tairf,hprif,landfrac,frac_grid,min_seaice, & + & tsknf,tairf,hprif,frac_grid,min_seaice, & & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & @@ -409,7 +409,7 @@ subroutine setalb & logical, intent(in) :: frac_grid real (kind=kind_phys), dimension(:), intent(in) :: & - & slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, landfrac, & + & slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, & & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & & lsmalbdvis, lsmalbdnir, lsmalbivis, lsmalbinir, & & icealbdvis, icealbdnir, icealbivis, icealbinir, & @@ -687,7 +687,6 @@ end subroutine setalb !! or -pi -> +pi ranges !!\param xlat (IMAX), latitude in radiance, default to pi/2 -> !! -pi/2 range, otherwise see in-line comment -!!\param landfrac (IMAX), fraction of grid that is land !!\param snowf (IMAX), snow depth water equivalent in mm !!\param sncovr (IMAX), snow cover over land !!\param zorlf (IMAX), surface roughness in cm @@ -700,7 +699,7 @@ end subroutine setalb !! @{ !----------------------------------- subroutine setemis & - & ( lsm,lsm_noahmp,lsm_ruc,vtype,landfrac,frac_grid, & ! --- inputs: + & ( lsm,lsm_noahmp,lsm_ruc,vtype,frac_grid, & ! --- inputs: & min_seaice,xlon,xlat,slmsk,snowf,sncovr,sncovr_ice, & & zorlf,tsknf,tairf,hprif, & & semis_lnd,semis_ice,IMAX,fracl,fraco,fraci,icy, & @@ -723,7 +722,6 @@ subroutine setemis & ! xlat (IMAX) - latitude in radiance, default to pi/2 -> -pi/2 ! ! range, otherwise see in-line comment ! ! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! -! landfrac (IMAX) - fraction of land on on fcst model grid ! ! snowf (IMAX) - snow depth water equivalent in mm ! ! sncovr(IMAX) - ialbflg=1: snow cover over land in fraction ! ! sncovr_ice(IMAX) - snow cover over ice in fraction ! @@ -759,7 +757,6 @@ subroutine setemis & integer, intent(in) :: lsm, lsm_noahmp, lsm_ruc logical, intent(in) :: frac_grid real (kind=kind_phys), dimension(:), intent(in) :: vtype - real (kind=kind_phys), dimension(:), intent(in) :: landfrac real (kind=kind_phys), intent(in) :: min_seaice real (kind=kind_phys), dimension(:), intent(in) :: & @@ -892,7 +889,7 @@ subroutine setemis & asnow = 0.02*snowf(i) argh = min(0.50, max(.025,0.01*zorlf(i))) hrgh = min(f_one,max(0.20,1.0577-1.1538e-3*hprif(i))) - fsno = asnow / (argh + asnow) * hrgh + fsno = asnow / (argh + asnow) * hrgh sfcemis_ice = sfcemis_ice*(f_one-fsno)+emsref(8)*fsno endif elseif (lsm == lsm_ruc) then @@ -906,7 +903,7 @@ subroutine setemis & !-- Composite emissivity from land, water and ice fractions. sfcemis(i) = fracl(i)*sfcemis_land + fraco(i)*emsref(1) & - & + fraci(i)*sfcemis_ice + & + fraci(i)*sfcemis_ice enddo ! i diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index ee58baecd..79a5dce40 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -297,7 +297,7 @@ end subroutine rascnv_finalize !! \section arg_table_rascnv_run Argument Table !! \htmlinclude rascnv_run.html !! - subroutine rascnv_run(IM, k, ntr, dt, dtf & + subroutine rascnv_run(IM, k, itc, ntc, ntr, dt, dtf & &, ccwf, area, dxmin, dxinv & &, psauras, prauras, wminras, dlqf, flipv & &, me, rannum, nrcm, mp_phys, mp_phys_mg & @@ -332,7 +332,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! logical, intent(in) :: flipv ! - integer, intent(in) :: im, k, ntr, me, nrcm, ntk, kdt & + integer, intent(in) :: im, k, itc, ntc, ntr, me, nrcm, ntk, kdt & &, mp_phys, mp_phys_mg integer, dimension(:), intent(out) :: kbot, ktop integer, dimension(:), intent(inout) :: kcnv @@ -401,11 +401,15 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & real fscav_(ntr+2) ! Fraction scavenged per km ! fscav_ = -999.0_kp ! By default no scavenging - if (ntr > 0 .and. fscav(1) > zero) then - do i=1,ntr - fscav_(i) = fscav(i) - enddo - endif + if (itc > 0 .and. ntc > 0) then + if (ntr >= itc + ntc - 3) then + fscav_(itc:ntc) = fscav + else + errmsg = 'Error in rascnv_run: test ntr >= itc + ntc - 3 FAILED' + errflg = 1 + return + end if + end if trcmin = -99999.0_kp if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4_kp @@ -681,7 +685,8 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & if (advups) then ! For first order upstream for updraft alfint(:,:) = one elseif (advtvd) then ! TVD flux limiter scheme for updraft - alfint(:,:) = one +! alfint(:,:) = one + alfint(:,:) = half l = krmin lm1 = l - 1 dtvd(1,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & diff --git a/physics/rascnv.meta b/physics/rascnv.meta index 4babf620d..40ae7d684 100644 --- a/physics/rascnv.meta +++ b/physics/rascnv.meta @@ -210,6 +210,22 @@ type = integer intent = in optional = F +[itc] + standard_name = number_of_aerosol_tracers_for_convection + long_name = number of aerosol tracers transported/scavenged by convection + units = count + dimensions = () + type = integer + intent = in + optional = F +[ntc] + standard_name = number_of_chemical_tracers + long_name = number of chemical tracers + units = count + dimensions = () + type = integer + intent = in + optional = F [ntr] standard_name = number_of_tracers_for_samf long_name = number of tracers for scale-aware mass flux schemes diff --git a/physics/samfaerosols.F b/physics/samfaerosols.F index fea4b5ead..87a2277dd 100644 --- a/physics/samfaerosols.F +++ b/physics/samfaerosols.F @@ -77,6 +77,7 @@ subroutine samfdeepcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, ecdo2 = zero ecko2 = zero qaero = zero + wet_dep = zero c -- set work arrays @@ -91,7 +92,7 @@ subroutine samfdeepcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, do k = 1, km do i = 1, im - xmbp(i,k) = g * xmb(i) / delp(i,k) + if (cnvflg(i)) xmbp(i,k) = g * xmb(i) / delp(i,k) enddo enddo @@ -477,6 +478,7 @@ subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, !ecdo2 = zero ecko2 = zero qaero = zero + wet_dep = zero c -- set work arrays @@ -491,7 +493,7 @@ subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, do k = 1, km do i = 1, im - xmbp(i,k) = g * xmb(i) / delp(i,k) + if (cnvflg(i)) xmbp(i,k) = g * xmb(i) / delp(i,k) enddo enddo @@ -810,4 +812,4 @@ subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, return end subroutine samfshalcnv_aerosols - end module samfcnv_aerosols \ No newline at end of file + end module samfcnv_aerosols diff --git a/physics/samfdeepcnv.f b/physics/samfdeepcnv.f index 425aa92a9..95e99e7be 100644 --- a/physics/samfdeepcnv.f +++ b/physics/samfdeepcnv.f @@ -10,9 +10,9 @@ module samfdeepcnv contains - subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, & + subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, & & errmsg, errflg) - + integer, intent(in) :: imfdeepcnv integer, intent(in) :: imfdeepcnv_samf character(len=*), intent(out) :: errmsg @@ -21,7 +21,7 @@ subroutine samfdeepcnv_init(imfdeepcnv,imfdeepcnv_samf, & ! Consistency checks if (imfdeepcnv/=imfdeepcnv_samf) then - write(errmsg,'(*(a))') 'Logic error: namelist choice of', & + write(errmsg,'(*(a))') 'Logic error: namelist choice of', & & ' deep convection is different from SAMF scheme' errflg = 1 return @@ -80,10 +80,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & t0c,delt,ntk,ntr,delp, & & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav,hwrf_samfdeep, & & cldwrk,rn,kbot,ktop,kcnv,islimsk,garea, & - & dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & + & dot,ncloud,hpbl,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & & QLCN, QICN, w_upi, cf_upi, CNV_MFD, & & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys,mp_phys_mg,& - & clam,c0s,c1,betal,betas,evfact,evfactl,pgcon,asolfac, & + & clam,c0s,c1,betal,betas,evef,pgcon,asolfac, & & do_ca, ca_closure, ca_entr, ca_trigger, nthresh, ca_deep, & & rainevap, & & errmsg,errflg) @@ -99,7 +99,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & fv, grav, hvap, rd, rv, t0c real(kind=kind_phys), intent(in) :: delt real(kind=kind_phys), intent(in) :: psp(:), delp(:,:), & - & prslp(:,:), garea(:), dot(:,:), phil(:,:) + & prslp(:,:), garea(:), hpbl(:), dot(:,:), phil(:,:) real(kind=kind_phys), dimension(:), intent(in) :: fscav logical, intent(in) :: hwrf_samfdeep real(kind=kind_phys), intent(in) :: nthresh @@ -108,6 +108,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & 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(:,:,:), & & q1(:,:), t1(:,:), u1(:,:), v1(:,:), & & cnvw(:,:), cnvc(:,:) @@ -128,7 +129,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys), intent(in) :: clam, c0s, c1, & & betal, betas, asolfac, & - & evfact, evfactl, pgcon + & evef, pgcon character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! @@ -137,12 +138,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! integer latd,lond ! real(kind=kind_phys) clamd, tkemx, tkemn, dtke, - & beta, dbeta, betamx, betamn, + & beta, clamca, & cxlame, cxlamd, - & cxlamu, & xlamde, xlamdd, - & crtlamd, - & crtlame + & crtlame, crtlamd ! ! real(kind=kind_phys) detad real(kind=kind_phys) adw, aup, aafac, d0, @@ -157,7 +156,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & edtmaxl, edtmaxs, el2orc, elocp, & es, etah, & cthk, dthk, - & evef, fact1, fact2, factor, +! & evfact, evfactl, + & fact1, fact2, factor, & gamma, pprime, cm, & qlk, qrch, qs, & rain, rfact, shear, tfac, @@ -171,15 +171,16 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & xqrch, tem, tem1, tem2, & ptem, ptem1, ptem2 ! - integer kb(im), kbcon(im), kbcon1(im), + integer kb(im), kb1(im), kbcon(im), kbcon1(im), & ktcon(im), ktcon1(im), ktconn(im), & jmin(im), lmin(im), kbmax(im), - & kbm(im), kmax(im) + & kbm(im), kmax(im), kd94(im) ! ! real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), real(kind=kind_phys) aa1(im), tkemean(im),clamt(im), & ps(im), del(im,km), prsl(im,km), - & umean(im), tauadv(im), gdx(im), +! & umean(im), tauadv(im), gdx(im), + & gdx(im), & delhbar(im), delq(im), delq2(im), & delqbar(im), delqev(im), deltbar(im), & deltv(im), dtconv(im), edt(im), @@ -197,10 +198,11 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! & xpwev(im), delebar(im,ntr), & delubar(im), delvbar(im) ! - real(kind=kind_phys) c0(im) + real(kind=kind_phys) c0(im), sfcpbl(im) cj real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, - & cinacr, cinacrmx, cinacrmn + & cinacr, cinacrmx, cinacrmn, + & sfclfac, rhcrt cj ! ! parameters for updraft velocity calculation @@ -226,9 +228,9 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & parameter(cm=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) parameter(dtke=tkemx-tkemn) - parameter(dbeta=0.1) - parameter(cthk=150.,dthk=25.) + parameter(cthk=200.,dthk=25.,sfclfac=0.2,rhcrt=0.75) parameter(cinpcrmx=180.,cinpcrmn=120.) ! parameter(cinacrmx=-120.,cinacrmn=-120.) parameter(cinacrmx=-120.,cinacrmn=-80.) @@ -251,7 +253,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), & dbyo(im,km), zo(im,km), & xlamue(im,km), xlamud(im,km), - & fent1(im,km), fent2(im,km), frh(im,km), + & fent1(im,km), fent2(im,km), + & rh(im,km), frh(im,km), & heo(im,km), heso(im,km), & qrcd(im,km), dellah(im,km), dellaq(im,km), & dellae(im,km,ntr), @@ -262,7 +265,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & & qrcko(im,km), qrcdo(im,km), & pwo(im,km), pwdo(im,km), c0t(im,km), & tx1(im), sumx(im), cnvwt(im,km) -! &, rhbar(im) + &, rhbar(im) ! logical do_aerosols, totflg, cnvflg(im), asqecflg(im), flg(im) ! @@ -317,6 +320,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & c do i=1,im cnvflg(i) = .true. + sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. mbdt(i)=10. kbot(i)=km+1 @@ -341,12 +345,20 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & cina(i) = 0. pwavo(i)= 0. pwevo(i)= 0. + xmb(i) = 0. xpwav(i)= 0. xpwev(i)= 0. vshear(i) = 0. rainevap(i) = 0. gdx(i) = sqrt(garea(i)) enddo + + do k=1,km + do i=1,im + xlamud(i,k) = 0. + xlamue(i,k) = 0. + enddo + enddo ! if (hwrf_samfdeep) then do i=1,im @@ -424,16 +436,17 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! model tunable parameters are all here edtmaxl = .3 edtmaxs = .3 +! evfact = 0.3 +! evfactl = 0.3 + aafac = .1 if (hwrf_samfdeep) then - aafac = .1 - cxlamu = 1.0e-3 + cxlame = 1.0e-3 else - aafac = .05 cxlame = 1.0e-4 endif - crtlamd = 1.0e-4 + cxlamd = 0.75e-4 crtlame = 1.0e-4 - cxlamd = 1.0e-4 + crtlamd = 1.0e-4 xlamde = 1.0e-4 xlamdd = 1.0e-4 ! @@ -457,6 +470,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & kbmax(i) = km kbm(i) = km kmax(i) = km + kd94(i) = km tx1(i) = 1.0 / ps(i) enddo ! @@ -465,12 +479,14 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if (prsl(i,k)*tx1(i) > 0.04) kmax(i) = k + 1 if (prsl(i,k)*tx1(i) > 0.45) kbmax(i) = k + 1 if (prsl(i,k)*tx1(i) > 0.70) kbm(i) = k + 1 + if (prsl(i,k)*tx1(i) > 0.94) kd94(i) = k + 1 enddo enddo do i=1,im kmax(i) = min(km,kmax(i)) kbmax(i) = min(kbmax(i),kmax(i)) kbm(i) = min(kbm(i),kmax(i)) + kd94(i) = min(kd94(i),kmax(i)) enddo c c hydrostatic height assume zero terr and initially assume @@ -507,6 +523,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & eta(i,k) = 1. fent1(i,k)= 1. fent2(i,k)= 1. + rh(i,k) = 0. frh(i,k) = 0. hcko(i,k) = 0. qcko(i,k) = 0. @@ -591,14 +608,32 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & c this is the level where updraft starts c !> ## Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). -!> - Search below index "kbm" for the level of maximum moist static energy. +!> - Find the index for a level of sfclfac*hpbl which is initial guess for the parcel starting level. + do i=1,im + flg(i) = .true. + kb1(i) = 1 + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. zo(i,k) <= sfcpbl(i)) then + kb1(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + kb1(i) = min(kb1(i),kbm(i)) + enddo +c +!> - Search below index "kbm" and above kb1 for the level of maximum moist static energy. do i=1,im - hmax(i) = heo(i,1) - kb(i) = 1 + hmax(i) = heo(i,kb1(i)) + kb(i) = kb1(i) enddo do k = 2, km do i=1,im - if (k <= kbm(i)) then + if (k > kb1(i) .and. k <= kbm(i)) then if(heo(i,k) > hmax(i)) then kb(i) = k hmax(i) = heo(i,k) @@ -640,8 +675,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & val2 = 1.e-10 qo(i,k) = max(qo(i,k), val2 ) ! qo(i,k) = min(qo(i,k),qeso(i,k)) - tem = min(qo(i,k)/qeso(i,k), 1.) - frh(i,k) = 1. - tem + rh(i,k) = min(qo(i,k)/qeso(i,k), 1.) + frh(i,k) = 1. - rh(i,k) heo(i,k) = .5 * grav * (zo(i,k) + zo(i,k+1)) + & cp * to(i,k) + hvap * qo(i,k) heso(i,k) = .5 * grav * (zo(i,k) + zo(i,k+1)) + @@ -685,14 +720,6 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i=1,im if(kbcon(i) == kmax(i)) cnvflg(i) = .false. enddo -!! - if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo - endif !! totflg = .true. do i=1,im @@ -746,13 +773,112 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & enddo !! if(do_ca .and. ca_trigger)then + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo + endif + + totflg = .true. do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +! re-define kb & kbcon +! + do i=1,im + if (cnvflg(i)) then + hmax(i) = heo(i,1) + kb(i) = 1 + endif + enddo + do k = 2, km + do i=1,im + if (cnvflg(i) .and. k <= kbm(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo enddo +! + do i=1,im + flg(i) = cnvflg(i) + if(flg(i)) kbcon(i) = kmax(i) + enddo + do k = 1, km1 + do i=1,im + if (flg(i) .and. k <= kbmax(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +! + do i=1,im + if(cnvflg(i) .and. kbcon(i) == kmax(i)) then + cnvflg(i) = .false. + endif + enddo +!! + if(do_ca .and. ca_trigger)then + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo endif + + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +! +!> - if the mean relative humidity in the subcloud layers is less than a threshold value (rhcrt), convection is not triggered. +! + do i = 1, im + rhbar(i) = 0. + sumx(i) = 0. + enddo + do k = 1, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kb(i) .and. k < kbcon(i)) then + dz = zo(i,k+1) - zo(i,k) + rhbar(i) = rhbar(i) + rh(i,k) * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + rhbar(i) = rhbar(i) / sumx(i) + if(rhbar(i) < rhcrt) then + cnvflg(i) = .false. + endif + endif + enddo !! + if(do_ca .and. ca_trigger)then + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo + endif + totflg = .true. do i=1,im totflg = totflg .and. (.not. cnvflg(i)) @@ -760,6 +886,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(totflg) return !! ! +!Lisa: at this point only trigger criteria is set + ! turbulent entrainment rate assumed to be proportional ! to subcloud mean TKE ! @@ -799,13 +927,25 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif enddo ! + if(do_ca .and. ca_entr)then + do i=1,im + if(cnvflg(i)) then + if(ca_deep(i) > nthresh)then + clamt(i) = clam - clamca + else + clamt(i) = clam + endif + endif + enddo + endif + else ! if(do_ca .and. ca_entr)then do i=1,im if(cnvflg(i)) then if(ca_deep(i) > nthresh)then - clamt(i) = clam - clamd + clamt(i) = clam - clamca else clamt(i) = clam endif @@ -827,7 +967,8 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do k = 1, km1 do i=1,im if(cnvflg(i)) then - xlamue(i,k) = clamt(i) / zi(i,k) + dz =zo(i,k+1) - zo(i,k) + xlamue(i,k) = clamt(i) / (zi(i,k) + dz) xlamue(i,k) = max(xlamue(i,k), crtlame) endif enddo @@ -874,6 +1015,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do k = 1, km1 do i=1,im if(cnvflg(i) .and. k < kmax(i)) then +! xlamud(i,k) = crtlamd xlamud(i,k) = 0.001 * clamt(i) endif enddo @@ -904,7 +1046,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i=1,im if(cnvflg(i) .and. & (k > kbcon(i) .and. k < kmax(i))) then - tem = cxlamu * frh(i,k) * fent2(i,k) + tem = cxlame * frh(i,k) * fent2(i,k) xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem endif enddo @@ -1071,14 +1213,14 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif enddo !! + if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo endif -!! + totflg = .true. do i = 1, im totflg = totflg .and. (.not. cnvflg(i)) @@ -1154,13 +1296,12 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif !hwrf_samfdeep !! if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo endif -!! + totflg = .true. do i=1,im totflg = totflg .and. (.not. cnvflg(i)) @@ -1195,21 +1336,22 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & if(tem < cthk) cnvflg(i) = .false. endif enddo -!! + + if(do_ca .and. ca_trigger)then - do i=1,im - if(ca_deep(i) > nthresh) then - cnvflg(i) = .true. - endif - enddo + do i=1,im + if(ca_deep(i) > nthresh) cnvflg(i) = .true. + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo endif -!! + totflg = .true. - do i = 1, im + do i=1,im totflg = totflg .and. (.not. cnvflg(i)) enddo if(totflg) return !! + c c search for downdraft originating level above theta-e minimum c @@ -1644,60 +1786,34 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do k = 1, km1 do i = 1, im if(cnvflg(i)) then - if(k >= 1 .and. k < kbcon(i)) then + if(k >= 1 .and. k < kd94(i)) then dz = zi(i,k+1) - zi(i,k) sumx(i) = sumx(i) + dz endif endif enddo enddo - - if (hwrf_samfdeep) then - do i = 1, im + do i = 1, im beta = betas if(islimsk(i) == 1) beta = betal if(cnvflg(i)) then - dz = (sumx(i)+zi(i,1))/float(kbcon(i)) - tem = 1./float(kbcon(i)) + dz = (sumx(i)+zi(i,1))/float(kd94(i)) + tem = 1./float(kd94(i)) xlamd(i) = (1.-beta**tem)/dz endif - enddo - else - do i = 1, im - if(cnvflg(i)) then - betamn = betas - if(islimsk(i) == 1) betamn = betal - if(ntk > 0) then - betamx = betamn + dbeta - if(tkemean(i) > tkemx) then - beta = betamn - else if(tkemean(i) < tkemn) then - beta = betamx - else - tem = (betamx - betamn) * (tkemean(i) - tkemn) - beta = betamx - tem / dtke - endif - else - beta = betamn - endif - dz = (sumx(i)+zi(i,1))/float(kbcon(i)) - tem = 1./float(kbcon(i)) - xlamd(i) = (1.-beta**tem)/dz - endif - enddo - endif + enddo c c determine downdraft mass flux c -!> - Calculate the normalized downdraft mass flux from equation 1 of Pan and Wu (1995) \cite pan_and_wu_1995 . Downdraft entrainment and detrainment rates are constants from the downdraft origination to the LFC. +!> - Calculate the normalized downdraft mass flux from equation 1 of Pan and Wu (1995) \cite pan_and_wu_1995 . Downdraft entrainment and detrainment rates are constants from the downdraft origination to the level of 60mb above the ground surface (kd94). do k = km1, 1, -1 do i = 1, im if (cnvflg(i) .and. k <= kmax(i)-1) then - if(k < jmin(i) .and. k >= kbcon(i)) then + if(k < jmin(i) .and. k >= kd94(i)) then dz = zi(i,k+1) - zi(i,k) ptem = xlamdd - xlamde etad(i,k) = etad(i,k+1) * (1. - ptem * dz) - else if(k < kbcon(i)) then + else if(k < kd94(i)) then dz = zi(i,k+1) - zi(i,k) ptem = xlamd(i) + xlamdd - xlamde etad(i,k) = etad(i,k+1) * (1. - ptem * dz) @@ -1737,7 +1853,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if (cnvflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) - if(k >= kbcon(i)) then + if(k >= kd94(i)) then tem = xlamde * dz tem1 = 0.5 * xlamdd * dz else @@ -1786,7 +1902,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - if(k >= kbcon(i)) then + if(k >= kd94(i)) then tem = xlamde * dz tem1 = 0.5 * xlamdd * dz else @@ -1935,7 +2051,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) tem1 = 0.5 * (xlamud(i,k)+xlamud(i,k-1)) c - if(k <= kbcon(i)) then + if(k <= kd94(i)) then ptem = xlamde ptem1 = xlamd(i)+xlamdd else @@ -2247,7 +2363,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & do i = 1, im if (asqecflg(i) .and. k < jmin(i)) then dz = zi(i,k+1) - zi(i,k) - if(k >= kbcon(i)) then + if(k >= kd94(i)) then tem = xlamde * dz tem1 = 0.5 * xlamdd * dz else @@ -2272,7 +2388,7 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & ! detad = etad(i,k+1) - etad(i,k) cj dz = zi(i,k+1) - zi(i,k) - if(k >= kbcon(i)) then + if(k >= kd94(i)) then tem = xlamde * dz tem1 = 0.5 * xlamdd * dz else @@ -2424,40 +2540,41 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & endif ! !> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. - do i= 1, im - if(cnvflg(i)) then - sumx(i) = 0. - umean(i) = 0. - endif - enddo - do k = 2, km1 - do i = 1, im - if(cnvflg(i)) then - if(k >= kbcon1(i) .and. k < ktcon1(i)) then - dz = zi(i,k) - zi(i,k-1) - tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) - umean(i) = umean(i) + tem * dz - sumx(i) = sumx(i) + dz - endif - endif - enddo - enddo - do i= 1, im - if(cnvflg(i)) then - umean(i) = umean(i) / sumx(i) - umean(i) = max(umean(i), 1.) - tauadv(i) = gdx(i) / umean(i) - endif - enddo +! do i= 1, im +! if(cnvflg(i)) then +! sumx(i) = 0. +! umean(i) = 0. +! endif +! enddo +! do k = 2, km1 +! do i = 1, im +! if(cnvflg(i)) then +! if(k >= kbcon1(i) .and. k < ktcon1(i)) then +! dz = zi(i,k) - zi(i,k-1) +! tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) +! umean(i) = umean(i) + tem * dz +! sumx(i) = sumx(i) + dz +! endif +! endif +! enddo +! enddo +! do i= 1, im +! if(cnvflg(i)) then +! umean(i) = umean(i) / sumx(i) +! umean(i) = max(umean(i), 1.) +! tauadv(i) = gdx(i) / umean(i) +! endif +! enddo !> - 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. !! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. do i= 1, im if(cnvflg(i) .and. .not.asqecflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - tfac = tauadv(i) / dtconv(i) - tfac = min(tfac, 1.) - xmb(i) = tfac*betaw*rho*wc(i) +! tfac = tauadv(i) / dtconv(i) +! tfac = min(tfac, 1.) +! xmb(i) = tfac*betaw*rho*wc(i) + xmb(i) = betaw*rho*wc(i) endif enddo !> - For the cases where the quasi-equilibrium assumption of Arakawa-Schubert is valid, first calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : @@ -2497,9 +2614,10 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & !! !! Again when dtconv is larger than tauadv, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. if(asqecflg(i)) then - tfac = tauadv(i) / dtconv(i) - tfac = min(tfac, 1.) - xmb(i) = -tfac * fld(i) / xk(i) +! tfac = tauadv(i) / dtconv(i) +! tfac = min(tfac, 1.) +! xmb(i) = -tfac * fld(i) / xk(i) + xmb(i) = -fld(i) / xk(i) endif enddo !! @@ -2713,10 +2831,9 @@ subroutine samfdeepcnv_run (im,km,itc,ntc,cliq,cp,cvap, & rn(i) = rn(i) + rain * xmb(i) * .001 * dt2 endif if(flg(i) .and. k < ktcon(i)) then - evef = edt(i) * evfact - if(islimsk(i) == 1) evef=edt(i) * evfactl +! evef = edt(i) * evfact +! if(islimsk(i) == 1) evef=edt(i) * evfactl ! if(islimsk(i) == 1) evef=.07 -c if(islimsk(i) == 1) evef = 0. qcond(i) = evef * (q1(i,k) - qeso(i,k)) & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) dp = 1000. * del(i,k) diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index ff3c0d115..ca7cad4df 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -368,13 +368,22 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer intent = in optional = F +[hpbl] + standard_name = atmosphere_boundary_layer_thickness + long_name = PBL top height + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [ud_mf] standard_name = instantaneous_atmosphere_updraft_convective_mass_flux long_name = (updraft mass flux) * delt @@ -571,18 +580,9 @@ kind = kind_phys intent = in optional = F -[evfact] - standard_name = rain_evaporation_coefficient_deep_convection - long_name = convective rain evaporation coefficient for deep conv. - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[evfactl] - standard_name = rain_evaporation_coefficient_over_land_deep_convection - long_name = convective rain evaporation coefficient over land for deep conv. +[evef] + standard_name = rain_evaporation_coefficient_convection + long_name = convective rain evaporation coefficient for convection units = frac dimensions = () type = real diff --git a/physics/samfshalcnv.f b/physics/samfshalcnv.f index 1697cfe35..c314809cc 100644 --- a/physics/samfshalcnv.f +++ b/physics/samfshalcnv.f @@ -14,7 +14,7 @@ subroutine samfshalcnv_init(imfshalcnv, imfshalcnv_samf, & integer, intent(in) :: imfshalcnv integer, intent(in) :: imfshalcnv_samf - + ! CCPP error handling character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -25,7 +25,7 @@ subroutine samfshalcnv_init(imfshalcnv, imfshalcnv_samf, & & ' shallow convection is different from SAMF' errflg = 1 return - end if + end if end subroutine samfshalcnv_init subroutine samfshalcnv_finalize() @@ -61,7 +61,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav, & & rn,kbot,ktop,kcnv,islimsk,garea, & & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, & - & clam,c0s,c1,pgcon,asolfac,hwrf_samfshal,errmsg,errflg) + & clam,c0s,c1,evef,pgcon,asolfac,hwrf_samfshal,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -87,7 +87,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & cnvw(:,:), cnvc(:,:), ud_mf(:,:), dt_mf(:,:) ! real(kind=kind_phys), intent(in) :: clam, c0s, c1, & - & asolfac, pgcon + & asolfac, evef, pgcon logical, intent(in) :: hwrf_samfshal character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -108,8 +108,8 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & dz, dz1, e1, & el2orc, elocp, aafac, cm, & es, etah, h1, - & evef, evfact, evfactl, fact1, - & fact2, factor, dthk, +! & evfact, evfactl, + & fact1, fact2, factor, dthk, & gamma, pprime, betaw, & qlk, qrch, qs, & rfact, shear, tfac, @@ -120,30 +120,34 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & rho, tem, tem1, tem2, & ptem, ptem1 ! - integer kb(im), kbcon(im), kbcon1(im), + integer kb(im), kb1(im), kbcon(im), kbcon1(im), & ktcon(im), ktcon1(im), ktconn(im), & kbm(im), kmax(im) ! real(kind=kind_phys) aa1(im), cina(im), & tkemean(im), clamt(im), & ps(im), del(im,km), prsl(im,km), - & umean(im), tauadv(im), gdx(im), +! & umean(im), tauadv(im), gdx(im), + & gdx(im), & delhbar(im), delq(im), delq2(im), & delqbar(im), delqev(im), deltbar(im), - & deltv(im), dtconv(im), edt(im), +! & deltv(im), dtconv(im), edt(im), + & deltv(im), dtconv(im), & pdot(im), po(im,km), & qcond(im), qevap(im), hmax(im), - & rntot(im), vshear(im), +! & rntot(im), vshear(im), + & rntot(im), & xlamud(im), xmb(im), xmbmax(im), & delebar(im,ntr), & delubar(im), delvbar(im) ! - real(kind=kind_phys) c0(im) + real(kind=kind_phys) c0(im), sfcpbl(im) c - real(kind=kind_phys) crtlamd + real(kind=kind_phys) crtlame, crtlamd ! real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, - & cinacr, cinacrmx, cinacrmn + & cinacr, cinacrmx, cinacrmn, + & sfclfac, rhcrt ! ! parameters for updraft velocity calculation real(kind=kind_phys) bet1, cd1, f1, gam1, @@ -172,10 +176,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! 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.) + parameter(dthk=25.,sfclfac=0.2,rhcrt=0.75) parameter(cinpcrmx=180.,cinpcrmn=120.) parameter(cinacrmx=-120.) - parameter(crtlamd=3.e-4) parameter(dtmax=10800.,dtmin=600.) parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) parameter(betaw=.03,dxcrt=15.e3) @@ -194,6 +197,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & ! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), & dbyo(im,km), zo(im,km), xlamue(im,km), + & rh(im,km), & heo(im,km), heso(im,km), & dellah(im,km), dellaq(im,km), & dellae(im,km,ntr), @@ -203,6 +207,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & & eta(im,km), & zi(im,km), pwo(im,km), c0t(im,km), & sumx(im), tx1(im), cnvwt(im,km) + &, rhbar(im) ! logical do_aerosols, totflg, cnvflg(im), flg(im) ! @@ -255,6 +260,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & kbot(i)=km+1 ktop(i)=0 endif + sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. kbcon(i)=km ktcon(i)=1 @@ -262,11 +268,12 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & kb(i)=km pdot(i) = 0. qlko_ktcon(i) = 0. - edt(i) = 0. +! edt(i) = 0. aa1(i) = 0. cina(i) = 0. - vshear(i) = 0. +! vshear(i) = 0. gdx(i) = sqrt(garea(i)) + xmb(i) = 0. scaldfunc(i)=-1.0 ! wang initialized sigmagfm(i)=-1.0 enddo @@ -279,6 +286,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & kbot(i)=km+1 ktop(i)=0 endif + sfcpbl(i) = sfclfac * hpbl(i) rn(i)=0. kbcon(i)=km ktcon(i)=1 @@ -286,11 +294,12 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & kb(i)=km pdot(i) = 0. qlko_ktcon(i) = 0. - edt(i) = 0. +! edt(i) = 0.0 aa1(i) = 0. cina(i) = 0. - vshear(i) = 0. +! vshear(i) = 0. gdx(i) = sqrt(garea(i)) + xmb(i) = 0. enddo endif !! @@ -342,14 +351,12 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & dt2 = delt ! c model tunable parameters are all here - if (hwrf_samfshal) then - aafac = .1 - else - aafac = .05 - endif -c evef = 0.07 - evfact = 0.3 - evfactl = 0.3 + aafac = .1 +! evfact = 0.3 +! evfactl = 0.3 +! + crtlame = 1.0e-4 + crtlamd = 3.0e-4 ! w1l = -8.e-3 w2l = -4.e-2 @@ -437,6 +444,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if (cnvflg(i) .and. k <= kmax(i)) then pfld(i,k) = prsl(i,k) * 10.0 eta(i,k) = 1. + rh(i,k) = 0. hcko(i,k) = 0. qcko(i,k) = 0. qrcko(i,k)= 0. @@ -510,16 +518,34 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & c this is the level where updraft starts c !> ## Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!> - Find the index for a level of sfclfac*hpbl which is initial guess for the parcel starting level. + do i=1,im + flg(i) = cnvflg(i) + kb1(i) = 1 + enddo + do k = 1, km1 + do i=1,im + if (flg(i) .and. zo(i,k) <= sfcpbl(i)) then + kb1(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + kb1(i) = min(kb1(i),kpbl(i)) + enddo +c !> - Search in the PBL for the level of maximum moist static energy to start the ascending parcel. do i=1,im if (cnvflg(i)) then - hmax(i) = heo(i,1) - kb(i) = 1 + hmax(i) = heo(i,kb1(i)) + kb(i) = kb1(i) endif enddo do k = 2, km do i=1,im - if (cnvflg(i) .and. k <= kpbl(i)) then + if(cnvflg(i) .and. (k > kb1(i) .and. k <= kpbl(i))) then if(heo(i,k) > hmax(i)) then kb(i) = k hmax(i) = heo(i,k) @@ -561,6 +587,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & val2 = 1.e-10 qo(i,k) = max(qo(i,k), val2 ) ! qo(i,k) = min(qo(i,k),qeso(i,k)) + rh(i,k) = min(qo(i,k)/qeso(i,k), 1.) heo(i,k) = .5 * grav * (zo(i,k) + zo(i,k+1)) + & cp * to(i,k) + hvap * qo(i,k) heso(i,k) = .5 * grav * (zo(i,k) + zo(i,k+1)) + @@ -666,11 +693,95 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo if(totflg) return ! +! re-define kb & kbcon +! + do i=1,im + if (cnvflg(i)) then + hmax(i) = heo(i,1) + kb(i) = 1 + endif + enddo + do k = 2, km + do i=1,im + if (cnvflg(i) .and. k <= kpbl(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +! + do i=1,im + flg(i) = cnvflg(i) + if(flg(i)) kbcon(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +! + do i=1,im + if(cnvflg(i)) then + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +! +!> - if the mean relative humidity in the subcloud layers is less than a threshold value (rhcrt), convection is not triggered. +! + do i = 1, im + rhbar(i) = 0. + sumx(i) = 0. + enddo + do k = 1, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kb(i) .and. k < kbcon(i)) then + dz = zo(i,k+1) - zo(i,k) + rhbar(i) = rhbar(i) + rh(i,k) * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + rhbar(i) = rhbar(i) / sumx(i) + if(rhbar(i) < rhcrt) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! ! turbulent entrainment rate assumed to be proportional ! to subcloud mean TKE ! -! - !c !c specify the detrainment rate for the updrafts !c @@ -735,7 +846,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & do k = 1, km1 do i=1,im if(cnvflg(i)) then - xlamue(i,k) = clamt(i) / zi(i,k) + dz = zo(i,k+1) - zo(i,k) + xlamue(i,k) = clamt(i) / (zi(i,k) + dz) + xlamue(i,k) = max(xlamue(i,k), crtlame) endif enddo enddo @@ -1006,23 +1119,13 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & 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. - if(hwrf_samfshal) then - do i = 1, im + do i = 1, im if(cnvflg(i)) then k = kbcon(i) dp = 1000. * del(i,k) xmbmax(i) = dp / (grav * dt2) endif - enddo - else - do i = 1, im - if(cnvflg(i)) then - k = kbcon(i) - dp = 1000. * del(i,k) - xmbmax(i) = dp / (2. * grav * dt2) - endif - enddo - endif + enddo c c compute cloud moisture property and precipitation c @@ -1349,34 +1452,34 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & !! E = 1.591 - 0.639\frac{\Delta V}{\Delta z} + 0.0953\left(\frac{\Delta V}{\Delta z}\right)^2 - 0.00496\left(\frac{\Delta V}{\Delta z}\right)^3 !! \f] !! where \f$\Delta V\f$ is the integrated horizontal shear over the cloud depth, \f$\Delta z\f$, (the ratio is converted to units of \f$10^{-3} s^{-1}\f$). The variable "edt" is \f$1-E\f$ and is constrained to the range \f$[0,0.9]\f$. - do i = 1, im - if(cnvflg(i)) then - vshear(i) = 0. - endif - enddo - do k = 2, km - do i = 1, im - if (cnvflg(i)) then - if(k > kb(i) .and. k <= ktcon(i)) then - shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 - & + (vo(i,k)-vo(i,k-1)) ** 2) - vshear(i) = vshear(i) + shear - endif - endif - enddo - enddo - do i = 1, im - if(cnvflg(i)) then - vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) - e1=1.591-.639*vshear(i) - & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) - edt(i)=1.-e1 - val = .9 - edt(i) = min(edt(i),val) - val = .0 - edt(i) = max(edt(i),val) - endif - enddo +! do i = 1, im +! if(cnvflg(i)) then +! vshear(i) = 0. +! endif +! enddo +! do k = 2, km +! do i = 1, im +! if (cnvflg(i)) then +! if(k > kb(i) .and. k <= ktcon(i)) then +! shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 +! & + (vo(i,k)-vo(i,k-1)) ** 2) +! vshear(i) = vshear(i) + shear +! endif +! endif +! enddo +! enddo +! do i = 1, im +! if(cnvflg(i)) then +! vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) +! e1=1.591-.639*vshear(i) +! & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) +! edt(i)=1.-e1 +! val = .9 +! edt(i) = min(edt(i),val) +! val = .0 +! edt(i) = max(edt(i),val) +! endif +! enddo c c--- what would the change be, that a cloud with unit mass c--- will do to the environment? @@ -1521,31 +1624,31 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & enddo ! !> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. - do i= 1, im - if(cnvflg(i)) then - sumx(i) = 0. - umean(i) = 0. - endif - enddo - do k = 2, km1 - do i = 1, im - if(cnvflg(i)) then - if(k >= kbcon1(i) .and. k < ktcon1(i)) then - dz = zi(i,k) - zi(i,k-1) - tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) - umean(i) = umean(i) + tem * dz - sumx(i) = sumx(i) + dz - endif - endif - enddo - enddo - do i= 1, im - if(cnvflg(i)) then - umean(i) = umean(i) / sumx(i) - umean(i) = max(umean(i), 1.) - tauadv(i) = gdx(i) / umean(i) - endif - enddo +! do i= 1, im +! if(cnvflg(i)) then +! sumx(i) = 0. +! umean(i) = 0. +! endif +! enddo +! do k = 2, km1 +! do i = 1, im +! if(cnvflg(i)) then +! if(k >= kbcon1(i) .and. k < ktcon1(i)) then +! dz = zi(i,k) - zi(i,k-1) +! tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) +! umean(i) = umean(i) + tem * dz +! sumx(i) = sumx(i) + dz +! endif +! endif +! enddo +! enddo +! do i= 1, im +! if(cnvflg(i)) then +! umean(i) = umean(i) / sumx(i) +! umean(i) = max(umean(i), 1.) +! tauadv(i) = gdx(i) / umean(i) +! endif +! enddo c c compute cloud base mass flux as a function of the mean c updraft velcoity @@ -1556,9 +1659,10 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & if(cnvflg(i)) then k = kbcon(i) rho = po(i,k)*100. / (rd*to(i,k)) - tfac = tauadv(i) / dtconv(i) - tfac = min(tfac, 1.) - xmb(i) = tfac*betaw*rho*wc(i) +! tfac = tauadv(i) / dtconv(i) +! tfac = min(tfac, 1.) +! xmb(i) = tfac*betaw*rho*wc(i) + xmb(i) = betaw*rho*wc(i) endif enddo ! @@ -1722,10 +1826,9 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & endif endif if(flg(i) .and. k < ktcon(i)) then - evef = edt(i) * evfact - if(islimsk(i) == 1) evef=edt(i) * evfactl +! evef = edt(i) * evfact +! if(islimsk(i) == 1) evef=edt(i) * evfactl ! if(islimsk(i) == 1) evef=.07 -c if(islimsk(i) == 1) evef = 0. qcond(i) = evef * (q1(i,k) - qeso(i,k)) & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) dp = 1000. * del(i,k) diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index a454da3e7..8a346e75b 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -351,8 +351,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer @@ -430,6 +430,15 @@ kind = kind_phys intent = in optional = F +[evef] + standard_name = rain_evaporation_coefficient_convection + long_name = convective rain evaporation coefficient for convection + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F [pgcon] standard_name = momentum_transport_reduction_factor_pgf_shallow_convection long_name = reduction factor in momentum transport due to shal conv. induced pressure gradient force diff --git a/physics/sascnvn.meta b/physics/sascnvn.meta index af25b8477..89f2c6984 100644 --- a/physics/sascnvn.meta +++ b/physics/sascnvn.meta @@ -327,8 +327,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer diff --git a/physics/satmedmfvdif.meta b/physics/satmedmfvdif.meta index 40bc129bc..1ab70d937 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/satmedmfvdif.meta @@ -365,8 +365,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 @@ -374,7 +374,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index a165df5c7..4ac22e137 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -35,7 +35,7 @@ subroutine satmedmfvdifq_init (satmedmf, ! Consistency checks if (.not. satmedmf) then - write(errmsg,fmt='(*(a))') 'Logic error: satmedmf = .false.' + write(errmsg,fmt='(*(a))') 'Logic error: satmedmf = .false.' errflg = 1 return end if @@ -69,8 +69,8 @@ end subroutine satmedmfvdifq_finalize !! @{ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & - & dv,du,tdt,rtg,u1,v1,t1,q1,swh,hlw,xmu,garea,islimsk, & - & snwdph_lnd,psk,rbsoil,zorl,u10m,v10m,fm,fh, & + & 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, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku, & @@ -87,7 +87,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !---------------------------------------------------------------------- integer, intent(in) :: im, km, ntrac, ntcw, ntiw, ntke, ntoz,ntqv integer, intent(in) :: kinver(:) - integer, intent(in) :: islimsk(:) integer, intent(out) :: kpbl(:) logical, intent(in) :: gen_tend,ldiag3d ! @@ -102,7 +101,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & t1(:,:), q1(:,:,:), & & swh(:,:), hlw(:,:), & & xmu(:), garea(:), & - & snwdph_lnd(:), & + & zvfun(:), & & psk(:), rbsoil(:), & & zorl(:), tsea(:), & & u10m(:), v10m(:), & @@ -116,8 +115,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & integer, intent(in) :: dtidx(:,:), index_of_temperature, & & index_of_x_wind, index_of_y_wind, index_of_process_pbl real(kind=kind_phys), intent(out) :: & - & dusfc(:), dvsfc(:), & - & dtsfc(:), dqsfc(:), & + & dusfc(:), dvsfc(:), & + & dtsfc(:), dqsfc(:), & & hpbl(:) real(kind=kind_phys), intent(out) :: & & dkt(:,:), dku(:,:) @@ -151,7 +150,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & phih(im), phim(im), prn(im,km-1), & rbdn(im), rbup(im), thermal(im), & ustar(im), wstar(im), hpblx(im), - & ust3(im), wst3(im), + & ust3(im), wst3(im), rho_a(im), & z0(im), crb(im), & hgamt(im), hgamq(im), & wscale(im),vpert(im), @@ -168,7 +167,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & f1(im,km), f2(im,km*(ntrac-1)) ! real(kind=kind_phys) elm(im,km), ele(im,km), - & ckz(im,km), chz(im,km), frik(im), + & ckz(im,km), chz(im,km), & diss(im,km-1),prod(im,km-1), & bf(im,km-1), shr2(im,km-1), & xlamue(im,km-1), xlamde(im,km-1), @@ -195,7 +194,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & real(kind=kind_phys) aphi16, aphi5, & wfac, cfac, & gamcrt, gamcrq, sfcfrac, - & conq, cont, conw, +! & conq, cont, conw, & dsdz2, dsdzt, dkmax, & dsig, dt2, dtodsd, & dtodsu, g, factor, dz, @@ -212,50 +211,50 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & epsi, beta, chx, cqx, & rdt, rdz, qmin, qlmin, & rimin, rbcr, rbint, tdzmin, - & rlmn, rlmn1, rlmn2, + & rlmn, rlmn0, rlmn1, rlmn2, & rlmx, elmx, & ttend, utend, vtend, qtend, & zfac, zfmin, vk, spdk2, - & tkmin, tkminx, xkzinv, xkgdx, - & zlup, zldn, bsum, - & tem, tem1, tem2, + & tkmin, tkbmx, xkgdx, + & xkinv1, xkinv2, + & zlup, zldn, bsum, cs0, + & tem, tem1, tem2, tem3, & ptem, ptem0, ptem1, ptem2 -! - real(kind=kind_phys) xkzm_mp, xkzm_hp ! real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck ! - real(kind=kind_phys) qlcr, zstblmax + real(kind=kind_phys) qlcr, zstblmax, hcrinv ! real(kind=kind_phys) h1 !! - parameter(wfac=7.0,cfac=3.0) + parameter(wfac=7.0,cfac=4.5) parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) parameter(vk=0.4,rimin=-100.) parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) - parameter(rlmn=30.,rlmn1=5.,rlmn2=10.) + parameter(rlmn=30.,rlmn0=5.,rlmn1=5.,rlmn2=10.) parameter(rlmx=300.,elmx=300.) parameter(prmin=0.25,prmax=4.0) parameter(pr0=1.0,prtke=1.0,prscu=0.67) parameter(f0=1.e-4,crbmin=0.15,crbmax=0.35) - parameter(tkmin=1.e-9,tkminx=0.2,dspmax=10.0) + parameter(tkmin=1.e-9,tkbmx=0.2,dspmax=10.0) parameter(qmin=1.e-8,qlmin=1.e-12,zfmin=1.e-8) parameter(aphi5=5.,aphi16=16.) parameter(elmfac=1.0,elefac=1.0,cql=100.) - parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=5000.) - parameter(qlcr=3.5e-5,zstblmax=2500.,xkzinv=0.1) - parameter(h1=0.33333333) + parameter(dw2min=1.e-4,dkmax=1000.,xkgdx=3000.) + parameter(qlcr=3.5e-5,zstblmax=2500.) + parameter(xkinv1=0.15,xkinv2=0.3) + parameter(h1=0.33333333,hcrinv=250.) parameter(ck0=0.4,ck1=0.15,ch0=0.4,ch1=0.15) - parameter(ce0=0.4) + parameter(ce0=0.4,cs0=0.2) parameter(rchck=1.5,ndt=20) gravi=1.0/grav g=grav gocp=g/cp - cont=cp/g - conq=hvap/g - conw=1.0/g ! for del in pa -! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) !kpa +! cont=cp/g +! conq=hvap/g +! conw=1.0/g ! for del in pa +!! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) !kpa elocp=hvap/cp el2orc=hvap*hvap/(rv*cp) ! @@ -287,12 +286,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & buod(i,k) = 0. ckz(i,k) = ck1 chz(i,k) = ch1 - rlmnz(i,k) = rlmn + rlmnz(i,k) = rlmn0 enddo enddo - do i=1,im - frik(i) = 1.0 - enddo do i=1,im zi(i,km+1) = phii(i,km+1) * gravi enddo @@ -331,41 +327,22 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !> - Compute background vertical diffusivities for scalars and momentum (xkzo and xkzmo) -!> - set background diffusivities as a function of -!! horizontal grid size with xkzm_h & xkzm_m for gdx >= 25km -!! and 0.01 for gdx=5m, i.e., -!! \n xkzm_hx = 0.01 + (xkzm_h - 0.01)/(xkgdx-5.) * (gdx-5.) -!! \n xkzm_mx = 0.01 + (xkzm_h - 0.01)/(xkgdx-5.) * (gdx-5.) - - do i=1,im - xkzm_mp = xkzm_m - xkzm_hp = xkzm_h -! - if( islimsk(i) == 1 .and. snwdph_lnd(i) > 10.0 ) then ! over land - if (rbsoil(i) > 0. .and. rbsoil(i) <= 0.25) then - xkzm_mp = xkzm_m * (1.0 - rbsoil(i)/0.25)**2 + - & 0.1 * (1.0 - (1.0-rbsoil(i)/0.25)**2) - xkzm_hp = xkzm_h * (1.0 - rbsoil(i)/0.25)**2 + - & 0.1 * (1.0 - (1.0-rbsoil(i)/0.25)**2) - else if (rbsoil(i) > 0.25) then - xkzm_mp = 0.1 - xkzm_hp = 0.1 - endif - endif +!> - set background diffusivities with xkzm_h & xkzm_m for gdx >= xkgdx and +!! as a function of horizontal grid size for gdx < xkgdx +!! \n xkzm_hx = xkzm_h * (gdx / xkgdx) +!! \n xkzm_mx = xkzm_m * (gdx / xkgdx) ! + do i=1,im kx1(i) = 1 tx1(i) = 1.0 / prsi(i,1) tx2(i) = tx1(i) if(gdx(i) >= xkgdx) then - xkzm_hx(i) = xkzm_hp - xkzm_mx(i) = xkzm_mp + xkzm_hx(i) = xkzm_h + xkzm_mx(i) = xkzm_m else - tem = 1. / (xkgdx - 5.) - tem1 = (xkzm_hp - 0.01) * tem - tem2 = (xkzm_mp - 0.01) * tem - ptem = gdx(i) - 5. - xkzm_hx(i) = 0.01 + tem1 * ptem - xkzm_mx(i) = 0.01 + tem2 * ptem + tem = gdx(i) / xkgdx + xkzm_hx(i) = xkzm_h * tem + xkzm_mx(i) = xkzm_m * tem endif enddo do k = 1,km1 @@ -374,19 +351,18 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & xkzmo(i,k) = 0.0 if (k < kinver(i)) then ! minimum turbulent mixing length - ptem = prsl(i,k) * tx1(i) + ptem = prsi(i,k+1) * tx1(i) tem1 = 1.0 - ptem tem2 = tem1 * tem1 * 2.5 tem2 = min(1.0, exp(-tem2)) rlmnz(i,k)= rlmn * tem2 - rlmnz(i,k)= max(rlmnz(i,k), rlmn1) + rlmnz(i,k)= max(rlmnz(i,k), rlmn0) ! vertical background diffusivity - ptem = prsi(i,k+1) * tx1(i) - tem1 = 1.0 - ptem tem2 = tem1 * tem1 * 10.0 tem2 = min(1.0, exp(-tem2)) xkzo(i,k) = xkzm_hx(i) * tem2 -! vertical background diffusivity for momentum +! vertical background diffusivity for +! momentum if (ptem >= xkzm_s) then xkzmo(i,k) = xkzm_mx(i) kx1(i) = k + 1 @@ -399,10 +375,11 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & endif enddo enddo - +! !> - Some output variables and logical flags are initialized do i = 1,im z0(i) = 0.01 * zorl(i) + rho_a(i) = prsl(i,1)/(rd*t1(i,1)*(1.+fv*max(q1(i,1,1),qmin))) dusfc(i) = 0. dvsfc(i) = 0. dtsfc(i) = 0. @@ -710,10 +687,54 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & hgamq(i) = evap(i)/wscale(i) vpert(i) = hgamt(i) + hgamq(i)*fv*theta(i,1) vpert(i) = max(vpert(i),0.) - vpert(i) = min(cfac*vpert(i),gamcrt) + tem = min(cfac*vpert(i),gamcrt) + thermal(i)= thermal(i) + tem endif enddo ! +! enhance the pbl height by considering the thermal excess +! (overshoot pbl top) +! + do i=1,im + flg(i) = .true. + if(pcnvflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(pcnvflg(i)) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) then + kpbl(i) = kpbl(i) - 1 + endif + if(kpbl(i) <= 1) then + pcnvflg(i) = .false. + pblflg(i) = .false. + endif + endif + enddo +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! look for stratocumulus !> ## Determine whether stratocumulus layers exist and compute quantities @@ -848,38 +869,43 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & enddo enddo ! -! background diffusivity decreasing with increasing surface layer stability -! -! do i = 1, im -! if(.not.sfcflg(i)) then -! tem = (1. + 5. * rbsoil(i))**2. -!! tem = (1. + 5. * zol(i))**2. -! frik(i) = 0.1 + 0.9 / tem -! endif -! enddo +! Above a threshold height (hcrinv), the background vertical +! diffusivities & mixing length +! in the inversion layers are set to much smaller values (xkinv1 & +! rlmn1) ! -! do k = 1,km1 -! do i=1,im -! xkzo(i,k) = frik(i) * xkzo(i,k) -! xkzmo(i,k)= frik(i) * xkzmo(i,k) -! enddo -! enddo -! -!> ## The background vertical diffusivities in the inversion layers are limited -!! to be less than or equal to xkzinv +! Below the threshold height (hcrinv), the background vertical +! diffusivities & mixing length +! in the inversion layers are increased with increasing roughness +! length & vegetation fraction ! do k = 1,km1 do i=1,im -! tem1 = (tvx(i,k+1)-tvx(i,k)) * rdzt(i,k) -! if(tem1 > 1.e-5) then - tem1 = tvx(i,k+1)-tvx(i,k) - if(tem1 > 0. .and. islimsk(i) /= 1) then - xkzo(i,k) = min(xkzo(i,k), xkzinv) - xkzmo(i,k) = min(xkzmo(i,k), xkzinv) - rlmnz(i,k) = min(rlmnz(i,k), rlmn2) + if(zi(i,k+1) > hcrinv) then + tem1 = tvx(i,k+1)-tvx(i,k) + if(tem1 >= 0.) then + xkzo(i,k) = min(xkzo(i,k), xkinv1) + xkzmo(i,k) = min(xkzmo(i,k), xkinv1) + rlmnz(i,k) = min(rlmnz(i,k), rlmn1) + endif + else + tem1 = tvx(i,k+1)-tvx(i,k) + if(tem1 > 0.) then + ptem = xkzo(i,k) * zvfun(i) + xkzo(i,k) = min(max(ptem, xkinv2), xkzo(i,k)) + ptem = xkzmo(i,k) * zvfun(i) + xkzmo(i,k) = min(max(ptem, xkinv2), xkzmo(i,k)) + ptem = rlmnz(i,k) * zvfun(i) + rlmnz(i,k) = min(max(ptem, rlmn2), rlmnz(i,k)) + endif endif enddo enddo + do k = 2,km1 + do i=1,im + rlmnz(i,k) = 0.5 * (rlmnz(i,k-1) + rlmnz(i,k)) + enddo + enddo ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> ## Compute an asymtotic mixing length @@ -892,8 +918,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & do n = k, km1 if(mlenflg) then dz = zl(i,n+1) - zl(i,n) - ptem = gotvx(i,n)*(thvx(i,n+1)-thvx(i,k))*dz -! ptem = gotvx(i,n)*(thlvx(i,n+1)-thlvx(i,k))*dz +! 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)) + 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 bsum = bsum + ptem zlup = zlup + dz if(bsum >= tke(i,k)) then @@ -917,13 +950,23 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & 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)) else dz = zl(i,n) - zl(i,n-1) 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)) + 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)) endif - ptem = gotvx(i,n)*(thvx(i,k)-tem1)*dz -! ptem = gotvx(i,n)*(thlvx(i,k)-tem1)*dz + 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 @@ -954,6 +997,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & !! where \f$l_{up}\f$ and \f$l_{down}\f$ are the distances that a parcel !! having an initial TKE can travel upward and downward before being stopped !! by buoyancy effects. +! +! Following Rodier et. al (2017), environmental wind shear effect on +! mixing length was included. +! ptem2 = min(zlup,zldn) rlam(i,k) = elmfac * ptem2 rlam(i,k) = max(rlam(i,k), tem1) @@ -1063,7 +1110,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & endif ptem = tem1 / (tem * elm(i,k)) tkmnz(i,k) = ptem * ptem - tkmnz(i,k) = min(tkmnz(i,k), tkminx) + tkmnz(i,k) = min(tkmnz(i,k), tkbmx) tkmnz(i,k) = max(tkmnz(i,k), tkmin) enddo enddo @@ -1439,10 +1486,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & qtend = (f2(i,k)-q1(i,k,1))*rdt tdt(i,k) = tdt(i,k)+ttend rtg(i,k,1) = rtg(i,k,1)+qtend - dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend - dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend +! dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend +! 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) + enddo +! if(ldiag3d .and. .not. gen_tend) then idtend=dtidx(index_of_temperature,index_of_process_pbl) if(idtend>=1) then @@ -1575,7 +1627,6 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & ! enddo enddo - c !> - Call tridi2() to solve tridiagonal problem for momentum c @@ -1589,10 +1640,15 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & vtend = (f2(i,k)-v1(i,k))*rdt du(i,k) = du(i,k)+utend dv(i,k) = dv(i,k)+vtend - dusfc(i) = dusfc(i)+conw*del(i,k)*utend - dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend +! dusfc(i) = dusfc(i)+conw*del(i,k)*utend +! dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend enddo enddo + do i = 1,im + dusfc(i) = -1.*rho_a(i)*stress(i)*u1(i,1)/spd1(i) + dvsfc(i) = -1.*rho_a(i)*stress(i)*v1(i,1)/spd1(i) + enddo +! if(ldiag3d .and. .not. gen_tend) then idtend=dtidx(index_of_x_wind,index_of_process_pbl) if(idtend>=1) then diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index e0a5dba26..e4dddccf0 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -290,18 +290,10 @@ kind = kind_phys intent = in optional = F -[islimsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_loop_extent) - type = integer - intent = in - optional = F -[snwdph_lnd] - standard_name = surface_snow_thickness_water_equivalent_over_land - long_name = water equivalent snow depth over land - units = mm +[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 @@ -380,8 +372,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 @@ -389,7 +381,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index bff171f4b..0941b1144 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -62,7 +62,7 @@ end subroutine sfc_diff_finalize !! - Calculate the exchange coefficients:\f$cm\f$, \f$ch\f$, and \f$stress\f$ as inputs of other \a sfc schemes. !! subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) - & ps,t1,q1,z1,wind, & !intent(in) + & ps,t1,q1,z1,garea,wind, & !intent(in) & prsl1,prslki,prsik1,prslk1, & !intent(in) & sigmaf,vegtype,shdmax,ivegsrc, & !intent(in) & z0pert,ztpert, & ! mg, sfc-perts !intent(in) @@ -72,9 +72,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & thsfc_loc, & !intent(in) & tskin_wat, tskin_lnd, tskin_ice, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) - & snwdph_wat,snwdph_lnd,snwdph_ice, & !intent(in) - & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) - & z0rl_wav, & !intent(inout) + & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) + & z0rl_wav, & !intent(inout) & ustar_wat, ustar_lnd, ustar_ice, & !intent(inout) & cm_wat, cm_lnd, cm_ice, & !intent(inout) & ch_wat, ch_lnd, ch_ice, & !intent(inout) @@ -85,6 +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) & errmsg, errflg) !intent(out) ! implicit none @@ -103,13 +103,12 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) real(kind=kind_phys), dimension(:), intent(in) :: u10m,v10m real(kind=kind_phys), intent(in) :: rvrdm1, eps, epsm1, grav real(kind=kind_phys), dimension(:), intent(in) :: & - & ps,t1,q1,z1,prsl1,prslki,prsik1,prslk1, & + & ps,t1,q1,z1,garea,prsl1,prslki,prsik1,prslk1, & & wind,sigmaf,shdmax, & & z0pert,ztpert ! mg, sfc-perts real(kind=kind_phys), dimension(:), intent(in) :: & & tskin_wat, tskin_lnd, tskin_ice, & - & tsurf_wat, tsurf_lnd, tsurf_ice, & - & snwdph_wat,snwdph_lnd,snwdph_ice + & tsurf_wat, tsurf_lnd, tsurf_ice real(kind=kind_phys), dimension(:), intent(in) :: z0rl_wav real(kind=kind_phys), dimension(:), intent(inout) :: & @@ -124,6 +123,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & fm10_wat, fm10_lnd, fm10_ice, & & fh2_wat, fh2_lnd, fh2_ice, & & ztmax_wat, ztmax_lnd, ztmax_ice + real(kind=kind_phys), dimension(:), intent(out) :: zvfun ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -132,17 +132,17 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! integer i ! - real(kind=kind_phys) :: rat, thv1, restar, wind10m, + real(kind=kind_phys) :: rat, tv1, thv1, restar, wind10m, & czilc, tem1, tem2, virtfac ! - real(kind=kind_phys) :: tv1 - - real(kind=kind_phys) :: tvs, z0, z0max + real(kind=kind_phys) :: tvs, z0, z0max, ztmax, gdx +! + real(kind=kind_phys), parameter :: z0lo=0.1, z0up=1.0 ! real(kind=kind_phys), parameter :: & one=1.0_kp, zero=0.0_kp, half=0.5_kp, qmin=1.0e-8_kp - &, charnock=.014_kp, z0s_max=.317e-2_kp &! a limiting value at high winds over sea + &, charnock=.018_kp, z0s_max=.317e-2_kp &! a limiting value at high winds over sea &, zmin=1.0e-6_kp & &, vis=1.4e-5_kp, rnu=1.51e-5_kp, visi=one/vis & &, log01=log(0.01_kp), log05=log(0.05_kp), log07=log(0.07_kp) @@ -191,6 +191,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) thv1 = t1(i) / prslk1(i) * virtfac endif + zvfun(i) = zero + gdx = sqrt(garea(i)) + ! compute stability dependent exchange coefficients ! this portion of the code is presently suppressed ! @@ -249,24 +252,37 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = max(z0max, zmin) -! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil - czilc = 0.8_kp - - tem1 = 1.0_kp - sigmaf(i) - ztmax_lnd(i) = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) - - +!! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil +! czilc = 0.8_kp +! +! tem1 = 1.0_kp - sigmaf(i) +! ztmax_lnd(i) = z0max*exp( - tem1*tem1 +! & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) +! + czilc = 10.0_kp ** (- 4.0_kp * z0max) ! Trier et al. (2011,WAF) + czilc = max(min(czilc, 0.8_kp), 0.08_kp) + tem1 = 1.0_kp - sigmaf(i) + czilc = czilc * tem1 * tem1 + ztmax_lnd(i) = z0max * exp( - czilc * ca + & * 258.2_kp * sqrt(ustar_lnd(i)*z0max) ) +! ! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land if (ztpert(i) /= zero) then ztmax_lnd(i) = ztmax_lnd(i) * (10.0_kp**ztpert(i)) endif ztmax_lnd(i) = max(ztmax_lnd(i), zmin) +! +! compute a function of surface roughness & green vegetation fraction (zvfun) +! + tem1 = (z0max - z0lo) / (z0up - z0lo) + tem1 = min(max(tem1, zero), 1.0_kp) + tem2 = max(sigmaf(i), 0.1_kp) + zvfun(i) = sqrt(tem1 * tem2) ! call stability ! --- inputs: - & (z1(i), snwdph_lnd(i), thv1, wind(i), - & z0max, ztmax_lnd(i), tvs, grav, tv1, thsfc_loc, + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & z0max, ztmax_lnd(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_lnd(i), fm_lnd(i), fh_lnd(i), fm10_lnd(i), fh2_lnd(i), & cm_lnd(i), ch_lnd(i), stress_lnd(i), ustar_lnd(i)) @@ -274,6 +290,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) if (icy(i)) then ! Some ice + zvfun(i) = zero + if(thsfc_loc) then ! Use local potential temperature tvs = half * (tsurf_ice(i)+tskin_ice(i)) * virtfac else ! Use potential temperature referenced to 1000 hPa @@ -296,19 +314,27 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = max(z0max, zmin) -! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height +!! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height ! dependance of czil - czilc = 0.8_kp - - tem1 = 1.0_kp - sigmaf(i) - ztmax_ice(i) = z0max*exp( - tem1*tem1 - & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) +! czilc = 0.8_kp +! +! tem1 = 1.0_kp - sigmaf(i) +! ztmax_ice(i) = z0max*exp( - tem1*tem1 +! & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) +! + czilc = 10.0_kp ** (- 4.0_kp * z0max) + czilc = max(min(czilc, 0.8_kp), 0.08_kp) + tem1 = 1.0_kp - sigmaf(i) + czilc = czilc * tem1 * tem1 + ztmax_ice(i) = z0max * exp( - czilc * ca + & * 258.2_kp * sqrt(ustar_ice(i)*z0max) ) +! ztmax_ice(i) = max(ztmax_ice(i), 1.0e-6) ! call stability ! --- inputs: - & (z1(i), snwdph_ice(i), thv1, wind(i), - & z0max, ztmax_ice(i), tvs, grav, tv1, thsfc_loc, + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & z0max, ztmax_ice(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_ice(i), fm_ice(i), fh_ice(i), fm10_ice(i), fh2_ice(i), & cm_ice(i), ch_ice(i), stress_ice(i), ustar_ice(i)) @@ -318,6 +344,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! the stuff now put into "stability" if (wet(i)) then ! Some open ocean + + zvfun(i) = zero if(thsfc_loc) then ! Use local potential temperature tvs = half * (tsurf_wat(i)+tskin_wat(i)) * virtfac @@ -328,7 +356,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0 = 0.01_kp * z0rl_wat(i) z0max = max(zmin, min(z0,z1(i))) - ustar_wat(i) = sqrt(grav * z0 / charnock) +! ustar_wat(i) = sqrt(grav * z0 / charnock) wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) !** test xubin's new z0 @@ -358,8 +386,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! call stability ! --- inputs: - & (z1(i), snwdph_wat(i), thv1, wind(i), - & z0max, ztmax_wat(i), tvs, grav, tv1, thsfc_loc, + & (z1(i), zvfun(i), gdx, tv1, thv1, wind(i), + & z0max, ztmax_wat(i), tvs, grav, thsfc_loc, ! --- outputs: & rb_wat(i), fm_wat(i), fh_wat(i), fm10_wat(i), fh2_wat(i), & cm_wat(i), ch_wat(i), stress_wat(i), ustar_wat(i)) @@ -368,7 +396,10 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! if (sfc_z0_type >= 0) then if (sfc_z0_type == 0) then - z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) +! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + tem1 = 0.11 * vis / ustar_wat(i) + z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) + ! mbek -- toga-coare flux algorithm ! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) @@ -396,7 +427,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) endif elseif (z0rl_wav(i) <= 1.0e-7_kp) then - z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) +! z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + tem1 = 0.11 * vis / ustar_wat(i) + z0 = tem1 + (charnock/grav)*ustar_wat(i)*ustar_wat(i) if (redrag) then z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) @@ -418,8 +451,8 @@ end subroutine sfc_diff_run !>\ingroup GFS_diff_main subroutine stability & ! --- inputs: - & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav, & - & tv1, thsfc_loc, & + & ( z1, zvfun, gdx, tv1, thv1, wind, z0max, ztmax, tvs, grav, & + & thsfc_loc, & ! --- outputs: & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) !----- @@ -427,8 +460,7 @@ subroutine stability & integer, parameter :: kp = kind_phys ! --- inputs: real(kind=kind_phys), intent(in) :: & - & z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav - real(kind=kind_phys), intent(in) :: tv1 + & z1, zvfun, gdx, tv1, thv1, wind, z0max, ztmax, tvs, grav logical, intent(in) :: thsfc_loc ! --- outputs: @@ -438,27 +470,41 @@ subroutine stability & ! --- locals: real(kind=kind_phys), parameter :: alpha=5.0_kp, a0=-3.975_kp & &, a1=12.32_kp, alpha4=4.0_kp*alpha & - &, b1=-7.755_kp, b2=6.041_kp, alpha2=alpha+alpha & - &, beta=1.0_kp & + &, b1=-7.755_kp, b2=6.041_kp & + &, xkrefsqr=0.3_kp, xkmin=0.05_kp & + &, xkgdx=3000.0_kp & &, a0p=-7.941_kp, a1p=24.75_kp, b1p=-8.705_kp, b2p=7.899_kp& - &, ztmin1=-999.0_kp, zero=0.0_kp, one=1.0_kp + &, zolmin=-10.0_kp, zero=0.0_kp, one=1.0_kp real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, & hl1, hl12, pm, ph, pm10, ph2, & z1i, & fms, fhs, hl0, hl0inf, hlinf, & hl110, hlt, hltinf, olinf, - & tem1, tem2, ztmax1 + & tem1, tem2, zolmax + + real(kind=kind_phys) xkzo z1i = one / z1 - tem1 = z0max/z1 - if (abs(one-tem1) > 1.0e-6_kp) then - ztmax1 = - beta*log(tem1)/(alpha2*(one-tem1)) +! +! 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 - ztmax1 = 99.0_kp + xkzo = gdx / xkgdx endif - if( z0max < 0.05_kp .and. snwdph < 10.0_kp ) ztmax1 = 99.0_kp + + tem1 = tv1 - tvs + if(tem1 > zero) then + tem2 = xkzo * zvfun + xkzo = min(max(tem2, xkmin), xkzo) + endif + + zolmax = xkrefsqr / sqrt(xkzo) ! compute stability indices (rb and hlinf) @@ -481,7 +527,7 @@ subroutine stability & fm10 = log((z0max+10.0_kp) * tem1) fh2 = log((ztmax+2.0_kp) * tem2) hlinf = rb * fm * fm / fh - hlinf = min(max(hlinf,ztmin1),ztmax1) + hlinf = min(max(hlinf,zolmin),zolmax) ! ! stable case ! @@ -500,7 +546,7 @@ subroutine stability & fms = fm - pm fhs = fh - ph hl1 = fms * fms * rb / fhs - hl1 = min(max(hl1, ztmin1), ztmax1) + hl1 = min(hl1, zolmax) endif ! ! second iteration @@ -515,11 +561,9 @@ subroutine stability & pm = aa0 - aa + log( (one+aa)/(one+aa0) ) ph = bb0 - bb + log( (one+bb)/(one+bb0) ) hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) aa = sqrt(one + alpha4 * hl110) pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12,ztmin1),ztmax1) ! aa = sqrt(one + alpha4 * hl12) bb = sqrt(one + alpha4 * hl12) ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) @@ -531,7 +575,7 @@ subroutine stability & tem1 = 50.0_kp * z0max if(abs(olinf) <= tem1) then hlinf = -z1 / tem1 - hlinf = min(max(hlinf,ztmin1),ztmax1) + hlinf = max(hlinf, zolmin) endif ! ! get pm and ph @@ -541,10 +585,8 @@ subroutine stability & pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12, ztmin1), ztmax1) ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) else ! hlinf < 0.05 hl1 = -hlinf @@ -554,11 +596,9 @@ subroutine stability & ! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 ! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 hl110 = hl1 * 10.0_kp * z1i - hl110 = min(max(hl110, ztmin1), ztmax1) pm10 = log(hl110) + 2.0_kp/sqrt(sqrt(hl110)) - 0.8776_kp ! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 hl12 = (hl1+hl1) * z1i - hl12 = min(max(hl12, ztmin1), ztmax1) ph2 = log(hl12) + 0.5_kp / sqrt(hl12) + 1.386_kp ! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 endif diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index 7b639b6b0..f079b4357 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -87,6 +87,24 @@ kind = kind_phys intent = in optional = F +[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 + optional = F +[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 = out + optional = F [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level @@ -312,33 +330,6 @@ kind = kind_phys intent = in optional = F -[snwdph_wat] - standard_name = surface_snow_thickness_water_equivalent_over_water - long_name = water equivalent snow depth over water - units = mm - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F -[snwdph_lnd] - 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 - optional = F -[snwdph_ice] - 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 = in - optional = F [z0rl_wat] standard_name = surface_roughness_length_over_water long_name = surface roughness length over water (temporary use as interstitial) diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index d50a8505e..2ecb26469 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -569,8 +569,7 @@ subroutine lsm_noah_run & snwdph(i) = snowh * 1000.0_kind_phys weasd(i) = sneqv * 1000.0_kind_phys sncovr1(i) = sncovr -! ---- ... outside sflx, roughness uses cm as unit (update after snow's -! effect) +! ---- ... outside sflx, roughness uses cm as unit (update after snow's effect) zorl(i) = z0*100.0_kind_phys !> - Do not return the following output fields to parent model: diff --git a/physics/sfc_drv_ruc.F90 b/physics/sfc_drv_ruc.F90 index f313f2fba..f20b51141 100644 --- a/physics/sfc_drv_ruc.F90 +++ b/physics/sfc_drv_ruc.F90 @@ -99,7 +99,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & ! --- 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(out) :: tsice + 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 @@ -221,16 +221,17 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & enddo ! i - call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) + call init_soil_depth_3 ( zs , dzs , lsoil_ruc ) - call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in - me, master, lsm_ruc, lsm, slmsk, & ! in - soiltyp, vegtype, & ! in - tsfc_lnd, tsfc_wat, tg3, & ! in - zs, dzs, smc, slc, stc, & ! in - sh2o, smfrkeep, tslb, smois, & ! out - wetness, errmsg, errflg) + call rucinit (flag_restart, im, lsoil_ruc, lsoil, nlev, & ! in + me, master, lsm_ruc, lsm, slmsk, & ! in + soiltyp, vegtype, & ! in + tsfc_lnd, tsfc_wat, tg3, & ! in + zs, dzs, smc, slc, stc, & ! in + sh2o, smfrkeep, tslb, smois, & ! out + wetness, errmsg, errflg) + if (.not.flag_restart) then do i = 1, im ! i - horizontal loop do k = 1, min(kice,lsoil_ruc) ! - at initial time set sea ice T (tsice) @@ -238,6 +239,7 @@ subroutine lsm_ruc_init (me, master, isot, ivegsrc, nlunit, & tsice (i,k) = tslb(i,k) enddo enddo ! i + endif ! .not. restart !-- end of initialization diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 7a7fc5075..cf37670fe 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -531,7 +531,7 @@ dimensions = (horizontal_dimension,ice_vertical_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = F [pores] standard_name = maximum_soil_moisture_content_for_land_surface_model @@ -845,8 +845,8 @@ intent = in optional = F [lake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 967fd1c0a..9258b5256 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -28,6 +28,7 @@ end subroutine sfc_nst_finalize 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, & & sinlat, stress, & & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & @@ -47,6 +48,7 @@ subroutine sfc_nst_run & ! call sfc_nst ! ! inputs: ! ! ( im, ps, u1, v1, t1, q1, tref, cm, ch, ! +! lseaspray, fm, fm10, ! ! prsl1, prslki, wet, use_flake, xlon, sinlat, stress, ! ! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! ! wind, flag_iter, flag_guess, nstf_name1, nstf_name4, ! @@ -89,12 +91,16 @@ subroutine sfc_nst_run & ! tref - real, reference/foundation temperature ( k ) im ! ! cm - real, surface exchange coeff for momentum (m/s) im ! ! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! lseaspray- logical, .t. for parameterization for sea spray 1 ! +! fm - real, a stability profile function for momentum im ! +! fm10 - real, a stability profile function for momentum im ! +! at 10m ! ! prsl1 - real, surface layer mean pressure (pa) im ! ! prslki - real, im ! ! prsik1 - real, im ! ! prslk1 - real, im ! ! wet - logical, =T if any ocn/lake water (F otherwise) im ! -! use_flake - logical, =T if any lake otherwise ocn +! use_flake- 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 ! @@ -190,12 +196,15 @@ subroutine sfc_nst_run & real (kind=kind_phys), intent(in) :: hvap, cp, hfus, jcal, eps, & & epsm1, rvrdm1, rd, rhw0, sbc, pi, tgice real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & - & t1, q1, tref, cm, ch, prsl1, prslki, prsik1, prslk1, & - & xlon,xcosz, & + & t1, q1, tref, cm, ch, fm, fm10, & + & prsl1, prslki, prsik1, prslk1, xlon, xcosz, & & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, wind real (kind=kind_phys), intent(in) :: timestep real (kind=kind_phys), intent(in) :: solhr +! For sea spray effect + logical, intent(in) :: lseaspray +! logical, dimension(:), intent(in) :: flag_iter, flag_guess, wet, & & use_flake ! &, icy @@ -244,15 +253,30 @@ subroutine sfc_nst_run & real(kind=kind_phys) fw,q_warm real(kind=kind_phys) t12,alon,tsea,sstc,dta,dtz real(kind=kind_phys) zsea1,zsea2,soltim + logical do_nst ! external functions called: iw3jdn integer :: iw3jdn +! +! parameters for sea spray effect +! + real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, + & bb1, hflxs, evaps, ptem +! +! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1, +! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0, +! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, + real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, + & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 +! !====================================================================================================== cc ! Initialize CCPP error handling variables errmsg = '' errflg = 0 + if (nstf_name1 == 0) return ! No NSST model used + cpinv = one/cp hvapi = one/hvap elocp = hvap/cp @@ -261,10 +285,13 @@ subroutine sfc_nst_run & ! ! flag for open water and where the iteration is on ! + 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) + do_nst = do_nst .or. flag(i) enddo + if (.not. do_nst) return ! ! save nst-related prognostic fields for guess run ! @@ -636,7 +663,33 @@ subroutine sfc_nst_run & endif enddo endif ! if ( nstf_name1 > 1 ) then - +! +! include sea spray effects +! + do i=1,im + if(lseaspray .and. flag(i)) then + f10m = fm10(i) / fm(i) + u10m = f10m * u1(i) + v10m = f10m * v1(i) + ws10 = sqrt(u10m*u10m + v10m*v10m) + ws10 = max(ws10,1.) + ws10 = min(ws10,ws10cr) + tem = .015 * ws10 * ws10 + ru10 = 1. - .087 * log(10./tem) + qss1 = fpvs(t1(i)) + qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1) + tem = rd * cp * t1(i) * t1(i) + tem = 1. + eps * hvap * hvap * qss1 / tem + bb1 = 1. / tem + evaps = conlf * (ws10**5.4) * ru10 * bb1 + evaps = evaps * rho_a(i) * hvap * (qss1 - q0(i)) + evap(i) = evap(i) + alps * evaps + hflxs = consf * (ws10**3.4) * ru10 + hflxs = hflxs * rho_a(i) * cp * (tskin(i) - t1(i)) + ptem = alps - gams + hflx(i) = hflx(i) + bets * hflxs - ptem * evaps + endif + enddo ! do i=1,im if ( flag(i) ) then @@ -677,7 +730,7 @@ end subroutine sfc_nst_pre_finalize !> \section NSST_general_pre_algorithm General Algorithm !! @{ subroutine sfc_nst_pre_run - & (im, wet, use_flake, tgice, tsfco, tsfc_wat, tsurf_wat, + & (im, wet, tgice, tsfco, tsurf_wat, & tseal, xt, xz, dt_cool, z_c, tref, cplflx, & oceanfrac, nthreads, errmsg, errflg) @@ -690,11 +743,10 @@ subroutine sfc_nst_pre_run ! --- inputs: integer, intent(in) :: im, nthreads - logical, dimension(:), intent(in) :: wet, use_flake + logical, dimension(:), intent(in) :: wet real (kind=kind_phys), intent(in) :: tgice real (kind=kind_phys), dimension(:), intent(in) :: - & tsfc_wat, xt, xz, dt_cool, z_c, oceanfrac, - & tsfco + & tsfco, xt, xz, dt_cool, z_c, oceanfrac logical, intent(in) :: cplflx ! --- input/outputs: @@ -712,33 +764,32 @@ subroutine sfc_nst_pre_run & half = 0.5_kp, & omz1 = 2.0_kp real(kind=kind_phys) :: tem1, tem2, dnsst - real(kind=kind_phys), dimension(im) :: dtzm,z_c_0 + real(kind=kind_phys), dimension(im) :: dtzm, z_c_0 ! Initialize CCPP error handling variables errmsg = '' errflg = 0 do i=1,im - if (wet(i) .and. .not. use_flake(i)) then + if (wet(i) .and. oceanfrac(i) > 0.0) then ! tem = (oro(i)-oro_uf(i)) * rlapse ! DH* 20190927 simplyfing this code because tem is zero !tem = zero - !tseal(i) = tsfc_wat(i) + tem - tseal(i) = tsfc_wat(i) + !tseal(i) = tsfco(i) + tem + tseal(i) = tsfco(i) !tsurf_wat(i) = tsurf_wat(i) + tem ! *DH endif enddo - ! ! update tsfc & tref with T1 from OGCM & NSST Profile if coupled ! if (cplflx) then - z_c_0 = 0.0 + z_c_0 = zero call get_dtzm_2d (xt, xz, dt_cool, & & z_c_0, wet, zero, omz1, im, 1, nthreads, dtzm) do i=1,im - if (wet(i) .and. oceanfrac(i)>zero .and..not.use_flake(i)) then + if (wet(i) .and. oceanfrac(i) > zero ) then ! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf tref(i) = max(tgice, tsfco(i) - dtzm(i)) ! update Tf with T1 and NSST T-Profile ! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index dc0056aeb..92884faef 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -195,6 +195,32 @@ kind = kind_phys intent = in optional = F +[lseaspray] + standard_name = flag_for_sea_spray + long_name = flag for sea spray parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[fm] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_water + long_name = Monin-Obukhov similarity function for momentum over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fm10] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_water + long_name = Monin-Obukhov similarity parameter for momentum at 10m over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [prsl1] standard_name = air_pressure_at_lowest_model_layer long_name = surface layer mean pressure @@ -240,8 +266,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical @@ -696,14 +722,6 @@ type = logical intent = in optional = F -[use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction - units = flag - dimensions = (horizontal_loop_extent) - type = logical - intent = in - optional = F [tgice] standard_name = freezing_point_temperature_of_seawater long_name = freezing point temperature of seawater @@ -722,15 +740,6 @@ kind = kind_phys intent = in optional = F -[tsfc_wat] - standard_name = surface_skin_temperature_over_water_interstitial - long_name = surface skin temperature over water (temporary use as interstitial) - units = K - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [tsurf_wat] standard_name = surface_skin_temperature_after_iteration_over_water long_name = surface skin temperature after iteration over water @@ -890,8 +899,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 67a6df04f..79a9eb295 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -26,8 +26,9 @@ end subroutine sfc_ocean_finalize subroutine sfc_ocean_run & !................................... ! --- inputs: - & ( im, rd, eps, epsm1, rvrdm1, ps, t1, q1, & - & tskin, cm, ch, prsl1, prslki, wet, use_flake, wind, &, ! --- 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 & flag_iter, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs & errmsg, errflg & @@ -40,8 +41,7 @@ subroutine sfc_ocean_run & ! ! ! call sfc_ocean ! ! inputs: ! -! ( im, ps, t1, q1, tskin, cm, ch, ! -!! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! +! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, lseaspray, fm, fm10, ! ! prsl1, prslki, wet, use_flake, wind, flag_iter, ! ! outputs: ! ! qsurf, cmm, chh, gflux, evap, hflx, ep ) ! @@ -65,11 +65,16 @@ subroutine sfc_ocean_run & ! inputs: size ! ! im - integer, horizontal dimension 1 ! ! ps - real, surface pressure im ! +! u1, v1 - real, u/v component of surface layer wind (m/s) im ! ! t1 - real, surface layer mean temperature ( k ) im ! ! q1 - real, surface layer mean specific humidity im ! ! tskin - real, ground surface skin temperature ( k ) im ! ! cm - real, surface exchange coeff for momentum (m/s) im ! ! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! lseaspray- logical, .t. for parameterization for sea spray 1 ! +! fm - real, a stability profile function for momentum im ! +! fm10 - real, a stability profile function for momentum im ! +! at 10m ! ! prsl1 - real, surface layer mean pressure im ! ! prslki - real, im ! ! wet - logical, =T if any ocean/lak, =F otherwise im ! @@ -93,15 +98,19 @@ subroutine sfc_ocean_run & implicit none ! --- constant parameters: - real (kind=kind_phys), parameter :: one = 1.0_kind_phys, zero = 0.0_kind_phys & - &, qmin = 1.0e-8_kind_phys + real (kind=kind_phys), parameter :: one = 1.0_kind_phys, & + & zero = 0.0_kind_phys, qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im - real (kind=kind_phys), intent(in) :: rd, eps, epsm1, rvrdm1 + real (kind=kind_phys), intent(in) :: hvap, cp, rd, & + & eps, epsm1, rvrdm1 - real (kind=kind_phys), dimension(:), intent(in) :: ps, & - & t1, q1, tskin, cm, ch, prsl1, prslki, wind + real (kind=kind_phys), dimension(:), intent(in) :: ps, u1, v1, & + & t1, q1, tskin, cm, ch, fm, fm10, prsl1, prslki, wind +! For sea spray effect + logical, intent(in) :: lseaspray +! logical, dimension(:), intent(in) :: flag_iter, wet, use_flake ! --- outputs: @@ -113,48 +122,105 @@ subroutine sfc_ocean_run & ! --- locals: - real (kind=kind_phys) :: q0, qss, rch, rho, tem + real (kind=kind_phys) :: qss, rch, tem, + & elocp, cpinv, hvapi + real (kind=kind_phys), dimension(im) :: rho, q0 integer :: i + logical :: flag(im) +! +! parameters for sea spray effect +! + real (kind=kind_phys) :: f10m, u10m, v10m, ws10, ru10, qss1, + & bb1, hflxs, evaps, ptem +! +! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.1, +! real (kind=kind_phys), parameter :: alps=0.5, bets=0.5, gams=0.0, +! real (kind=kind_phys), parameter :: alps=1.0, bets=1.0, gams=0.2, + real (kind=kind_phys), parameter :: alps=0.75,bets=0.75,gams=0.15, + & ws10cr=30., conlf=7.2e-9, consf=6.4e-8 +! +!====================================================================================================== !===> ... begin here ! ! -- ... initialize CCPP error handling variables errmsg = '' errflg = 0 + + cpinv = one/cp + hvapi = one/hvap + elocp = hvap/cp ! ! --- ... flag for open water do i = 1, im - + flag(i) = (wet(i) .and. flag_iter(i) .and. .not. use_flake(i)) ! --- ... 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 - if (wet(i) .and. flag_iter(i) .and. .not. use_flake(i)) then - q0 = max( q1(i), qmin ) - rho = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0)) + if ( flag(i) ) then + q0(i) = max( q1(i), qmin ) + rho(i) = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0(i))) qss = fpvs( tskin(i) ) qss = eps*qss / (ps(i) + epsm1*qss) ! --- ... rcp = rho cp ch v + rch = rho(i) * cp * ch(i) * wind(i) tem = ch(i) * wind(i) cmm(i) = cm(i) * wind(i) - chh(i) = rho * tem + chh(i) = rho(i) * tem ! --- ... sensible and latent heat flux over open water - hflx(i) = tem * (tskin(i) - t1(i) * prslki(i)) + hflx(i) = rch * (tskin(i) - t1(i) * prslki(i)) - evap(i) = tem * (qss - q0) + evap(i) = elocp * rch * (qss - q0(i)) - ep(i) = evap(i) qsurf(i) = qss gflux(i) = zero endif enddo ! +! include sea spray effects +! + do i=1,im + if(lseaspray .and. flag(i)) then + f10m = fm10(i) / fm(i) + u10m = f10m * u1(i) + v10m = f10m * v1(i) + ws10 = sqrt(u10m*u10m + v10m*v10m) + ws10 = max(ws10,1.) + ws10 = min(ws10,ws10cr) + tem = .015 * ws10 * ws10 + ru10 = 1. - .087 * log(10./tem) + qss1 = fpvs(t1(i)) + qss1 = eps * qss1 / (prsl1(i) + epsm1 * qss1) + tem = rd * cp * t1(i) * t1(i) + tem = 1. + eps * hvap * hvap * qss1 / tem + bb1 = 1. / tem + evaps = conlf * (ws10**5.4) * ru10 * bb1 + evaps = evaps * rho(i) * hvap * (qss1 - q0(i)) + evap(i) = evap(i) + alps * evaps + hflxs = consf * (ws10**3.4) * ru10 + hflxs = hflxs * rho(i) * cp * (tskin(i) - t1(i)) + ptem = alps - gams + hflx(i) = hflx(i) + bets * hflxs - ptem * evaps + endif + enddo +! + do i = 1, im + if ( flag(i) ) then + tem = 1.0 / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + ep(i) = evap(i) + endif + enddo +! + return !................................... end subroutine sfc_ocean_run diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index f27c2207d..ace1fcf70 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -15,6 +15,24 @@ type = integer intent = in optional = F +[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 + optional = F +[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 + optional = F [rd] standard_name = gas_constant_dry_air long_name = ideal gas constant for dry air @@ -60,6 +78,24 @@ kind = kind_phys intent = in optional = F +[u1] + standard_name = x_wind_at_lowest_model_layer + long_name = x component of surface layer wind + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[v1] + standard_name = y_wind_at_lowest_model_layer + long_name = y component of surface layer wind + units = m s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [t1] standard_name = air_temperature_at_lowest_model_layer long_name = surface layer mean temperature @@ -105,6 +141,32 @@ kind = kind_phys intent = in optional = F +[lseaspray] + standard_name = flag_for_sea_spray + long_name = flag for sea spray parameterization + units = flag + dimensions = () + type = logical + intent = in + optional = F +[fm] + standard_name = Monin_Obukhov_similarity_function_for_momentum_over_water + long_name = Monin-Obukhov similarity function for momentum over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F +[fm10] + standard_name = Monin_Obukhov_similarity_function_for_momentum_at_10m_over_water + long_name = Monin-Obukhov similarity parameter for momentum at 10m over water + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = F [prsl1] standard_name = air_pressure_at_lowest_model_layer long_name = surface layer mean pressure @@ -132,8 +194,8 @@ intent = in optional = F [use_flake] - standard_name = flag_nonzero_lake_surface_fraction - long_name = flag indicating presence of some lake surface area fraction + standard_name = flag_for_using_flake + long_name = flag indicating lake points using flake model units = flag dimensions = (horizontal_loop_extent) type = logical diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 93f7ca16d..176a3e8de 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -45,11 +45,10 @@ subroutine sfc_sice_run & & t0c, rd, ps, t1, q1, delt, & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & - & flag_iter, lprnt, ipr, thsfc_loc, & + & flag_iter, use_flake, lprnt, ipr, thsfc_loc, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: - & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & ! - & frac_grid, icy, islmsk_cice, & - & min_lakeice, min_seaice, oceanfrac, & + & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & + & islmsk, & & errmsg, errflg & ) @@ -71,22 +70,22 @@ subroutine sfc_sice_run & ! ! ! subprogram called: ice3lay. ! ! ! -!> program history log: -!!- 2005 -- xingren wu created from original progtm and added -!! two-layer ice model -!!- 200x -- sarah lu added flag_iter -!!- oct 2006 -- h. wei added cmm and chh to output +!> program history log: +!!- 2005 -- xingren wu created from original progtm and added +!! two-layer ice model +!!- 200x -- sarah lu added flag_iter +!!- oct 2006 -- h. wei added cmm and chh to output !!- 2007 -- x. wu modified for mom4 coupling (i.e. cpldice) !! (not used anymore) -!!- 2007 -- s. moorthi micellaneous changes -!!- may 2009 -- y.-t. hou modified to include surface emissivity -!! effect on lw radiation. replaced the confusing +!!- 2007 -- s. moorthi micellaneous changes +!!- may 2009 -- y.-t. hou modified to include surface emissivity +!! effect on lw radiation. replaced the confusing !! slrad with sfc net sw sfcnsw (dn-up). reformatted -!! the code and add program documentation block. -!!- sep 2009 -- s. moorthi removed rcl, changed pressure units and -!! further optimized -!!- jan 2015 -- x. wu change "cimin = 0.15" for both -!! uncoupled and coupled case +!! the code and add program documentation block. +!!- sep 2009 -- s. moorthi removed rcl, changed pressure units and +!! further optimized +!!- jan 2015 -- x. wu change "cimin = 0.15" for both +!! uncoupled and coupled case ! ! ! ! ! ==================== defination of variables ==================== ! @@ -111,6 +110,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 ! ! thsfc_loc- logical, reference pressure for potential temp im ! ! ! ! input/outputs: ! @@ -135,7 +135,7 @@ subroutine sfc_sice_run & ! ! ! ===================================================================== ! ! - use machine, only : kind_phys + use machine, only : kind_phys use funcphys, only : fpvs ! implicit none @@ -155,21 +155,18 @@ subroutine sfc_sice_run & integer, intent(in) :: im, kice, ipr logical, intent(in) :: lprnt logical, intent(in) :: thsfc_loc - logical, intent(in) :: frac_grid real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & & epsm1, grav, rvrdm1, t0c, rd real (kind=kind_phys), dimension(:), intent(in) :: ps, & & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & - & prsl1, prslki, prsik1, prslk1, wind, oceanfrac + & prsl1, prslki, prsik1, prslk1, wind -! integer, dimension(im), intent(in) :: islimsk - integer, dimension(:), intent(in) :: islmsk_cice - real (kind=kind_phys), intent(in) :: delt, min_seaice, & - & min_lakeice + integer, dimension(:), intent(in) :: islmsk + real (kind=kind_phys), intent(in) :: delt - logical, dimension(:), intent(in) :: flag_iter, icy + logical, dimension(im), intent(in) :: flag_iter, use_flake ! --- input/outputs: real (kind=kind_phys), dimension(:), intent(inout) :: hice, & @@ -193,10 +190,11 @@ subroutine sfc_sice_run & real (kind=kind_phys) :: t12, t14, tem, stsice(im,kice) &, hflxi, hflxw, q0, qs1, qssi, qssw - real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin + real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw +! real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin + logical do_sice integer :: i, k - integer, dimension(im) :: islmsk_local logical :: flag(im) ! @@ -209,35 +207,20 @@ subroutine sfc_sice_run & ! Initialize CCPP error handling variables errmsg = '' errflg = 0 - - - islmsk_local = islmsk_cice - if (frac_grid) then - do i=1,im - if (icy(i) .and. islmsk_local(i) < 2) then - if (oceanfrac(i) > zero) then - tem = min_seaice - else - tem = min_lakeice - endif - if (fice(i) > tem) then - islmsk_local(i) = 2 - tice(i) =min( tice(i), tgice) - endif - endif - enddo - endif - ! !> - Set flag for sea-ice. + do_sice = .false. do i = 1, im - flag(i) = (islmsk_local(i) == 2) .and. flag_iter(i) - if (flag_iter(i) .and. islmsk_local(i) < 2) then - hice(i) = zero - fice(i) = zero - endif + flag(i) = islmsk(i) == 2 .and. flag_iter(i) & + & .and. .not. use_flake(i) + do_sice = do_sice .or. flag(i) +! if (flag_iter(i) .and. islmsk(i) < 2) then +! hice(i) = zero +! fice(i) = zero +! endif enddo + if (.not. do_sice) return do i = 1, im if (flag(i)) then @@ -266,38 +249,30 @@ subroutine sfc_sice_run & do i = 1, im if (flag(i)) then - if (oceanfrac(i) > zero) then - cimin = min_seaice - else - cimin = min_lakeice - endif -! psurf(i) = 1000.0 * ps(i) -! ps1(i) = 1000.0 * prsl1(i) ! dlwflx has been given a negative sign for downward longwave ! sfcnsw is the net shortwave flux (direction: dn-up) q0 = max(q1(i), qmin) -! tsurf(i) = tskin(i) - if(thsfc_loc) then ! Use local potential temperature + if (thsfc_loc) then ! Use local potential temperature theta1(i) = t1(i) * prslki(i) - else ! Use potential temperature referenced to 1000 hPa + else ! Use potential temperature referenced to 1000 hPa theta1(i) = t1(i) / prslk1(i) ! potential temperature in middle of lowest atm. layer endif - rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) - qs1 = fpvs(t1(i)) - qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) - q0 = min(qs1, q0) + rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) + qs1 = fpvs(t1(i)) + qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) + q0 = min(qs1, q0) - if (fice(i) < cimin) then +! if (fice(i) < cimin) then ! print *,'warning: ice fraction is low:', fice(i) - fice(i) = cimin - tice(i) = tgice - tskin(i)= tgice +! fice(i) = cimin +! tice(i) = tgice +! tskin(i)= tgice ! print *,'fix ice fraction: reset it to:', fice(i) - endif +! endif ffw(i) = one - fice(i) qssi = fpvs(tice(i)) @@ -378,7 +353,7 @@ subroutine sfc_sice_run & !> - Call the three-layer thermodynamics sea ice model ice3lay(). call ice3lay ! --- inputs: ! - & ( im, kice, fice, flag, hfi, hfd, sneti, focn, delt, ! + & ( im, kice, fice, flag, hfi, hfd, sneti, focn, delt, ! & lprnt, ipr, ! --- outputs: ! & snowd, hice, stsice, tice, snof, snowmt, gflux ) ! @@ -387,14 +362,12 @@ subroutine sfc_sice_run & if (flag(i)) then if (tice(i) < timin) then print *,'warning: snow/ice temperature is too low:',tice(i) - &,' i=',i tice(i) = timin print *,'fix snow/ice temperature: reset it to:',tice(i) endif if (stsice(i,1) < timin) then print *,'warning: layer 1 ice temp is too low:',stsice(i,1) - &,' i=',i stsice(i,1) = timin print *,'fix layer 1 ice temp: reset it to:',stsice(i,1) endif @@ -405,7 +378,6 @@ subroutine sfc_sice_run & print *,'fix layer 2 ice temp: reset it to:',stsice(i,2) endif - tskin(i) = tice(i)*fice(i) + tgice*ffw(i) endif enddo @@ -431,6 +403,7 @@ subroutine sfc_sice_run & hflx(i) = fice(i)*hflxi + ffw(i)*hflxw evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) + tskin(i) = fice(i)*tice(i) + ffw(i)*tgice ! ! --- ... the rest of the output @@ -696,8 +669,8 @@ subroutine ice3lay snowd (i) = snowd(i) - snowmt(i) else snowmt(i) = snowd(i) - h1 = h1 - (tmelt - snowd(i)*dsli) & - & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1))) + h1 = max(zero, h1 - (tmelt - snowd(i)*dsli) & + & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1)))) snowd(i) = zero endif @@ -712,6 +685,7 @@ subroutine ice3lay else h2 = h2 - bmelt / (dili + dici*(tfi - stsice(i,2))) endif + h2 = max(h2, zero) !> - If ice remains, even up 2 layers, else, pass negative energy back in snow. !! Calculate the new upper layer temperature (see \a eq.(38)). diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index b256d54ff..aa520115b 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -265,6 +265,14 @@ type = logical intent = in optional = F +[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 + intent = in + optional = F [lprnt] standard_name = flag_print long_name = switch for printing sample column to stdout @@ -433,23 +441,7 @@ kind = kind_phys intent = inout optional = F -[frac_grid] - standard_name = flag_for_fractional_grid - long_name = flag for fractional grid - units = flag - dimensions = () - type = logical - intent = in - optional = F -[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 = in - optional = F -[islmsk_cice] +[islmsk] standard_name = sea_land_ice_mask_cice long_name = sea/land/ice mask cice (=0/1/2) units = flag @@ -457,33 +449,6 @@ type = integer intent = in optional = F -[min_lakeice] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[min_seaice] - standard_name = sea_ice_minimum - long_name = minimum sea ice value - units = frac - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F -[oceanfrac] - standard_name = sea_area_fraction - long_name = fraction of horizontal grid area occupied by ocean - units = frac - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in - optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfcsub.F b/physics/sfcsub.F index 067e5ad4e..002103e10 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -8,6 +8,7 @@ !! This module contains grib code for each parameter-used in subroutines sfccycle() !! and setrmsk(). module sfccyc_module + use machine , only : kind_io8,kind_io4 implicit none save ! @@ -19,12 +20,12 @@ module sfccyc_module &, kpdvmn,kpdvmx,kpdslp,kpdabs &, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4) parameter(kpdtsf=11, kpdwet=86, kpdsno=65, kpdzor=83, -! 1 kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, - 1 kpdais=91, kpdtg3=11, kpdplr=224, - 2 kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, - 3 kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87, +! & kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, + & kpdais=91, kpdtg3=11, kpdplr=224, + & kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, + & 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, + & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, & kpdvet=225, kpdsot=224,kpdabs_1=159, & kpdsnd=66 ) ! @@ -32,6 +33,7 @@ module sfccyc_module integer, parameter :: kpdalb_1(4)=(/189,190,191,192/) integer, parameter :: kpdalf(2)=(/214,217/) ! + real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice @@ -52,11 +54,11 @@ end function message end module sfccyc_module !>\ingroup mod_GFS_phys_time_vary -!! This subroutine reads or interpolates surface climatology data in analysis +!! This subroutine reads or interpolates surface climatology data in analysis !! and forecast mode. !!\param lugb the unit number used in this subprogram !!\param len number of points on which sfccyc operates -!!\param lsoil number of soil layers +!!\param lsoil number of soil layers !!\param sig1t sigma level 1 temperature for dead start. it should be on gaussian !! grid. If not dead start, no need for dimension but set to zero as !! in the example below. @@ -71,18 +73,18 @@ end module sfccyc_module !!\param nst_anl !! - subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & - &, iy,im,id,ih,fh & - &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl & - &, sihfcs,sicfcs,sitfcs & - &, swdfcs,slcfcs & - &, vmnfcs,vmxfcs,slpfcs,absfcs & - &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & - &, vegfcs,vetfcs,sotfcs,alffcs & - &, cvfcs,cvbfcs,cvtfcs,me,nthrds,nlunit & - &, sz_nml,input_nml_file & - &, lake, min_lakeice, min_seaice & + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & + &, iy,im,id,ih,fh,rla,rlo & + &, slmskl,slmskw,orog,orog_uf,use_ufo,nst_anl & + &, sihfcs,sicfcs,sitfcs & + &, swdfcs,slcfcs & + &, vmnfcs,vmxfcs,slpfcs,absfcs & + &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & + &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & + &, vegfcs,vetfcs,sotfcs,alffcs & + &, cvfcs,cvbfcs,cvtfcs,me,nthrds,nlunit & + &, sz_nml,input_nml_file & + &, min_ice & &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) ! use machine , only : kind_io8,kind_io4 @@ -92,8 +94,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & integer, intent(in) :: i_index(len), j_index(len), & & me, nthrds logical, intent(in) :: use_ufo, nst_anl - logical, intent(in) :: lake(len) - real (kind=kind_io8), intent(in) :: min_lakeice, min_seaice + real (kind=kind_io8), intent(in) :: min_ice(len) real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, & & orolmx,orolmn,oroomx,oroomn,orosmx, & @@ -316,7 +317,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, & plrjmx=1000.,plrjmn=0.0) -!clu [-1l/+1l] relax tsfsmx +!clu [-1l/+1l] relax tsfsmx parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, & tsfjmx=273.16,tsfjmn=173.0) @@ -342,19 +343,19 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & vegjmx=0.0,vegjmn=0.0) parameter(vmnlmx=1.0,vmnlmn=0.0,vmnomx=0.0,vmnomn=0.0, & vmnsmx=1.0,vmnsmn=0.0,vmnimx=0.0,vmnimn=0.0, - & vmnjmx=0.0,vmnjmn=0.0) + & vmnjmx=0.0,vmnjmn=0.0) parameter(vmxlmx=1.0,vmxlmn=0.0,vmxomx=0.0,vmxomn=0.0, & vmxsmx=1.0,vmxsmn=0.0,vmximx=0.0,vmximn=0.0, - & vmxjmx=0.0,vmxjmn=0.0) + & vmxjmx=0.0,vmxjmn=0.0) parameter(slplmx=9.0,slplmn=1.0,slpomx=0.0,slpomn=0.0, & slpsmx=9.0,slpsmn=1.0,slpimx=0.,slpimn=0., - & slpjmx=0.,slpjmn=0.) + & slpjmx=0.,slpjmn=0.) ! note: the range values for bare land and snow covered land ! (alblmx, alblmn, albsmx, albsmn) are set below ! based on whether the old or new radiation is selected parameter(absomx=0.0,absomn=0.0, & absimx=0.0,absimn=0.0, - & absjmx=0.0,absjmn=0.0) + & absjmx=0.0,absjmn=0.0) ! vegetation type parameter(vetlmx=20.,vetlmn=1.0,vetomx=0.0,vetomn=0.0, & vetsmx=20.,vetsmn=1.0,vetimx=0.,vetimn=0., @@ -399,7 +400,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! parameter(snwmin=25.,snwmax=100.) parameter(snwmin=5.0,snwmax=100.) - real (kind=kind_io8), parameter :: ten=10.0, one=1.0 +! real (kind=kind_io8), parameter :: ten=10.0, one=1.0, zero=0.0 ! ! coefficients of blending forecast and interpolated clim ! (or analyzed) fields over sea or land(l) (not for clouds) @@ -451,9 +452,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! mask orography and variance on gaussian grid ! - real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) & - &, orogd(len) - real (kind=kind_io8) rla(len), rlo(len) + real (kind=kind_io8) slmskl(len), slmskw(len) + real (kind=kind_io8) orog(len), orog_uf(len), orogd(len) + real (kind=kind_io8) rla(len), rlo(len) ! ! permanent/extremes ! @@ -467,7 +468,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc & &, fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc & &, fnvegc,fnvetc,fnsotc & - &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 + &, 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) & @@ -483,7 +484,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 & - &, fnvmna,fnvmxa,fnslpa,fnabsa + &, fnvmna,fnvmxa,fnslpa,fnabsa ! real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len) & &, zoranl(len), albanl(len,4), aisanl(len) & @@ -514,7 +515,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! in this program). ! real (kind=kind_io8) f10m (len) - real (kind=kind_io8) fsmcl(25),fsmcs(25),fstcl(25),fstcs(25) + real (kind=kind_io8) fsmcl(25), fsmcs(25), fstcl(25), fstcs(25) real (kind=kind_io8) fcsmcl(25),fcsmcs(25),fcstcl(25),fcstcs(25) !clu [+1l] add swratio (soil moisture liquid-to-total ratio) @@ -532,6 +533,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & integer kpd7, kpd9 ! logical icefl1(len), icefl2(len) +! + real (kind=kind_io8), allocatable, dimension(:) :: & + & tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, aisfcsd, & + & cnpfcsd, vegfcsd, vetfcsd, sotfcsd, sihfcsd, sicfcsd, & + & vmnfcsd, vmxfcsd, slpfcsd, absfcsd + real (kind=kind_io8), allocatable, dimension(:,:) :: & + & smcfcsd, stcfcsd, albfcsd ! ! input and output surface fields (bges) file names ! @@ -777,19 +785,19 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & num_threads = nthrds ! lprnt = .false. - iprnt = 1 ! do i=1,len ! if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i) ! *,' rlo=',rlo(i) -! tem1 = abs(rla(i) - 48.75) -! tem2 = abs(rlo(i) - (-68.50)) -! if(tem1 .lt. 0.25 .and. tem2 .lt. 0.50) then +! tem1 = abs(rla(i) - 60.11) +! tem2 = abs(rlo(i) - 5.38) +! if(tem1 < 0.10 .and. tem2 < 0.10) then ! lprnt = .true. ! iprnt = i ! print *,' lprnt=',lprnt,' iprnt=',iprnt ! print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i) ! endif ! enddo + if (ialb == 1) then kpdabs = kpdabs_1 kpdalb = kpdalb_1 @@ -855,14 +863,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif if (ivegsrc == 2) then ! sib - veg_type_landice=13 + veg_type_landice = 13 else - veg_type_landice=15 + veg_type_landice = 15 endif if (isot == 0) then - soil_type_landice=9 + soil_type_landice = 9 else - soil_type_landice=16 + soil_type_landice = 16 endif ! deltf = deltsfc / 24.0 @@ -1052,8 +1060,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! kpd9 = -1 kpd7 = -1 - call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmask, - & glacir,len,iret + call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmskl + &, glacir,len,iret &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk &, rla, rlo, me) ! znnt=1. @@ -1062,8 +1070,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! read maximum ice extent ! kpd7 = -1 - call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmask, - & amxice,len,iret + call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmskl + &, amxice,len,iret &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk &, rla, rlo, me) ! znnt=1. @@ -1085,6 +1093,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & 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 ! @@ -1096,7 +1106,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! percrit=critp1 ! - call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + 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, @@ -1113,6 +1123,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & deltsfc, lanom &, 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 @@ -1135,11 +1146,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! set albedo over ocean to albomx ! - call albocn(albclm,slmask,albomx,len) + call albocn(albclm,slmskl,albomx,len) ! ! make sure vegetation type and soil type are non zero over land ! - call landtyp(vetclm,sotclm,slpclm,slmask,len) + call landtyp(vetclm,sotclm,slpclm,slmskl,len) ! !cwu [-1l/+1l] !* ice concentration or ice mask (only ice mask used in the model now) @@ -1150,7 +1161,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do i=1,len sihclm(i) = 3.0*aisclm(i) sicclm(i) = aisclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskl(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicclm(i) /= 1.0) then sicclm(i) = sicimx sihfcs(i) = glacir_hice @@ -1159,21 +1170,21 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & crit=aislim !* crit=0.5 ! call rof01(aisclm,len,'ge',crit) - call rof01_len(aisclm, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(aisclm, len, 'ge', min_ice) elseif(fnacnc(1:8) /= ' ') then !cwu [+4l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*acnclm(i) sicclm(i) = acnclm(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicclm(i).ne.1.) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo ! call rof01(acnclm,len,'ge',aislim) - call rof01_len(acnclm, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(acnclm, len, 'ge', min_ice) do i=1,len aisclm(i) = acnclm(i) enddo @@ -1181,15 +1192,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! quality control of sea ice mask ! - call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmask, + call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmskw, & rla,rlo,len,me) ! ! set ocean/land/sea-ice mask ! - call setlsi(slmask,aisclm,len,aicice,sliclm) + call setlsi(slmskw,aisclm,len,aicice,sliclm) ! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' -! *,sliclm(iprnt),' slmask=',slmask(iprnt) +! &,sliclm(iprnt),' slmskw=',slmskw(iprnt) ! ! write(6,*) 'sliclm' ! znnt=1. @@ -1197,7 +1208,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! quality control of snow ! - call qcsnow(snoclm,slmask,aisclm,glacir,len,snosmx,landice,me) + call qcsnow(snoclm,slmskl,aisclm,glacir,len,snosmx,landice,me) ! call setzro(snoclm,epssno,len) ! @@ -1388,13 +1399,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, & vetanl,sotanl,alfanl, & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, + & vmnanl,vmxanl,slpanl,absanl, & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, & tg3clm,cvclm ,cvbclm,cvtclm, & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, & vetclm,sotclm,alfclm, & sihclm,sicclm, - & vmnclm,vmxclm,slpclm,absclm, + & vmnclm,vmxclm,slpclm,absclm, & len,lsoil) ! ! reverse scaling to match with grib analysis input @@ -1418,7 +1429,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! read analysis fields ! - call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + 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, @@ -1427,17 +1438,18 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & tg3anl,cvanl ,cvbanl,cvtanl, & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & vetanl,sotanl,alfanl,tsfan0, - & vmnanl,vmxanl,slpanl,absanl, + & vmnanl,vmxanl,slpanl,absanl, & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & kpdvet,kpdsot,kpdalf, - & kpdvmn,kpdvmx,kpdslp,kpdabs, + & kpdvmn,kpdvmx,kpdslp,kpdabs, & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & irtvet,irtsot,irtalf - &, irtvmn,irtvmx,irtslp,irtabs, + &, irtvmn,irtvmx,irtslp,irtabs, & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk &, me, lanom) + ! if(lprnt) print *,' tsfanl=',tsfanl(iprnt) ! ! scale zor and alb to match forecast model units @@ -1469,7 +1481,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if (use_ufo .and. .not. nst_anl) then ztsfc = 0.0 - call tsfcor(tsfanl,orog_uf,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orog_uf,slmskw,ztsfc,len,rlapse) endif ! ! ice concentration or ice mask (only ice mask used in the model now) @@ -1479,7 +1491,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do i=1,len sihanl(i) = 3.0*aisanl(i) sicanl(i) = aisanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice @@ -1488,13 +1500,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! crit=aislim !* crit=0.5 ! call rof01(aisanl,len,'ge',crit) - call rof01_len(aisanl, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(aisanl, len, 'ge', min_ice) elseif(fnacna(1:8) /= ' ') then !cwu [+17l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*acnanl(i) sicanl(i) = acnanl(i) - if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + if(nint(slmskw(i)) == 0 .and. nint(glacir(i)) == 1 & & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice @@ -1502,20 +1514,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & enddo ! crit=aislim do i=1,len - if (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif + crit = min_ice(i) if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then - slianl(i) = 2. + slianl(i) = 2.0_kind_io8 ! print *,'cycle - new ice form: fice=',sicanl(i) elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then slianl(i) = 0. ! print *,'cycle - ice free: fice=',sicanl(i) - elseif (nint(slianl(i)) == 1 .and. sicanl(i) > crit) then -! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i) = 0. + elseif (nint(slianl(i)) == 1 .and. sicanl(i) >= crit) then + if (nint(slmskw(i)) == 0) then ! can happen only for fractional grid + slianl(i) = 2.0_kind_io8 + else +! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) + sicanl(i) = 0.0_kind_io8 + endif endif enddo ! znnt=10. @@ -1527,22 +1539,23 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! enddo ! if(lprnt) print *,' acnanl=',acnanl(iprnt) ! call rof01(acnanl,len,'ge',aislim) - call rof01_len(acnanl, len, 'ge', lake, min_lakeice, min_seaice) + call rof01_len(acnanl, len, 'ge', min_ice) do i=1,len aisanl(i) = acnanl(i) enddo endif -! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' -! &,glacir(iprnt),' slmask=',slmask(iprnt) +! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' & +! &,glacir(iprnt),' slmskwl=',slmskw(iprnt),slmskl(iprnt) ! - call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmask, + call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmskw, & rla,rlo,len,me) ! ! set ocean/land/sea-ice mask ! - call setlsi(slmask,aisanl,len,aicice,slianl) -! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' -! *,slianl(iprnt),' slmask=',slmask(iprnt) + call setlsi(slmskw,aisanl,len,aicice,slianl) + +! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' & +! &,slianl(iprnt),' slmskwl=',slmskw(iprnt),slmskl(iprnt) ! ! do k=1,lsoil @@ -1569,14 +1582,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! set albedo over ocean to albomx ! - call albocn(albanl,slmask,albomx,len) + call albocn(albanl,slmskl,albomx,len) ! ! quality control of snow and sea-ice ! process snow depth or snow cover ! if (fnsnoa(1:8) /= ' ') then call setzro(snoanl,epssno,len) - call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) + call qcsnow(snoanl,slmskl,aisanl,glacir,len,ten,landice,me) if (.not.landice) then call snodpth2(glacir,snosmx,snoanl, len, me) endif @@ -1594,14 +1607,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & else crit = 0.5 call rof01(scvanl,len,'ge',crit) - call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) + call qcsnow(scvanl,slmskl,aisanl,glacir,len,one,landice,me) call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1, & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, & rla,rlo,len,kqcm,percrit,lgchek,me) call snodpth(scvanl,slianl,tsfanl,snoclm, & glacir,snwmax,snwmin,landice,len,snoanl,me) - call qcsnow(scvanl,slmask,aisanl,glacir,len,snosmx,landice,me) + call qcsnow(scvanl,slmskl,aisanl,glacir,len,snosmx,landice,me) call snosfc(snoanl,tsfanl,tsfsmx,len,me) call qcmxmn('snowa ',snoanl,slianl,snoanl,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, @@ -1770,7 +1783,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & !cwu [+1l] add ()anl for sih, sic & sihanl,sicanl, !clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, + & vmnanl,vmxanl,slpanl,absanl, & len,lsoil) if (sig1t(1) /= 0.) then call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, @@ -1807,13 +1820,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if ( index(fntg3c, "tileX.nc") == 0) then ! global file ztsfc = 1.0 - call tsfcor(tg3fcs,orogd,slmask,ztsfc,len,-rlapse) + call tsfcor(tg3fcs,orogd,slmskl,ztsfc,len,-rlapse) endif ztsfc = 0. - call tsfcor(tsffcs,orogd,slmask,ztsfc,len,-rlapse) + call tsfcor(tsffcs,orogd,slmskw,ztsfc,len,-rlapse) else ztsfc = 0. - call tsfcor(tsffcs,orog,slmask,ztsfc,len,-rlapse) + call tsfcor(tsffcs,orog,slmskw,ztsfc,len,-rlapse) endif !clu [+12l] -------------------------------------------------------------- @@ -1833,7 +1846,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if (lqcbgs .and. irtacn == 0) then call qcsli(slianl,slifcs,len,me) - call albocn(albfcs,slmask,albomx,len) + call albocn(albfcs,slmskl,albomx,len) do i=1,len icefl2(i) = sicfcs(i) .gt. 0.99999 enddo @@ -1976,6 +1989,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) ! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) + do i=1,len + if (sicanl(i) >= min_ice(i)) then + slianl(i) = 2.0_kind_io8 + else + slianl(i) = zero + sicanl(i) = zero + endif + enddo + if (fh-deltsfc > -0.001 ) then do i=1,len if(slianl(i) == 0.0) then @@ -2004,15 +2026,18 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! merge analysis and forecast. note tg3, ais are not merged ! +! if(lprnt) print *,' stcfcsbefmer=',stcfcs(iprnt,:) +! if(lprnt) print *,' stcanlbefmer=',stcanl(iprnt,:) + call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, + & slmskl,slmskw,sihfcs,sicfcs, + & vmnfcs,vmxfcs,slpfcs,absfcs, & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & cvfcs ,cvbfcs,cvtfcs, & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, & cvanl ,cvbanl,cvtanl, & cnpanl,smcanl,stcanl,slianl,veganl, @@ -2025,20 +2050,22 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, + & irtvmn,irtvmx,irtslp,irtabs, & irtvet,irtsot,irtalf,landice,me) call setzro(snoanl,epssno,len) ! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt) ! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt) +! if(lprnt) print *,' stcfcsmer=',stcfcs(iprnt,:) +! if(lprnt) print *,' stcanlmer=',stcanl(iprnt,:) ! ! new ice/melted ice ! call newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, !cwu [+1l] add sihnew, aislim, sihanl & sicanl - & sihnew,aislim,sihanl,sicanl, + & sihnew,aislim,sihanl,sicanl, & albanl,snoanl,zoranl,smcanl,stcanl, & albomx,snoomx,zoromx,smcomx,smcimx, !cwu [-1l/+1l] change albimx to albimn - note albimx & albimn have been modified @@ -2048,7 +2075,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt) ! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt) -! +! if(lprnt) print *,' stcan=',stcanl(iprnt,:) + ! set tsfc to tsnow over snow ! call snosfc(snoanl,tsfanl,tsfsmx,len,me) @@ -2158,13 +2186,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! if ( index(fntg3c, "tileX.nc") == 0) then ! global file ztsfc = 1. - call tsfcor(tg3anl,orogd,slmask,ztsfc,len,rlapse) + call tsfcor(tg3anl,orogd,slmskl,ztsfc,len,rlapse) endif ztsfc = 0. - call tsfcor(tsfanl,orogd,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orogd,slmskw,ztsfc,len,rlapse) else ztsfc = 0. - call tsfcor(tsfanl,orog,slmask,ztsfc,len,rlapse) + call tsfcor(tsfanl,orog,slmskw,ztsfc,len,rlapse) endif ! if(lprnt) print *,' tsfaf=',tsfanl(iprnt) ! @@ -2214,37 +2242,45 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! if (mondif) then + 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), & + & vmnfcsd(len), vmxfcsd(len), slpfcsd(len), & + & absfcsd(len)) + allocate (smcfcsd(len,lsoil), stcfcsd(len,lsoil), & + & albfcsd(len,4)) do i=1,len - tsffcs(i) = tsfanl(i) - tsffcs(i) - snofcs(i) = snoanl(i) - snofcs(i) - tg3fcs(i) = tg3anl(i) - tg3fcs(i) - zorfcs(i) = zoranl(i) - zorfcs(i) + tsffcsd(i) = tsfanl(i) - tsffcs(i) + snofcsd(i) = snoanl(i) - snofcs(i) + tg3fcsd(i) = tg3anl(i) - tg3fcs(i) + zorfcsd(i) = zoranl(i) - zorfcs(i) ! plrfcs(i) = plranl(i) - plrfcs(i) ! albfcs(i) = albanl(i) - albfcs(i) - slifcs(i) = slianl(i) - slifcs(i) - aisfcs(i) = aisanl(i) - aisfcs(i) - cnpfcs(i) = cnpanl(i) - cnpfcs(i) - vegfcs(i) = veganl(i) - vegfcs(i) - vetfcs(i) = vetanl(i) - vetfcs(i) - sotfcs(i) = sotanl(i) - sotfcs(i) + slifcsd(i) = slianl(i) - slifcs(i) + aisfcsd(i) = aisanl(i) - aisfcs(i) + cnpfcsd(i) = cnpanl(i) - cnpfcs(i) + vegfcsd(i) = veganl(i) - vegfcs(i) + vetfcsd(i) = vetanl(i) - vetfcs(i) + sotfcsd(i) = sotanl(i) - sotfcs(i) !clu [+2l] add sih, sic - sihfcs(i) = sihanl(i) - sihfcs(i) - sicfcs(i) = sicanl(i) - sicfcs(i) + sihfcsd(i) = sihanl(i) - sihfcs(i) + sicfcsd(i) = sicanl(i) - sicfcs(i) !clu [+4l] add vmn, vmx, slp, abs - vmnfcs(i) = vmnanl(i) - vmnfcs(i) - vmxfcs(i) = vmxanl(i) - vmxfcs(i) - slpfcs(i) = slpanl(i) - slpfcs(i) - absfcs(i) = absanl(i) - absfcs(i) + vmnfcsd(i) = vmnanl(i) - vmnfcs(i) + vmxfcsd(i) = vmxanl(i) - vmxfcs(i) + slpfcsd(i) = slpanl(i) - slpfcs(i) + absfcsd(i) = absanl(i) - absfcs(i) enddo do j = 1,lsoil do i = 1,len - smcfcs(i,j) = smcanl(i,j) - smcfcs(i,j) - stcfcs(i,j) = stcanl(i,j) - stcfcs(i,j) + smcfcsd(i,j) = smcanl(i,j) - smcfcs(i,j) + stcfcsd(i,j) = stcanl(i,j) - stcfcs(i,j) enddo enddo do j = 1,4 do i = 1,len - albfcs(i,j) = albanl(i,j) - albfcs(i,j) + albfcsd(i,j) = albanl(i,j) - albfcs(i,j) enddo enddo ! @@ -2255,40 +2291,45 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & print *,'monitor of difference' print *,' (includes angulation correction)' print *,' ' - call monitr('tsfdif',tsffcs,slianl,snoanl,len) - call monitr('albdif',albfcs,slianl,snoanl,len) - call monitr('albdif1',albfcs,slianl,snoanl,len) - call monitr('albdif2',albfcs(1,2),slianl,snoanl,len) - call monitr('albdif3',albfcs(1,3),slianl,snoanl,len) - call monitr('albdif4',albfcs(1,4),slianl,snoanl,len) - call monitr('aisdif',aisfcs,slianl,snoanl,len) - call monitr('snodif',snofcs,slianl,snoanl,len) + call monitr('tsfdif', tsffcsd,slianl,snoanl,len) + call monitr('albdif', albfcsd,slianl,snoanl,len) + call monitr('albdif1',albfcsd,slianl,snoanl,len) + call monitr('albdif2',albfcsd(1,2),slianl,snoanl,len) + call monitr('albdif3',albfcsd(1,3),slianl,snoanl,len) + call monitr('albdif4',albfcsd(1,4),slianl,snoanl,len) + call monitr('aisdif', aisfcsd,slianl,snoanl,len) + call monitr('snodif', snofcsd,slianl,snoanl,len) do k=1,lsoil - call monitr(message('smcanl',k),smcfcs(1,k),slianl,snoanl,len) - call monitr(message('stcanl',k),stcfcs(1,k),slianl,snoanl,len) + call monitr(message('smcanl',k),smcfcsd(1,k),slianl,snoanl,len) + call monitr(message('stcanl',k),stcfcsd(1,k),slianl,snoanl,len) enddo - call monitr('tg3dif',tg3fcs,slianl,snoanl,len) - call monitr('zordif',zorfcs,slianl,snoanl,len) + call monitr('tg3dif',tg3fcsd,slianl,snoanl,len) + call monitr('zordif',zorfcsd,slianl,snoanl,len) ! if (gaus) then call monitr('cvadif',cvfcs ,slianl,snoanl,len) call monitr('cvbdif',cvbfcs,slianl,snoanl,len) call monitr('cvtdif',cvtfcs,slianl,snoanl,len) ! endif - call monitr('slidif',slifcs,slianl,snoanl,len) + call monitr('slidif',slifcsd,slianl,snoanl,len) ! call monitr('plrdif',plrfcs,slianl,snoanl,len) - call monitr('cnpdif',cnpfcs,slianl,snoanl,len) - call monitr('vegdif',vegfcs,slianl,snoanl,len) - call monitr('vetdif',vetfcs,slianl,snoanl,len) - call monitr('sotdif',sotfcs,slianl,snoanl,len) + call monitr('cnpdif',cnpfcsd,slianl,snoanl,len) + call monitr('vegdif',vegfcsd,slianl,snoanl,len) + call monitr('vetdif',vetfcsd,slianl,snoanl,len) + call monitr('sotdif',sotfcsd,slianl,snoanl,len) !cwu [+2l] add sih, sic - call monitr('sihdif',sihfcs,slianl,snoanl,len) - call monitr('sicdif',sicfcs,slianl,snoanl,len) + call monitr('sihdif',sihfcsd,slianl,snoanl,len) + call monitr('sicdif',sicfcsd,slianl,snoanl,len) !clu [+4l] add vmn, vmx, slp, abs - call monitr('vmndif',vmnfcs,slianl,snoanl,len) - call monitr('vmxdif',vmxfcs,slianl,snoanl,len) - call monitr('slpdif',slpfcs,slianl,snoanl,len) - call monitr('absdif',absfcs,slianl,snoanl,len) + call monitr('vmndif',vmnfcsd,slianl,snoanl,len) + call monitr('vmxdif',vmxfcsd,slianl,snoanl,len) + call monitr('slpdif',slpfcsd,slianl,snoanl,len) + call monitr('absdif',absfcsd,slianl,snoanl,len) endif + deallocate (tsffcsd, snofcsd, tg3fcsd, zorfcsd, slifcsd, & + & aisfcsd, cnpfcsd, vegfcsd, vetfcsd, sotfcsd, & + & sihfcsd, sicfcsd, vmnfcsd, vmxfcsd, slpfcsd, & + & absfcsd) + deallocate (smcfcsd, stcfcsd, albfcsd) endif ! ! @@ -2324,6 +2365,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif enddo enddo +! if(lprnt) print *,' stcfcs=',stcfcs(iprnt,:),'slifcs=', & +! & slifcs(iprnt) do j = 1,4 do i = 1,len albfcs(i,j) = albanl(i,j) @@ -2338,27 +2381,29 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & !cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points ! crit = aislim do i=1,len - sihfcs(i) = sihanl(i) - sitfcs(i) = tsffcs(i) - if (lake(i)) then - crit = min_lakeice - else - crit = min_seaice - endif - if (slifcs(i) >= 1.99_kind_io8) then - if (sicfcs(i) > crit) then - tem1 = 1.0_kind_io8 / sicfcs(i) - tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice) * tem1 - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 - sicfcs(i) = sicanl(i) + if (slmskw(i) == zero) then + crit = min_ice(i) + if (sicanl(i) >= crit) then + sihfcs(i) = sihanl(i) + sitfcs(i) = tsffcs(i) + if (sicfcs(i) >= crit) then + tem1 = 1.0_kind_io8 / sicfcs(i) + tsffcs(i) = (sicanl(i)*tsffcs(i) + & + (sicfcs(i)-sicanl(i))*tgice) * tem1 + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 + sicfcs(i) = sicanl(i) + else + tsffcs(i) = tgice + sitfcs(i) = tgice + sicfcs(i) = sicanl(i) + sihfcs(i) = sihnew + endif else tsffcs(i) = tsfanl(i) -! tsffcs(i) = tgice -! sihfcs(i) = sihnew - sihfcs(i) = 0.0_kind_io8 - sicfcs(i) = 0.0_kind_io8 - slifcs(i) = 0.0_kind_io8 + sihfcs(i) = zero + sicfcs(i) = zero + slifcs(i) = zero + sitfcs(i) = tsffcs(i) endif endif if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then @@ -2373,11 +2418,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! sicfcs(i) = 0.0_kind_io8 ! sitfcs(i) = tsffcs(i) ! else -! if (lake(i)) then -! crit = min_lakeice -! else -! crit = min_seaice -! endif +! crit = min_ice(i) ! if (sicfcs(i) < crit) then ! print *,'warning: check, slifcs and sicfcs', & ! & slifcs(i),sicfcs(i) @@ -2464,9 +2505,16 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & tsffcs(i) = min(tsffcs(i),273.15) endif enddo - end if + endif + do i=1,len + if (nint(slmskl(i)) == 1 .and. nint(slmskw(i)) == 0) then + slifcs(i) = slmskl(i) ! resetting slmsk to land value where land/wate/ice coexist + endif + enddo ! ! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) +! if(lprnt) print *,' stcfcsend=',stcfcs(iprnt,:) +! if(lprnt) print *,' slifcsend=',slifcs(iprnt) return end subroutine sfccycle @@ -3315,8 +3363,10 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& !cggg routine assign a default. if (num_threads == 1) then - print*,'no matching mask found ',i,i1,j1,ix,jx - print*,'set to default value.' + print*,'no matching mask found ',i,i1,j1,ix,jx & + &, ' slmask=',slmask(i),' me=',me & + &, ' outlon=',outlon(i),' outlat=',outlat(i) + &, 'set to default value.' endif gauout(i) = 0.0 @@ -3581,7 +3631,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & & slianl(len),scvanl(len),veganl(len), & & vetanl(len),sotanl(len),alfanl(len,2) & &, sihanl(len),sicanl(len) & - &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), & & snoclm(len), & & zorclm(len),albclm(len,4),aisclm(len), & @@ -3617,7 +3667,7 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & sicanl(i) = sicclm(i) ! sea ice concentration !clu [+4l] add vmn, vmx, slp, abs vmnanl(i) = vmnclm(i) ! min vegetation cover - vmxanl(i) = vmxclm(i) ! max vegetation cover + vmxanl(i) = vmxclm(i) ! max vegetation cover slpanl(i) = slpclm(i) ! slope type absanl(i) = absclm(i) ! max snow albedo enddo @@ -3643,8 +3693,8 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & end !>\ingroup mod_sfcsub - subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & - & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,& + 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, & & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs @@ -3674,7 +3724,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs real (kind=kind_io8) blto,blno,fh ! - real (kind=kind_io8) slmask(len) + real (kind=kind_io8) slmskl(len), slmskw(len) real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) integer kpdalb(4), kpdalf(2) @@ -3704,7 +3754,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irttsf = 1 if(fntsfa(1:8).ne.' ') then - call fixrda(lugb,fntsfa,kpdtsf,slmask, + call fixrda(lugb,fntsfa,kpdtsf,slmskw, & iy,im,id,ih,fh,tsfanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3731,7 +3781,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf0 ! if(fntsfa(1:8).ne.' ' .and. lanom) then - call fixrda(lugb,fntsfa,kpdtsf,slmask, + call fixrda(lugb,fntsfa,kpdtsf,slmskw, & iy,im,id,ih,0.,tsfan0,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3759,7 +3809,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtalb = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 4 - call fixrda(lugb,fnalba,kpdalb(kk),slmask, + call fixrda(lugb,fnalba,kpdalb(kk),slmskl, & iy,im,id,ih,fh,albanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3790,7 +3840,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtalf = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 2 - call fixrda(lugb,fnalba,kpdalf(kk),slmask, + call fixrda(lugb,fnalba,kpdalf(kk),slmskl, & iy,im,id,ih,fh,alfanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3821,7 +3871,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtwet=0 irtsmc=0 if(fnweta(1:8).ne.' ') then - call fixrda(lugb,fnweta,kpdwet,slmask, + call fixrda(lugb,fnweta,kpdwet,slmskl, & iy,im,id,ih,fh,wetanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3839,11 +3889,11 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'bucket wetness analysis provided.' endif elseif(fnsmca(1:8).ne.' ') then - call fixrda(lugb,fnsmca,kpdsmc,slmask, + call fixrda(lugb,fnsmca,kpdsmc,slmskl, & iy,im,id,ih,fh,smcanl(1,1),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - call fixrda(lugb,fnsmca,kpdsmc,slmask, + call fixrda(lugb,fnsmca,kpdsmc,slmskl, & iy,im,id,ih,fh,smcanl(1,2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3904,14 +3954,14 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & call abort endif if (kgds(1) == 4) then ! gaussian data is depth - call fixrda(lugb,fnsnoa,kpdsnd,slmask, + call fixrda(lugb,fnsnoa,kpdsnd,slmskl, & iy,im,id,ih,fh,snoanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - snoanl=snoanl*100. ! convert from meters to liq. eq. - ! depth in mm using 10:1 ratio + snoanl = snoanl*100. ! convert from meters to liq. eq. + ! depth in mm using 10:1 ratio else ! lat/lon data is liq equv. depth - call fixrda(lugb,fnsnoa,kpdsno,slmask, + call fixrda(lugb,fnsnoa,kpdsno,slmskl, & iy,im,id,ih,fh,snoanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3933,9 +3983,9 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtsno=0 elseif(fnscva(1:8).ne.' ') then do i=1,len - snoanl(i)=0. + snoanl(i) = 0. enddo - call fixrda(lugb,fnscva,kpdscv,slmask, + call fixrda(lugb,fnscva,kpdscv,slmskl, & iy,im,id,ih,fh,scvanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3964,7 +4014,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irtacn=0 irtais=0 if(fnacna(1:8).ne.' ') then - call fixrda(lugb,fnacna,kpdacn,slmask, + call fixrda(lugb,fnacna,kpdacn,slmskw, & iy,im,id,ih,fh,acnanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -3984,7 +4034,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'ice concentration analysis provided.' endif elseif(fnaisa(1:8).ne.' ') then - call fixrda(lugb,fnaisa,kpdais,slmask, + call fixrda(lugb,fnaisa,kpdais,slmskw, & iy,im,id,ih,fh,aisanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4012,7 +4062,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtzor=0 if(fnzora(1:8).ne.' ') then - call fixrda(lugb,fnzora,kpdzor,slmask, + call fixrda(lugb,fnzora,kpdzor,slmskl, & iy,im,id,ih,fh,zoranl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4041,7 +4091,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & irttg3=0 irtstc=0 if(fntg3a(1:8).ne.' ') then - call fixrda(lugb,fntg3a,kpdtg3,slmask, + call fixrda(lugb,fntg3a,kpdtg3,slmskl, & iy,im,id,ih,fh,tg3anl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4060,11 +4110,11 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) print *,'deep soil tmp analysis provided.' endif elseif(fnstca(1:8).ne.' ') then - call fixrda(lugb,fnstca,kpdstc,slmask, + call fixrda(lugb,fnstca,kpdstc,slmskl, & iy,im,id,ih,fh,stcanl(1,1),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - call fixrda(lugb,fnstca,kpdstc,slmask, + call fixrda(lugb,fnstca,kpdstc,slmskl, & iy,im,id,ih,fh,stcanl(1,2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4093,7 +4143,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtveg=0 if(fnvega(1:8).ne.' ') then - call fixrda(lugb,fnvega,kpdveg,slmask, + call fixrda(lugb,fnvega,kpdveg,slmskl, & iy,im,id,ih,fh,veganl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4123,7 +4173,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvet=0 if(fnveta(1:8).ne.' ') then - call fixrda(lugb,fnveta,kpdvet,slmask, + call fixrda(lugb,fnveta,kpdvet,slmskl, & iy,im,id,ih,fh,vetanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4153,7 +4203,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtsot=0 if(fnsota(1:8).ne.' ') then - call fixrda(lugb,fnsota,kpdsot,slmask, + call fixrda(lugb,fnsota,kpdsot,slmskl, & iy,im,id,ih,fh,sotanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4184,7 +4234,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvmn=0 if(fnvmna(1:8).ne.' ') then - call fixrda(lugb,fnvmna,kpdvmn,slmask, + call fixrda(lugb,fnvmna,kpdvmn,slmskl, & iy,im,id,ih,fh,vmnanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4214,7 +4264,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtvmx=0 if(fnvmxa(1:8).ne.' ') then - call fixrda(lugb,fnvmxa,kpdvmx,slmask, + call fixrda(lugb,fnvmxa,kpdvmx,slmskl, & iy,im,id,ih,fh,vmxanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4244,7 +4294,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtslp=0 if(fnslpa(1:8).ne.' ') then - call fixrda(lugb,fnslpa,kpdslp,slmask, + call fixrda(lugb,fnslpa,kpdslp,slmskl, & iy,im,id,ih,fh,slpanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4274,7 +4324,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! irtabs=0 if(fnabsa(1:8).ne.' ') then - call fixrda(lugb,fnabsa,kpdabs,slmask, + call fixrda(lugb,fnabsa,kpdabs,slmskl, & iy,im,id,ih,fh,absanl,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -4331,7 +4381,7 @@ subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & & slifcs(len),vegfcs(len), & & vetfcs(len),sotfcs(len),alffcs(len,2) & &, sihfcs(len),sicfcs(len) & - &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) + &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), & & zoranl(len),albanl(len,4),aisanl(len), & & tg3anl(len), & @@ -4470,21 +4520,14 @@ subroutine rof01(aisfld, len, op, crit) end !>\ingroup mod_sfcsub - subroutine rof01_len(aisfld, len, op, lake, critl, crits) + subroutine rof01_len(aisfld, len, op, crit) use machine , only : kind_io8,kind_io4 implicit none integer i,len - logical :: lake(len) - real (kind=kind_io8) aisfld(len), critl, crits, crit(len) + real (kind=kind_io8), intent(in) :: crit(len) + real (kind=kind_io8) aisfld(len) character*2 op ! - do i=1,len - if (lake(i)) then - crit(i) = critl - else - crit(i) = crits - endif - enddo if(op == 'ge') then do i=1,len if(aisfld(i) >= crit(i)) then @@ -4602,7 +4645,7 @@ end subroutine snodpth !>\ingroup mod_sfcsub !! This subroutine merges analysis and forecast. subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & - & sihfcs,sicfcs, & + & slmskl,slmskw,sihfcs,sicfcs, & & vmnfcs,vmxfcs,slpfcs,absfcs, & & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & & cvfcs ,cvbfcs,cvtfcs, & @@ -4626,7 +4669,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & & irtvet,irtsot,irtalf, landice, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : veg_type_landice, soil_type_landice, & - & num_threads + & num_threads, zero, one implicit none integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & @@ -4651,6 +4694,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns & &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss ! + real (kind=kind_io8) slmskl(len), slmskw(len) real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & & zorfcs(len), albfcs(len,4), aisfcs(len), & & cvfcs (len), cvbfcs(len), cvtfcs(len), & @@ -4835,8 +4879,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & if (me == 0) then write(6,100) rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl 100 format('rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl=',10f7.3) - write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs - 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs=',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 endif @@ -4914,7 +4958,7 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & i1_t = (it-1)*len_thread_m+1 i2_t = min(i1_t+len_thread_m-1,len) do i=i1_t,i2_t - if(slianl(i).eq.0.) then + if(slianl(i) == zero) then vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots else @@ -4932,7 +4976,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & i2_t = min(i1_t+len_thread_m-1,len) ! do i=i1_t,i2_t - if(slianl(i).eq.0.) then + if(slianl(i) == zero) then +! if(slmskw(i) == zero) then !.... tsffc2 is the previous anomaly + today's climatology ! tsffc2 = (tsffcs(i)-tsfan2(i))+tsfanl(i) ! tsfanl(i) = tsffc2 *rtsfs+tsfanl(i)*qtsfs @@ -4950,7 +4995,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & vmxanl(i) = vmxfcs(i)*rvmxs + vmxanl(i)*qvmxs slpanl(i) = slpfcs(i)*rslps + slpanl(i)*qslps absanl(i) = absfcs(i)*rabss + absanl(i)*qabss - else + endif + if(slmskl(i) == one .or. slianl(i) > zero) then tsfanl(i) = tsffcs(i)*rtsfl + tsfanl(i)*qtsfl ! albanl(i) = albfcs(i)*ralbl + albanl(i)*qalbl aisanl(i) = aisfcs(i)*raisl + aisanl(i)*qaisl @@ -5053,11 +5099,11 @@ end subroutine merge !>\ingroup mod_sfcsub subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & - & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl - & albanl,snoanl,zoranl,smcanl,stcanl, & - & albsea,snosea,zorsea,smcsea,smcice, & - & tsfmin,tsfice,albice,zorice,tgice, & - & rla,rlo,me) + & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl + & albanl,snoanl,zoranl,smcanl,stcanl, & + & albsea,snosea,zorsea,smcsea,smcice, & + & tsfmin,tsfice,albice,zorice,tgice, & + & rla,rlo,me) ! use machine , only : kind_io8,kind_io4 implicit none @@ -5081,8 +5127,8 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & kount1 = 0 kount2 = 0 do i=1,len - if(slifcs(i).ne.slianl(i)) then - if(slifcs(i).eq.1..or.slianl(i).eq.1.) then + if (nint(slifcs(i)) /= nint(slianl(i))) then + if (nint(slifcs(i)) == 1 .or. nint(slianl(i)) == 1) then print *,'FATAL ERROR: inconsistency in slifcs or slianl.' print 910,rla(i),rlo(i),slifcs(i),slianl(i), & tsffcs(i),tsfanl(i) @@ -5093,7 +5139,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & ! ! interpolated climatology indicates melted sea ice ! - if(slianl(i).eq.0..and.slifcs(i).eq.2.) then + if (nint(slianl(i)) == 0 .and. nint(slifcs(i)) == 2) then tsfanl(i) = tsfmin albanl(i,1) = albsea albanl(i,2) = albsea @@ -5114,7 +5160,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & ! ! interplated climatoloyg/analysis indicates new sea ice ! - if(slianl(i).eq.2..and.slifcs(i).eq.0.) then + if (nint(slianl(i)) == 2 .and. nint(slifcs(i)) == 0) then tsfanl(i) = tsfice albanl(i,1) = albice albanl(i,2) = albice @@ -5134,15 +5180,15 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & endif enddo ! - if (me .eq. 0) then - if(kount1.gt.0) then - write(6,*) 'sea ice melted. tsf,alb,zor are filled', - & ' at ',kount1,' points' - endif - if(kount2.gt.0) then - write(6,*) 'sea ice formed. tsf,alb,zor are filled', - & ' at ',kount2,' points' - endif + if (me == 0) then + if (kount1 > 0) then + write(6,*) 'sea ice melted. tsf,alb,zor are filled', + & ' at ',kount1,' points' + endif + if(kount2 > 0) then + write(6,*) 'sea ice formed. tsf,alb,zor are filled', + & ' at ',kount2,' points' + endif endif ! return @@ -5884,7 +5930,7 @@ subroutine albocn(albclm,slmask,albomx,len) real (kind=kind_io8) albomx real (kind=kind_io8) albclm(len,4), slmask(len) do i=1,len - if(slmask(i).eq.0) then + if(slmask(i) == 0) then albclm(i,1) = albomx albclm(i,2) = albomx albclm(i,3) = albomx @@ -6256,7 +6302,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6271,7 +6317,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6286,7 +6332,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6301,7 +6347,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6479,9 +6525,9 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & ! veg type is zero over water, use this to get a bitmap. else do j = 1, jmax - do i = 1, imax - rslmsk(i,j) = data(i,j) - enddo + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo enddo crit=0.1 call rof01(rslmsk,ijmax,'gt',crit) @@ -6542,7 +6588,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & do j = 1, jmax do i = 1, imax if (lbms(i,j)) then - rslmsk(i,j) = 1. + rslmsk(i,j) = 1. end if enddo enddo @@ -6877,8 +6923,8 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) end !>\ingroup mod_sfcsub - subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & - & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,& + 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, & & fnvmnc,fnvmxc,fnslpc,fnabsc, & @@ -6928,7 +6974,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) ! - real (kind=kind_io8) slmask(len), tsfcl0(len) + real (kind=kind_io8) slmskl(len), slmskw(len), tsfcl0(len) real (kind=kind_io8), allocatable :: slmask_noice(:) ! logical lanom, gaus, first @@ -7100,7 +7146,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & do nn=1,2 mon = mon1 if (nn == 2) mon = mon2 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7242,7 +7288,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 1 .or. ialb == 2) then !cbosu still need facsf and facwf. read them from the production file if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file - call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmskl &, alf,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7251,13 +7297,13 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & & kpdalf(1), alf(:,1), 1, len, me) endif else - call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmskl &, alf,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) endif do i = 1, len - if(slmask(i).eq.1.) then + if(slmskl(i) == 1.) then alf(i,2) = 100. - alf(i,1) endif enddo @@ -7267,7 +7313,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fntg3c(1:8).ne.' ') then if ( index(fntg3c, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmask, + call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmskl, & tg3,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7285,7 +7331,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnvetc(1:8).ne.' ') then if ( index(fnvetc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmask, + call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmskl, & vet,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7312,7 +7358,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnsotc(1:8).ne.' ') then if ( index(fnsotc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmask, + call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmskl, & sot,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7329,7 +7375,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnvmnc(1:8).ne.' ') then if ( index(fnvmnc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmask, + call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmskl, & vmn,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7346,7 +7392,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnvmxc(1:8).ne.' ') then if ( index(fnvmxc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmask, + call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmskl, & vmx,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7362,7 +7408,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnslpc(1:8).ne.' ') then if ( index(fnslpc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmask, + call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmskl, & slp,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7373,12 +7419,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (me .eq. 0) write(6,*) 'climatological slope read in.' endif ! -! max snow albeod +! max snow albedo ! if(fnabsc(1:8).ne.' ') then if ( index(fnabsc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmask, + call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmskl, & absm,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7392,20 +7438,20 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! is1 = sea1/3 + 1 is2 = sea2/3 + 1 - if (is1 .eq. 5) is1 = 1 - if (is2 .eq. 5) is2 = 1 + if (is1 == 5) is1 = 1 + if (is2 == 5) is2 = 1 do nn=1,2 ! ! seasonal mean climatology - if(nn.eq.1) then - isx=is1 + if(nn == 1) then + isx = is1 else - isx=is2 + isx = is2 endif - if(isx.eq.1) kpd9 = 12 - if(isx.eq.2) kpd9 = 3 - if(isx.eq.3) kpd9 = 6 - if(isx.eq.4) kpd9 = 9 + if(isx == 1) kpd9 = 12 + if(isx == 2) kpd9 = 3 + if(isx == 3) kpd9 = 6 + if(isx == 4) kpd9 = 9 ! ! seasonal mean climatology ! @@ -7417,7 +7463,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 0) then kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7434,7 +7480,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if ( index(fnalbc, "tileX.nc") == 0) then ! grib file kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7452,7 +7498,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf at the current time t ! kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7462,7 +7508,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! fh2 = fh - deltsfc ! if (fh2 .gt. 0.0) then -! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmask, +! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmskw, ! & iy,im,id,ih,fh2,tsfcl2,len,iret ! &, imsk, jmsk, slmskh, gaus,blno, blto ! &, outlat, outlon, me) @@ -7476,14 +7522,14 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnwetc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmskl, & wet(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) elseif(fnsmcc(1:8).ne.' ') then if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data kpd7=-1 - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmskl, & smc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7496,7 +7542,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! points. so for efficiency, don't have fixrdc try to ! find a value at landice points as defined by the vet type (vet). allocate(slmask_noice(len)) - slmask_noice=1.0 + slmask_noice = 1.0 do i = 1, len if (nint(vet(i)) < 1 .or. & nint(vet(i)) == landice_cat) then @@ -7525,7 +7571,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnstcc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmask, + call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmskl, & stc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7540,12 +7586,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! kpd7=-1 if(fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmskw, & acn(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) elseif(fnaisc(1:8).ne.' ') then - call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmskw, & ais(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7558,7 +7604,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! snow depth ! kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmskl, & sno(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7567,7 +7613,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if(fnscvc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmskl, & scv(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7586,7 +7632,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & endif else kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmskl, & zor(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7606,7 +7652,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if(fnvegc(1:8).ne.' ') then if ( index(fnvegc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmskl, & veg(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7655,7 +7701,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & k1 = mod(k2,2) + 1 mon = mon1s kpd7=-1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,k1),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7695,7 +7741,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (ialb == 0) then kpd7=-1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmskl &, alb(1,k,m2),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7722,7 +7768,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if ( index(fnalbc, "tileX.nc") == 0) then ! grib file kpd7 = -1 do k = 1, 4 - call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmskl, & alb(1,k,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7738,7 +7784,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! tsf at the current time t ! kpd7 = -1 - call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmskw, & tsf(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7747,14 +7793,14 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if (fnwetc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmskl, & wet(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) elseif (fnsmcc(1:8).ne.' ') then if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data kpd7=-1 - call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmskl, & smc(1,lsoil,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7796,12 +7842,12 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! kpd7 = -1 if (fnacnc(1:8).ne.' ') then - call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmskw, & acn(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) elseif (fnaisc(1:8).ne.' ') then - call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmskw, & ais(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7814,7 +7860,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! snow depth ! kpd7=-1 - call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmskl, & sno(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7823,7 +7869,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & ! if (fnscvc(1:8).ne.' ') then kpd7=-1 - call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmskl, & scv(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7842,7 +7888,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & endif else kpd7=-1 - call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmskl, & zor(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -7853,7 +7899,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & if (fnvegc(1:8) .ne. ' ') then if ( index(fnvegc, "tileX.nc") == 0) then ! grib file kpd7=-1 - call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmskl, & veg(1,nn),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) @@ -8368,8 +8414,8 @@ subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, & inttyp = 0 if(kpds5.eq.225) inttyp = 1 if(kpds5.eq.230) inttyp = 1 - if(kpds5.eq.236) inttyp = 1 - if(kpds5.eq.224) inttyp = 1 + if(kpds5.eq.236) inttyp = 1 + if(kpds5.eq.224) inttyp = 1 if (me .eq. 0) then if(inttyp.eq.1) print *, ' nearest grid point used' &, ' kpds5=',kpds5, ' lmask = ',lmask @@ -8401,7 +8447,7 @@ subroutine fixrda(lugb,fngrib,kpds5,slmask, & integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, & & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, & & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, & - & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint + & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, & & rjday,blto ! diff --git a/physics/shalcnv.meta b/physics/shalcnv.meta index 7986d28f8..68880b773 100644 --- a/physics/shalcnv.meta +++ b/physics/shalcnv.meta @@ -334,8 +334,8 @@ intent = in optional = F [ncloud] - standard_name = number_of_hydrometeors - long_name = number of hydrometeors + standard_name = number_of_cloud_condensate_types + long_name = number of cloud condensate types units = count dimensions = () type = integer @@ -351,8 +351,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 @@ -360,7 +360,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) diff --git a/physics/shinhongvdif.meta b/physics/shinhongvdif.meta index eed8fee71..566bed31d 100644 --- a/physics/shinhongvdif.meta +++ b/physics/shinhongvdif.meta @@ -265,8 +265,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 @@ -274,7 +274,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent) diff --git a/physics/ysuvdif.meta b/physics/ysuvdif.meta index ba3516f7d..d5ae29810 100644 --- a/physics/ysuvdif.meta +++ b/physics/ysuvdif.meta @@ -292,8 +292,8 @@ intent = in optional = F [heat] - standard_name = kinematic_surface_upward_sensible_heat_flux_reduced_by_surface_roughness - long_name = kinematic surface upward sensible heat flux + 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 @@ -301,7 +301,7 @@ intent = in optional = F [evap] - standard_name = kinematic_surface_upward_latent_heat_flux_reduced_by_surface_roughness + standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux units = kg kg-1 m s-1 dimensions = (horizontal_loop_extent)