From 59e91f9d6ef98fbfdc233443eac3bdb400ff905a Mon Sep 17 00:00:00 2001 From: "jun.wang" Date: Mon, 5 Mar 2018 14:21:49 +0000 Subject: [PATCH] FV3: this commits #refs 44997 --- atmos_cubed_sphere/model/fv_cmp.F90 | 2 +- atmos_cubed_sphere/model/fv_control.F90 | 6 +- atmos_cubed_sphere/model/fv_sg.F90 | 45 + atmos_cubed_sphere/model/fv_update_phys.F90 | 408 +-- atmos_cubed_sphere/tools/external_ic.F90 | 8 +- atmos_cubed_sphere/tools/fv_diagnostics.F90 | 18 +- atmos_cubed_sphere/tools/fv_iau_mod.F90 | 42 +- atmos_cubed_sphere/tools/fv_nggps_diag.F90 | 15 +- atmos_cubed_sphere/tools/fv_restart.F90 | 32 +- atmos_model.F90 | 78 +- configure | 2 +- fms/fms/fms_io.F90 | 28 +- fms/tracer_manager/tracer_manager.F90 | 2 +- fv3_cap.F90 | 27 +- gfsphysics/GFS_layer/GFS_driver.F90 | 138 +- gfsphysics/GFS_layer/GFS_physics_driver.F90 | 2739 ++++++++------ gfsphysics/GFS_layer/GFS_radiation_driver.F90 | 511 ++- gfsphysics/GFS_layer/GFS_typedefs.F90 | 865 +++-- gfsphysics/makefile | 4 +- gfsphysics/physics/cldmacro.F | 591 ++- gfsphysics/physics/cldwat2m_micro.F | 748 ++-- gfsphysics/physics/cs_conv.f90 | 2890 +++++++-------- gfsphysics/physics/gcm_shoc.f90 | 640 ++-- gfsphysics/physics/gfdl_cloud_microphys.F90 | 122 +- gfsphysics/physics/m_micro_driver.f90 | 484 ++- gfsphysics/physics/micro_mg2_0.F90 | 3231 +++++++++++++++++ gfsphysics/physics/micro_mg_utils.F90 | 1731 +++++++++ gfsphysics/physics/moninedmf.f | 40 +- gfsphysics/physics/moninshoc.f | 97 +- gfsphysics/physics/physcons.f90 | 9 +- gfsphysics/physics/radiation_clouds.f | 361 +- gfsphysics/physics/radlw_main.f | 26 +- gfsphysics/physics/radsw_main.f | 7 +- gfsphysics/physics/rascnvv2.f | 99 +- gfsphysics/physics/set_soilveg.f | 24 +- gfsphysics/physics/sfcsub.F | 128 +- gfsphysics/physics/sflx.f | 4 +- io/FV3GFS_io.F90 | 8 +- io/module_write_nemsio.F90 | 50 +- io/module_wrt_grid_comp.F90 | 2 +- module_fcst_grid_comp.F90 | 70 +- 41 files changed, 11151 insertions(+), 5181 deletions(-) create mode 100755 gfsphysics/physics/micro_mg2_0.F90 create mode 100755 gfsphysics/physics/micro_mg_utils.F90 diff --git a/atmos_cubed_sphere/model/fv_cmp.F90 b/atmos_cubed_sphere/model/fv_cmp.F90 index a1a4c16d6..1109663be 100644 --- a/atmos_cubed_sphere/model/fv_cmp.F90 +++ b/atmos_cubed_sphere/model/fv_cmp.F90 @@ -707,7 +707,7 @@ subroutine fv_sat_adj (mdt, zvir, is, ie, js, je, ng, hydrostatic, consv_te, & rh = qpz (i) / qstar (i) ! ----------------------------------------------------------------------- - ! icloud_f = 0: bug - fxied + ! icloud_f = 0: bug - fixed ! icloud_f = 1: old fvgfs gfdl) mp implementation ! icloud_f = 2: binary cloud scheme (0 / 1) ! ----------------------------------------------------------------------- diff --git a/atmos_cubed_sphere/model/fv_control.F90 b/atmos_cubed_sphere/model/fv_control.F90 index e7d693da8..5e56ac996 100644 --- a/atmos_cubed_sphere/model/fv_control.F90 +++ b/atmos_cubed_sphere/model/fv_control.F90 @@ -255,6 +255,7 @@ module fv_control_mod ! 2 for block ! 3 for four-interfaces non-block + ! version number of this module ! Include variable "version" to be written to log file. #include @@ -530,7 +531,7 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) real :: dim0 = 180. ! base dimension real :: dt0 = 1800. ! base time step real :: ns0 = 5. ! base nsplit for base dimension - ! For cubed sphere 5 is better + ! For cubed sphere 5 is better !real :: umax = 350. ! max wave speed for grid_type>3 ! Now defined above real :: dimx, dl, dp, dxmin, dymin, d_fac @@ -570,6 +571,7 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) namelist /test_case_nml/test_case, bubble_do, alpha, nsolitons, soliton_Umax, soliton_size + pe_counter = mpp_root_pe() ! Make alpha = 0 the default: @@ -613,7 +615,7 @@ subroutine run_setup(Atm, dt_atmos, grids_on_this_pe, p_split) #ifdef INTERNAL_FILE_NML ! Set input_file_nml for correct parent/nest initialization - if (n .gt. 1) then + if (n > 1) then write(nested_grid_filename,'(A4, I2.2)') 'nest', n call read_input_nml(nested_grid_filename) endif diff --git a/atmos_cubed_sphere/model/fv_sg.F90 b/atmos_cubed_sphere/model/fv_sg.F90 index 598a5b29d..293f17345 100644 --- a/atmos_cubed_sphere/model/fv_sg.F90 +++ b/atmos_cubed_sphere/model/fv_sg.F90 @@ -225,6 +225,13 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & cpm(i) = (1.-(q0(i,k,sphum)+q_liq))*cp_air + q0(i,k,sphum)*cp_vapor + q_liq*c_liq cvm(i) = (1.-(q0(i,k,sphum)+q_liq))*cv_air + q0(i,k,sphum)*cv_vap + q_liq*c_liq enddo + elseif ( nwat==5 ) then + do i=is,ie + q_liq = q0(i,k,liq_wat) + q0(i,k,rainwat) + q_sol = q0(i,k,ice_wat) + q0(i,k,snowwat) + cpm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cp_air + q0(i,k,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cv_air + q0(i,k,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice + enddo else do i=is,ie q_liq = q0(i,k,liq_wat) + q0(i,k,rainwat) @@ -285,6 +292,12 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & qcon(i,k) = q0(i,k,liq_wat) + q0(i,k,rainwat) enddo enddo + elseif ( nwat==5 ) then + do k=1,kbot + do i=is,ie + qcon(i,k) = q0(i,k,liq_wat)+q0(i,k,ice_wat)+q0(i,k,snowwat)+q0(i,k,rainwat) + enddo + enddo else do k=1,kbot do i=is,ie @@ -341,6 +354,9 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) elseif ( nwat==4 ) then ! K_warm_rain scheme with fake ice qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,rainwat) + elseif ( nwat==5 ) then ! K_warm_rain scheme with fake ice + qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) + & + q0(i,km1,snowwat) + q0(i,km1,rainwat) else qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) + & q0(i,km1,snowwat) + q0(i,km1,rainwat) + q0(i,km1,graupel) @@ -419,6 +435,13 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & cpm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cp_air + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq cvm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cv_air + q0(i,kk,sphum)*cv_vap + q_liq*c_liq enddo + elseif ( nwat == 5 ) then + do i=is,ie + q_liq = q0(i,kk,liq_wat) + q0(i,kk,rainwat) + q_sol = q0(i,kk,ice_wat) + q0(i,kk,snowwat) + cpm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cp_air + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cv_air + q0(i,kk,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice + enddo else do i=is,ie q_liq = q0(i,kk,liq_wat) + q0(i,kk,rainwat) @@ -643,6 +666,13 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & cpm(i) = (1.-(q0(i,k,sphum)+q_liq))*cp_air + q0(i,k,sphum)*cp_vapor + q_liq*c_liq cvm(i) = (1.-(q0(i,k,sphum)+q_liq))*cv_air + q0(i,k,sphum)*cv_vap + q_liq*c_liq enddo + elseif ( nwat==5 ) then + do i=is,ie + q_liq = q0(i,k,liq_wat) + q0(i,k,rainwat) + q_sol = q0(i,k,ice_wat) + q0(i,k,snowwat) + cpm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cp_air + q0(i,k,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,k,sphum)+q_liq+q_sol))*cv_air + q0(i,k,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice + enddo else do i=is,ie q_liq = q0(i,k,liq_wat) + q0(i,k,rainwat) @@ -703,6 +733,11 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & qcon(i,k) = q0(i,k,liq_wat) + q0(i,k,rainwat) enddo enddo + elseif ( nwat==5 ) then + do k=1,kbot + do i=is,ie + qcon(i,k) = q0(i,k,liq_wat)+q0(i,k,ice_wat)+q0(i,k,snowwat)+q0(i,k,rainwat) + enddo else do k=1,kbot do i=is,ie @@ -752,6 +787,9 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) elseif ( nwat==4 ) then ! K_warm_rain scheme with fake ice qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,rainwat) + elseif ( nwat==5 ) then + qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) + & + q0(i,km1,snowwat) + q0(i,km1,rainwat) else qcon(i,km1) = q0(i,km1,liq_wat) + q0(i,km1,ice_wat) + & q0(i,km1,snowwat) + q0(i,km1,rainwat) + q0(i,km1,graupel) @@ -830,6 +868,13 @@ subroutine fv_subgrid_z( isd, ied, jsd, jed, is, ie, js, je, km, nq, dt, & cpm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cp_air + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq cvm(i) = (1.-(q0(i,kk,sphum)+q_liq))*cv_air + q0(i,kk,sphum)*cv_vap + q_liq*c_liq enddo + elseif ( nwat == 5 ) then + do i=is,ie + q_liq = q0(i,kk,liq_wat) + q0(i,kk,rainwat) + q_sol = q0(i,kk,ice_wat) + q0(i,kk,snowwat) + cpm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cp_air + q0(i,kk,sphum)*cp_vapor + q_liq*c_liq + q_sol*c_ice + cvm(i) = (1.-(q0(i,kk,sphum)+q_liq+q_sol))*cv_air + q0(i,kk,sphum)*cv_vap + q_liq*c_liq + q_sol*c_ice + enddo else do i=is,ie q_liq = q0(i,kk,liq_wat) + q0(i,kk,rainwat) diff --git a/atmos_cubed_sphere/model/fv_update_phys.F90 b/atmos_cubed_sphere/model/fv_update_phys.F90 index c77da877f..2e2b0ac97 100644 --- a/atmos_cubed_sphere/model/fv_update_phys.F90 +++ b/atmos_cubed_sphere/model/fv_update_phys.F90 @@ -168,15 +168,15 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, !f1p conv_vmr_mmr(1:nq) = .false. if (flagstruct%adj_mass_vmr) then - do m=1,nq - call get_tracer_names (MODEL_ATMOS, m, name = tracer_name, & - units = tracer_units) - if ( trim(tracer_units) .eq. 'vmr' ) then + do m=1,nq + call get_tracer_names (MODEL_ATMOS, m, name = tracer_name, & + units = tracer_units) + if ( trim(tracer_units) .eq. 'vmr' ) then conv_vmr_mmr(m) = .true. - else + else conv_vmr_mmr(m) = .false. - end if - end do + end if + end do end if sphum = get_tracer_index (MODEL_ATMOS, 'sphum') @@ -201,15 +201,15 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, endif if ( flagstruct%fv_debug ) then - call prt_maxmin('delp_b_update', delp, is, ie, js, je, ng, npz, 0.01) - if (present(q_dt)) then - do m=1,nq + call prt_maxmin('delp_b_update', delp, is, ie, js, je, ng, npz, 0.01) + if (present(q_dt)) then + do m=1,nq call prt_maxmin('q_dt', q_dt(is,js,1,m), is, ie, js, je, 0, npz, 1.) - enddo - endif - call prt_maxmin('u_dt', u_dt, is, ie, js, je, ng, npz, 1.) - call prt_maxmin('v_dt', v_dt, is, ie, js, je, ng, npz, 1.) - call prt_maxmin('T_dt', t_dt, is, ie, js, je, 0, npz, 1.) + enddo + endif + call prt_maxmin('u_dt', u_dt, is, ie, js, je, ng, npz, 1.) + call prt_maxmin('v_dt', v_dt, is, ie, js, je, ng, npz, 1.) + call prt_maxmin('T_dt', t_dt, is, ie, js, je, 0, npz, 1.) endif call get_eta_level(npz, 1.0E5, pfull, phalf, ak, bk) @@ -223,9 +223,9 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, !$OMP private(cvm, qc, qstar, ps_dt, p_fac) do k=1, npz - if (present(q_dt)) then + if (present(q_dt)) then - if (flagstruct%tau_h2o<0.0 .and. pfull(k) < 100.E2 ) then + if (flagstruct%tau_h2o<0.0 .and. pfull(k) < 100.E2 ) then ! Wipe the stratosphere clean: ! This should only be used for initialization from a bad model state p_fac = -flagstruct%tau_h2o*86400. @@ -234,7 +234,7 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, q_dt(i,j,k,sphum) = q_dt(i,j,k,sphum) + (3.E-6-q(i,j,k,sphum))/p_fac enddo enddo - elseif ( flagstruct%tau_h2o>0.0 .and. pfull(k) < 3000. ) then + elseif ( flagstruct%tau_h2o>0.0 .and. pfull(k) < 3000. ) then ! Do idealized Ch4 chemistry if ( pfull(k) < 1. ) then @@ -262,26 +262,26 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, q_dt(i,j,k,sphum) = q_dt(i,j,k,sphum) + (qstar-q(i,j,k,sphum))/p_fac enddo enddo - endif + endif !---------------- ! Update tracers: !---------------- - do m=1,nq + do m=1,nq if( m /= w_diff ) then - do j=js,je - do i=is,ie + do j=js,je + do i=is,ie q(i,j,k,m) = q(i,j,k,m) + dt*q_dt(i,j,k,m) - enddo - enddo + enddo + enddo endif - enddo + enddo !-------------------------------------------------------- ! Adjust total air mass due to changes in water substance !-------------------------------------------------------- - do j=js,je - do i=is,ie + do j=js,je + do i=is,ie ps_dt(i,j) = 1. + dt*sum(q_dt(i,j,k,1:nwat)) delp(i,j,k) = delp(i,j,k) * ps_dt(i,j) if (flagstruct%adj_mass_vmr) then @@ -289,26 +289,26 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, (ps_dt(i,j) - sum(q(i,j,k,1:flagstruct%nwat))) / & (1.d0 - sum(q(i,j,k,1:flagstruct%nwat))) end if - enddo - enddo + enddo + enddo !----------------------------------------- ! Adjust mass mixing ratio of all tracers !----------------------------------------- - if ( nwat /=0 ) then - do m=1,flagstruct%ncnst + if ( nwat /=0 ) then + do m=1,flagstruct%ncnst !-- check to query field_table to determine if tracer needs mass adjustment - if( m /= cld_amt .and. m /= w_diff .and. adjust_mass(MODEL_ATMOS,m)) then - if (m <= nq) then - q(is:ie,js:je,k,m) = q(is:ie,js:je,k,m) / ps_dt(is:ie,js:je) - if (conv_vmr_mmr(m)) & + if( m /= cld_amt .and. m /= w_diff .and. adjust_mass(MODEL_ATMOS,m)) then + if (m <= nq) then + q(is:ie,js:je,k,m) = q(is:ie,js:je,k,m) / ps_dt(is:ie,js:je) + if (conv_vmr_mmr(m)) & q(is:ie,js:je,k,m) = q(is:ie,js:je,k,m) * adj_vmr(is:ie,js:je,k) - else - qdiag(is:ie,js:je,k,m) = qdiag(is:ie,js:je,k,m) / ps_dt(is:ie,js:je) + else + qdiag(is:ie,js:je,k,m) = qdiag(is:ie,js:je,k,m) / ps_dt(is:ie,js:je) + endif endif - endif - enddo - endif + enddo + endif endif ! present(q_dt) @@ -320,8 +320,8 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, !!! pt(i,j,k) = pt(i,j,k) + t_dt(i,j,k)*dt pt(i,j,k) = pt(i,j,k) + t_dt(i,j,k)*dt*con_cp/cvm(i) enddo - enddo - else + enddo + else if ( flagstruct%phys_hydrostatic ) then ! Constant pressure do j=js,je @@ -377,10 +377,10 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, ! All fields will be updated; tendencies added !-------------------------------------------- call get_atmos_nudge ( Time, dt, is, ie, js, je, & - npz, ng, ps(is:ie,js:je), ua(is:ie, js:je,:), & - va(is:ie,js:je,:), pt(is:ie,js:je,:), & + npz, ng, ps(is:ie,js:je), ua(is:ie, js:je,:), & + va(is:ie,js:je,:), pt(is:ie,js:je,:), & q(is:ie,js:je,:,:), ps_dt(is:ie,js:je), u_dt(is:ie,js:je,:), & - v_dt(is:ie,js:je,:), t_dt(is:ie,js:je,:), & + v_dt(is:ie,js:je,:), t_dt(is:ie,js:je,:), & q_dt(is:ie,js:je,:,:) ) !-------------- @@ -428,14 +428,14 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, ! All fields will be updated except winds; wind tendencies added !$omp parallel do default(shared) do j=js,je - do k=2,npz+1 + do k=2,npz+1 + do i=is,ie + pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) + enddo + enddo do i=is,ie - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) + ps(i,j) = pe(i,npz+1,j) enddo - enddo - do i=is,ie - ps(i,j) = pe(i,npz+1,j) - enddo enddo call fv_ada_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, & zvir, ptop, ak, bk, ts, ps, delp, ua, va, pt, & @@ -444,14 +444,14 @@ subroutine fv_update_phys ( dt, is, ie, js, je, isd, ied, jsd, jed, ng, nq, ! All fields will be updated except winds; wind tendencies added !$OMP parallel do default(none) shared(is,ie,js,je,npz,pe,delp,ps) do j=js,je - do k=2,npz+1 + do k=2,npz+1 + do i=is,ie + pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) + enddo + enddo do i=is,ie - pe(i,k,j) = pe(i,k-1,j) + delp(i,j,k-1) + ps(i,j) = pe(i,npz+1,j) enddo - enddo - do i=is,ie - ps(i,j) = pe(i,npz+1,j) - enddo enddo call fv_nwp_nudge ( Time, dt, npx, npy, npz, ps_dt, u_dt, v_dt, t_dt, q_dt, & zvir, ptop, ak, bk, ts, ps, delp, ua, va, pt, & @@ -656,22 +656,22 @@ subroutine update_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt ! Purpose; Transform wind tendencies on A grid to D grid for the final update - integer, intent(in):: is, ie, js, je - integer, intent(in):: isd, ied, jsd, jed + integer, intent(in) :: is, ie, js, je + integer, intent(in) :: isd, ied, jsd, jed integer, intent(IN) :: npx,npy, npz - real, intent(in):: dt - real, intent(inout):: u(isd:ied, jsd:jed+1,npz) - real, intent(inout):: v(isd:ied+1,jsd:jed ,npz) + real, intent(in) :: dt + real, intent(inout) :: u(isd:ied, jsd:jed+1,npz) + real, intent(inout) :: v(isd:ied+1,jsd:jed ,npz) real, intent(inout), dimension(isd:ied,jsd:jed,npz):: u_dt, v_dt type(fv_grid_type), intent(IN), target :: gridstruct type(domain2d), intent(INOUT) :: domain ! local: real v3(is-1:ie+1,js-1:je+1,3) - real ue(is-1:ie+1,js:je+1,3) ! 3D winds at edges + real ue(is-1:ie+1,js:je+1,3) ! 3D winds at edges real ve(is:ie+1,js-1:je+1, 3) ! 3D winds at edges - real, dimension(is:ie):: ut1, ut2, ut3 - real, dimension(js:je):: vt1, vt2, vt3 + real, dimension(is:ie) :: ut1, ut2, ut3 + real, dimension(js:je) :: vt1, vt2, vt3 real dt5, gratio integer i, j, k, m, im2, jm2 @@ -699,138 +699,138 @@ subroutine update_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_dt !$OMP private(ut1, ut2, ut3, vt1, vt2, vt3, ue, ve, v3) do k=1, npz - if ( gridstruct%grid_type > 3 ) then ! Local & one tile configurations + if ( gridstruct%grid_type > 3 ) then ! Local & one tile configurations - do j=js,je+1 + do j=js,je+1 do i=is,ie u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k)) enddo - enddo - do j=js,je + enddo + do j=js,je do i=is,ie+1 v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k) + v_dt(i,j,k)) enddo - enddo + enddo - else + else ! Compute 3D wind tendency on A grid - do j=js-1,je+1 + do j=js-1,je+1 do i=is-1,ie+1 v3(i,j,1) = u_dt(i,j,k)*vlon(i,j,1) + v_dt(i,j,k)*vlat(i,j,1) v3(i,j,2) = u_dt(i,j,k)*vlon(i,j,2) + v_dt(i,j,k)*vlat(i,j,2) v3(i,j,3) = u_dt(i,j,k)*vlon(i,j,3) + v_dt(i,j,k)*vlat(i,j,3) enddo - enddo + enddo ! Interpolate to cell edges - do j=js,je+1 + do j=js,je+1 do i=is-1,ie+1 ue(i,j,1) = v3(i,j-1,1) + v3(i,j,1) ue(i,j,2) = v3(i,j-1,2) + v3(i,j,2) ue(i,j,3) = v3(i,j-1,3) + v3(i,j,3) enddo - enddo + enddo - do j=js-1,je+1 + do j=js-1,je+1 do i=is,ie+1 ve(i,j,1) = v3(i-1,j,1) + v3(i,j,1) ve(i,j,2) = v3(i-1,j,2) + v3(i,j,2) ve(i,j,3) = v3(i-1,j,3) + v3(i,j,3) enddo - enddo + enddo ! --- E_W edges (for v-wind): - if ( is==1 .and. .not. gridstruct%nested ) then - i = 1 - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_w(j)*ve(i,j-1,1)+(1.-edge_vect_w(j))*ve(i,j,1) - vt2(j) = edge_vect_w(j)*ve(i,j-1,2)+(1.-edge_vect_w(j))*ve(i,j,2) - vt3(j) = edge_vect_w(j)*ve(i,j-1,3)+(1.-edge_vect_w(j))*ve(i,j,3) - else - vt1(j) = edge_vect_w(j)*ve(i,j+1,1)+(1.-edge_vect_w(j))*ve(i,j,1) - vt2(j) = edge_vect_w(j)*ve(i,j+1,2)+(1.-edge_vect_w(j))*ve(i,j,2) - vt3(j) = edge_vect_w(j)*ve(i,j+1,3)+(1.-edge_vect_w(j))*ve(i,j,3) + if ( is==1 .and. .not. gridstruct%nested ) then + i = 1 + do j=js,je + if ( j>jm2 ) then + vt1(j) = edge_vect_w(j)*ve(i,j-1,1) + (1.-edge_vect_w(j))*ve(i,j,1) + vt2(j) = edge_vect_w(j)*ve(i,j-1,2) + (1.-edge_vect_w(j))*ve(i,j,2) + vt3(j) = edge_vect_w(j)*ve(i,j-1,3) + (1.-edge_vect_w(j))*ve(i,j,3) + else + vt1(j) = edge_vect_w(j)*ve(i,j+1,1) + (1.-edge_vect_w(j))*ve(i,j,1) + vt2(j) = edge_vect_w(j)*ve(i,j+1,2) + (1.-edge_vect_w(j))*ve(i,j,2) + vt3(j) = edge_vect_w(j)*ve(i,j+1,3) + (1.-edge_vect_w(j))*ve(i,j,3) + endif + enddo + do j=js,je + ve(i,j,1) = vt1(j) + ve(i,j,2) = vt2(j) + ve(i,j,3) = vt3(j) + enddo endif - enddo - do j=js,je - ve(i,j,1) = vt1(j) - ve(i,j,2) = vt2(j) - ve(i,j,3) = vt3(j) - enddo - endif - if ( (ie+1)==npx .and. .not. gridstruct%nested ) then - i = npx - do j=js,je - if ( j>jm2 ) then - vt1(j) = edge_vect_e(j)*ve(i,j-1,1)+(1.-edge_vect_e(j))*ve(i,j,1) - vt2(j) = edge_vect_e(j)*ve(i,j-1,2)+(1.-edge_vect_e(j))*ve(i,j,2) - vt3(j) = edge_vect_e(j)*ve(i,j-1,3)+(1.-edge_vect_e(j))*ve(i,j,3) - else - vt1(j) = edge_vect_e(j)*ve(i,j+1,1)+(1.-edge_vect_e(j))*ve(i,j,1) - vt2(j) = edge_vect_e(j)*ve(i,j+1,2)+(1.-edge_vect_e(j))*ve(i,j,2) - vt3(j) = edge_vect_e(j)*ve(i,j+1,3)+(1.-edge_vect_e(j))*ve(i,j,3) + if ( (ie+1)==npx .and. .not. gridstruct%nested ) then + i = npx + do j=js,je + if ( j>jm2 ) then + vt1(j) = edge_vect_e(j)*ve(i,j-1,1) + (1.-edge_vect_e(j))*ve(i,j,1) + vt2(j) = edge_vect_e(j)*ve(i,j-1,2) + (1.-edge_vect_e(j))*ve(i,j,2) + vt3(j) = edge_vect_e(j)*ve(i,j-1,3) + (1.-edge_vect_e(j))*ve(i,j,3) + else + vt1(j) = edge_vect_e(j)*ve(i,j+1,1) + (1.-edge_vect_e(j))*ve(i,j,1) + vt2(j) = edge_vect_e(j)*ve(i,j+1,2) + (1.-edge_vect_e(j))*ve(i,j,2) + vt3(j) = edge_vect_e(j)*ve(i,j+1,3) + (1.-edge_vect_e(j))*ve(i,j,3) + endif + enddo + do j=js,je + ve(i,j,1) = vt1(j) + ve(i,j,2) = vt2(j) + ve(i,j,3) = vt3(j) + enddo endif - enddo - do j=js,je - ve(i,j,1) = vt1(j) - ve(i,j,2) = vt2(j) - ve(i,j,3) = vt3(j) - enddo - endif ! N-S edges (for u-wind): - if ( js==1 .and. .not. gridstruct%nested) then - j = 1 - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_s(i)*ue(i-1,j,1)+(1.-edge_vect_s(i))*ue(i,j,1) - ut2(i) = edge_vect_s(i)*ue(i-1,j,2)+(1.-edge_vect_s(i))*ue(i,j,2) - ut3(i) = edge_vect_s(i)*ue(i-1,j,3)+(1.-edge_vect_s(i))*ue(i,j,3) - else - ut1(i) = edge_vect_s(i)*ue(i+1,j,1)+(1.-edge_vect_s(i))*ue(i,j,1) - ut2(i) = edge_vect_s(i)*ue(i+1,j,2)+(1.-edge_vect_s(i))*ue(i,j,2) - ut3(i) = edge_vect_s(i)*ue(i+1,j,3)+(1.-edge_vect_s(i))*ue(i,j,3) + if ( js==1 .and. .not. gridstruct%nested) then + j = 1 + do i=is,ie + if ( i>im2 ) then + ut1(i) = edge_vect_s(i)*ue(i-1,j,1) + (1.-edge_vect_s(i))*ue(i,j,1) + ut2(i) = edge_vect_s(i)*ue(i-1,j,2) + (1.-edge_vect_s(i))*ue(i,j,2) + ut3(i) = edge_vect_s(i)*ue(i-1,j,3) + (1.-edge_vect_s(i))*ue(i,j,3) + else + ut1(i) = edge_vect_s(i)*ue(i+1,j,1) + (1.-edge_vect_s(i))*ue(i,j,1) + ut2(i) = edge_vect_s(i)*ue(i+1,j,2) + (1.-edge_vect_s(i))*ue(i,j,2) + ut3(i) = edge_vect_s(i)*ue(i+1,j,3) + (1.-edge_vect_s(i))*ue(i,j,3) + endif + enddo + do i=is,ie + ue(i,j,1) = ut1(i) + ue(i,j,2) = ut2(i) + ue(i,j,3) = ut3(i) + enddo endif - enddo - do i=is,ie - ue(i,j,1) = ut1(i) - ue(i,j,2) = ut2(i) - ue(i,j,3) = ut3(i) - enddo - endif - if ( (je+1)==npy .and. .not. gridstruct%nested) then - j = npy - do i=is,ie - if ( i>im2 ) then - ut1(i) = edge_vect_n(i)*ue(i-1,j,1)+(1.-edge_vect_n(i))*ue(i,j,1) - ut2(i) = edge_vect_n(i)*ue(i-1,j,2)+(1.-edge_vect_n(i))*ue(i,j,2) - ut3(i) = edge_vect_n(i)*ue(i-1,j,3)+(1.-edge_vect_n(i))*ue(i,j,3) - else - ut1(i) = edge_vect_n(i)*ue(i+1,j,1)+(1.-edge_vect_n(i))*ue(i,j,1) - ut2(i) = edge_vect_n(i)*ue(i+1,j,2)+(1.-edge_vect_n(i))*ue(i,j,2) - ut3(i) = edge_vect_n(i)*ue(i+1,j,3)+(1.-edge_vect_n(i))*ue(i,j,3) + if ( (je+1)==npy .and. .not. gridstruct%nested) then + j = npy + do i=is,ie + if ( i>im2 ) then + ut1(i) = edge_vect_n(i)*ue(i-1,j,1) + (1.-edge_vect_n(i))*ue(i,j,1) + ut2(i) = edge_vect_n(i)*ue(i-1,j,2) + (1.-edge_vect_n(i))*ue(i,j,2) + ut3(i) = edge_vect_n(i)*ue(i-1,j,3) + (1.-edge_vect_n(i))*ue(i,j,3) + else + ut1(i) = edge_vect_n(i)*ue(i+1,j,1) + (1.-edge_vect_n(i))*ue(i,j,1) + ut2(i) = edge_vect_n(i)*ue(i+1,j,2) + (1.-edge_vect_n(i))*ue(i,j,2) + ut3(i) = edge_vect_n(i)*ue(i+1,j,3) + (1.-edge_vect_n(i))*ue(i,j,3) + endif + enddo + do i=is,ie + ue(i,j,1) = ut1(i) + ue(i,j,2) = ut2(i) + ue(i,j,3) = ut3(i) + enddo endif - enddo - do i=is,ie - ue(i,j,1) = ut1(i) - ue(i,j,2) = ut2(i) - ue(i,j,3) = ut3(i) - enddo - endif - do j=js,je+1 + do j=js,je+1 do i=is,ie u(i,j,k) = u(i,j,k) + dt5*( ue(i,j,1)*es(1,i,j,1) + & ue(i,j,2)*es(2,i,j,1) + & ue(i,j,3)*es(3,i,j,1) ) enddo - enddo - do j=js,je + enddo + do j=js,je do i=is,ie+1 v(i,j,k) = v(i,j,k) + dt5*( ve(i,j,1)*ew(1,i,j,2) + & ve(i,j,2)*ew(2,i,j,2) + & ve(i,j,3)*ew(3,i,j,2) ) enddo - enddo + enddo ! Update: endif ! end grid_type @@ -906,79 +906,79 @@ subroutine update2d_dwinds_phys(is, ie, js, je, isd, ied, jsd, jed, dt, u_dt, v_ !$OMP private(gratio) do k=1, npz - if ( gridstruct%grid_type > 3 .or. gridstruct%nested) then ! Local & one tile configurations + if ( gridstruct%grid_type > 3 .or. gridstruct%nested) then ! Local & one tile configurations - do j=js,je+1 - do i=is,ie - u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k)) - enddo - enddo - do j=js,je - do i=is,ie+1 + do j=js,je+1 + do i=is,ie + u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k) + u_dt(i,j,k)) + enddo + enddo + do j=js,je + do i=is,ie+1 v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k) + v_dt(i,j,k)) - enddo - enddo + enddo + enddo - else + else !-------- ! u-wind !-------- ! Edges: - if ( js==1 ) then - do i=is,ie - gratio = dya(i,2) / dya(i,1) - u(i,1,k) = u(i,1,k) + dt5*((2.+gratio)*(u_dt(i,0,k)+u_dt(i,1,k)) & - -(u_dt(i,-1,k)+u_dt(i,2,k)))/(1.+gratio) - enddo - endif + if ( js==1 ) then + do i=is,ie + gratio = dya(i,2) / dya(i,1) + u(i,1,k) = u(i,1,k) + dt5*((2.+gratio)*(u_dt(i,0,k)+u_dt(i,1,k)) & + -(u_dt(i,-1,k)+u_dt(i,2,k)))/(1.+gratio) + enddo + endif ! Interior - do j=max(2,js),min(npy-1,je+1) - do i=is,ie - u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k)+u_dt(i,j,k)) - enddo - enddo + do j=max(2,js),min(npy-1,je+1) + do i=is,ie + u(i,j,k) = u(i,j,k) + dt5*(u_dt(i,j-1,k)+u_dt(i,j,k)) + enddo + enddo - if ( (je+1)==npy ) then - do i=is,ie - gratio = dya(i,npy-2) / dya(i,npy-1) - u(i,npy,k) = u(i,npy,k) + dt5*((2.+gratio)*(u_dt(i,npy-1,k)+u_dt(i,npy,k)) & - -(u_dt(i,npy-2,k)+u_dt(i,npy+1,k)))/(1.+gratio) - enddo - endif + if ( (je+1)==npy ) then + do i=is,ie + gratio = dya(i,npy-2) / dya(i,npy-1) + u(i,npy,k) = u(i,npy,k) + dt5*((2.+gratio)*(u_dt(i,npy-1,k)+u_dt(i,npy,k)) & + -(u_dt(i,npy-2,k)+u_dt(i,npy+1,k)))/(1.+gratio) + enddo + endif !-------- ! v-wind !-------- ! West Edges: - if ( is==1 ) then - do j=js,je - gratio = dxa(2,j) / dxa(1,j) - v(1,j,k) = v(1,j,k) + dt5*((2.+gratio)*(v_dt(0,j,k)+v_dt(1,j,k)) & - -(v_dt(-1,j,k)+v_dt(2,j,k)))/(1.+gratio) - enddo - endif + if ( is==1 ) then + do j=js,je + gratio = dxa(2,j) / dxa(1,j) + v(1,j,k) = v(1,j,k) + dt5*((2.+gratio)*(v_dt(0,j,k)+v_dt(1,j,k)) & + -(v_dt(-1,j,k)+v_dt(2,j,k)))/(1.+gratio) + enddo + endif ! Interior - do j=js,je - do i=max(2,is),min(npx-1,ie+1) - v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k)+v_dt(i,j,k)) - enddo - enddo + do j=js,je + do i=max(2,is),min(npx-1,ie+1) + v(i,j,k) = v(i,j,k) + dt5*(v_dt(i-1,j,k)+v_dt(i,j,k)) + enddo + enddo ! East Edges: - if ( (ie+1)==npx ) then - do j=js,je - gratio = dxa(npx-2,j) / dxa(npx-1,j) - v(npx,j,k) = v(npx,j,k) + dt5*((2.+gratio)*(v_dt(npx-1,j,k)+v_dt(npx,j,k)) & - -(v_dt(npx-2,j,k)+v_dt(npx+1,j,k)))/(1.+gratio) - enddo - endif + if ( (ie+1)==npx ) then + do j=js,je + gratio = dxa(npx-2,j) / dxa(npx-1,j) + v(npx,j,k) = v(npx,j,k) + dt5*((2.+gratio)*(v_dt(npx-1,j,k)+v_dt(npx,j,k)) & + -(v_dt(npx-2,j,k)+v_dt(npx+1,j,k)))/(1.+gratio) + enddo + endif - endif ! end grid_type + endif ! end grid_type - enddo ! k-loop + enddo ! k-loop end subroutine update2d_dwinds_phys diff --git a/atmos_cubed_sphere/tools/external_ic.F90 b/atmos_cubed_sphere/tools/external_ic.F90 index 2502264aa..6425136e8 100644 --- a/atmos_cubed_sphere/tools/external_ic.F90 +++ b/atmos_cubed_sphere/tools/external_ic.F90 @@ -336,7 +336,7 @@ subroutine get_nggps_ic (Atm, fv_domain) real(kind=R_GRID), dimension(2):: p1, p2, p3 real(kind=R_GRID), dimension(3):: e1, e2, ex, ey integer:: i,j,k,nts, ks - integer:: liq_wat, ice_wat, rainwat, snowwat, graupel + integer:: liq_wat, ice_wat, rainwat, snowwat, graupel, ntclamt namelist /external_ic_nml/ filtered_terrain, levp, gfs_dwinds, & checker_tr, nt_checker #ifdef GFSL64 @@ -676,7 +676,7 @@ subroutine get_nggps_ic (Atm, fv_domain) endif endif ! call vertical remapping algorithms - if(is_master()) write(*,*) 'GFS ak(1)=', ak(1), ' ak(2)=', ak(2) + if(is_master()) write(*,*) 'GFS ak =', ak,' FV3 ak=',Atm(n)%ak ak(1) = max(1.e-9, ak(1)) call remap_scalar_nggps(Atm(n), levp, npz, ntracers, ak, bk, ps, q, omga, zh) @@ -785,13 +785,14 @@ subroutine get_nggps_ic (Atm, fv_domain) rainwat = get_tracer_index(MODEL_ATMOS, 'rainwat') snowwat = get_tracer_index(MODEL_ATMOS, 'snowwat') graupel = get_tracer_index(MODEL_ATMOS, 'graupel') + ntclamt = get_tracer_index(MODEL_ATMOS, 'cld_amt') !--- Add cloud condensate from GFS to total MASS ! 20160928: Adjust the mixing ratios consistently... do k=1,npz do j=js,je do i=is,ie wt = Atm(n)%delp(i,j,k) - if ( Atm(n)%flagstruct%nwat .eq. 6 ) then + if ( Atm(n)%flagstruct%nwat == 6 ) then qt = wt*(1. + Atm(n)%q(i,j,k,liq_wat) + & Atm(n)%q(i,j,k,ice_wat) + & Atm(n)%q(i,j,k,rainwat) + & @@ -805,6 +806,7 @@ subroutine get_nggps_ic (Atm, fv_domain) Atm(n)%q(i,j,k,iq) = m_fac * Atm(n)%q(i,j,k,iq) enddo Atm(n)%delp(i,j,k) = qt + if (ntclamt > 0) Atm(n)%q(i,j,k,ntclamt) = 0.0 ! Moorthi enddo enddo enddo diff --git a/atmos_cubed_sphere/tools/fv_diagnostics.F90 b/atmos_cubed_sphere/tools/fv_diagnostics.F90 index 39af7c1ee..2e6b0bad5 100644 --- a/atmos_cubed_sphere/tools/fv_diagnostics.F90 +++ b/atmos_cubed_sphere/tools/fv_diagnostics.F90 @@ -1982,7 +1982,7 @@ subroutine fv_diag(Atm, zvir, Time, print_freq) do k=1,npz do j=jsc,jec do i=isc,iec -! a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,1)*Atm(n)%delp(i,j,k) +! a2(i,j) = a2(i,j) + Atm(n)%q(i,j,k,1)*Atm(n)%delp(i,j,k) a2(i,j) = a2(i,j) + sum(Atm(n)%q(i,j,k,1:nwater))*Atm(n)%delp(i,j,k) enddo enddo @@ -4633,12 +4633,12 @@ subroutine dbzcalc(q, pt, delp, peln, delz, & !Other constants real, parameter :: gamma_seven = 720. !The following values are also used in GFDL MP - real, parameter :: rho_r = 1.0e3 ! LFO83 - real, parameter :: rho_s = 100. ! kg m^-3 + real, parameter :: rho_r = 1.0e3 ! LFO83 + real, parameter :: rho_s = 100. ! kg m^-3 real, parameter :: rho_g0 = 400. ! kg m^-3 - real, parameter :: rho_g = 500. ! graupel-hail mix -! real, parameter :: rho_g = 900. ! hail/frozen rain - real, parameter :: alpha = 0.224 + real, parameter :: rho_g = 500. ! graupel-hail mix +! real, parameter :: rho_g = 900. ! hail/frozen rain + real, parameter :: alpha = 0.224 real(kind=R_GRID), parameter :: factor_r = gamma_seven * 1.e18 * (1./(pi*rho_r))**1.75 real(kind=R_GRID), parameter :: factor_s = gamma_seven * 1.e18 * (1./(pi*rho_s))**1.75 & * (rho_s/rho_r)**2 * alpha @@ -4773,7 +4773,11 @@ subroutine dbzcalc(q, pt, delp, peln, delz, & ! Account for excessively high cloud water -> autoconvert (diag only) excess cloud water t1 = rhoair(i)*max(qmin, q(i,j,k,rainwat)+dim(q(i,j,k,liq_wat), 1.0e-3)) t2 = rhoair(i)*max(qmin, q(i,j,k,snowwat)) - t3 = rhoair(i)*max(qmin, q(i,j,k,graupel)) + if (graupel > 0) then + t3 = rhoair(i)*max(qmin, q(i,j,k,graupel)) + else + t3 = rhoair(i)*qmin + endif denfac = sqrt(min(10., 1.2/rhoair(i))) vtr = max(1.e-3, vconr*denfac*exp(0.2 *log(t1/normr))) vtg = max(1.e-3, vcong*denfac*exp(0.125 *log(t3/normg))) diff --git a/atmos_cubed_sphere/tools/fv_iau_mod.F90 b/atmos_cubed_sphere/tools/fv_iau_mod.F90 index d63ef42d2..28c9cdf3c 100644 --- a/atmos_cubed_sphere/tools/fv_iau_mod.F90 +++ b/atmos_cubed_sphere/tools/fv_iau_mod.F90 @@ -15,28 +15,28 @@ module fv_iau_mod - use fms_mod, only: file_exist - use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe - use mpp_domains_mod, only: domain2d - - use constants_mod, only: pi=>pi_8 - use fv_arrays_mod, only: fv_atmos_type, & - fv_grid_type, & - fv_grid_bounds_type, & - R_GRID - use fv_mp_mod, only: is_master - use sim_nc_mod, only: open_ncfile, & - close_ncfile, & - get_ncdim1, & - get_var1_double, & - get_var3_r4, & - get_var1_real, check_var_exists - use IPD_typedefs, only: IPD_init_type, IPD_control_type, & - kind_phys - use block_control_mod, only: block_control_type + use fms_mod, only: file_exist + use mpp_mod, only: mpp_error, FATAL, NOTE, mpp_pe + use mpp_domains_mod, only: domain2d + + use constants_mod, only: pi=>pi_8 + use fv_arrays_mod, only: fv_atmos_type, & + fv_grid_type, & + fv_grid_bounds_type, & + R_GRID + use fv_mp_mod, only: is_master + use sim_nc_mod, only: open_ncfile, & + close_ncfile, & + get_ncdim1, & + get_var1_double, & + get_var3_r4, & + get_var1_real, check_var_exists + use IPD_typedefs, only: IPD_init_type, IPD_control_type, & + kind_phys + use block_control_mod, only: block_control_type use fv_treat_da_inc_mod, only: remap_coef - use tracer_manager_mod, only: get_tracer_names,get_tracer_index, get_number_tracers - use field_manager_mod, only: MODEL_ATMOS + use tracer_manager_mod, only: get_tracer_names,get_tracer_index, get_number_tracers + use field_manager_mod, only: MODEL_ATMOS implicit none private diff --git a/atmos_cubed_sphere/tools/fv_nggps_diag.F90 b/atmos_cubed_sphere/tools/fv_nggps_diag.F90 index ca172b20a..3ff946949 100644 --- a/atmos_cubed_sphere/tools/fv_nggps_diag.F90 +++ b/atmos_cubed_sphere/tools/fv_nggps_diag.F90 @@ -53,7 +53,7 @@ module fv_nggps_diags_mod logical :: hydrostatico integer, allocatable :: id_tracer(:), all_axes(:) integer, allocatable :: kstt_tracer(:), kend_tracer(:) - real, allocatable :: ak(:), bk(:) + real, allocatable :: ak(:), bk(:) character(20),allocatable :: axis_name(:),axis_name_vert(:) logical :: module_is_initialized=.false. @@ -90,7 +90,7 @@ subroutine fv_nggps_diag_init(Atm, axes, Time) integer, intent(in) :: axes(4) type(time_type), intent(in) :: Time - integer :: n, i, j + integer :: n, i, j, nz n = 1 ncnsto = Atm(1)%ncnst @@ -221,10 +221,13 @@ subroutine fv_nggps_diag_init(Atm, axes, Time) nlevs = nlevs + 1 endif ! - allocate(ak(size(atm(1)%ak))) - allocate(bk(size(atm(1)%bk))) - ak(1:size(ak)) = atm(1)%ak(1:size(ak)) - bk(1:size(bk)) = atm(1)%bk(1:size(bk)) + nz = size(atm(1)%ak) + allocate(ak(nz)) + allocate(bk(nz)) + do i=1,nz + ak(i) = atm(1)%ak(i) + bk(i) = atm(1)%bk(i) + enddo ! print *,'in ngpps diag init, ak=',ak(1:5),' bk=',bk(1:5) ! get lon,lon information diff --git a/atmos_cubed_sphere/tools/fv_restart.F90 b/atmos_cubed_sphere/tools/fv_restart.F90 index 5389f21bf..e5966a161 100644 --- a/atmos_cubed_sphere/tools/fv_restart.F90 +++ b/atmos_cubed_sphere/tools/fv_restart.F90 @@ -97,7 +97,7 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ real, intent(in) :: dt_atmos integer, intent(out) :: seconds integer, intent(out) :: days - logical, intent(inout) :: cold_start + logical, intent(inout) :: cold_start integer, intent(in) :: grid_type logical, intent(INOUT) :: grids_on_this_pe(:) @@ -327,14 +327,13 @@ subroutine fv_restart(fv_domain, Atm, dt_atmos, seconds, days, cold_start, grid_ if( is_master() ) write(*,*) 'phis set to zero' endif !mountain - #ifdef SW_DYNAMICS - Atm(n)%pt(:,:,:)=1. + Atm(n)%pt(:,:,:) = 1. #else if ( .not.Atm(n)%flagstruct%hybrid_z ) then - if(Atm(n)%ptop/=Atm(n)%ak(1)) call mpp_error(FATAL,'FV restart: ptop not equal Atm(n)%ak(1)') + if(Atm(n)%ptop /= Atm(n)%ak(1)) call mpp_error(FATAL,'FV restart: ptop not equal Atm(n)%ak(1)') else - Atm(n)%ptop = Atm(n)%ak(1); Atm(n)%ks = 0 + Atm(n)%ptop = Atm(n)%ak(1) ; Atm(n)%ks = 0 endif call p_var(npz, isc, iec, jsc, jec, Atm(n)%ptop, ptop_min, & Atm(n)%delp, Atm(n)%delz, Atm(n)%pt, Atm(n)%ps, Atm(n)%pe, Atm(n)%peln, & @@ -643,21 +642,24 @@ subroutine setup_nested_boundary_halo(Atm, proc_in) process = .true. endif - isd = Atm%bd%isd - ied = Atm%bd%ied - jsd = Atm%bd%jsd - jed = Atm%bd%jed + isd = Atm%bd%isd + ied = Atm%bd%ied + jsd = Atm%bd%jsd + jed = Atm%bd%jed ncnst = Atm%ncnst - isc = Atm%bd%isc; iec = Atm%bd%iec; jsc = Atm%bd%jsc; jec = Atm%bd%jec - is = Atm%bd%is ; ie = Atm%bd%ie ; js = Atm%bd%js ; je = Atm%bd%je - npz = Atm%npz - nwat = Atm%flagstruct%nwat + isc = Atm%bd%isc; iec = Atm%bd%iec; jsc = Atm%bd%jsc; jec = Atm%bd%jec + is = Atm%bd%is ; ie = Atm%bd%ie ; js = Atm%bd%js ; je = Atm%bd%je + npz = Atm%npz + nwat = Atm%flagstruct%nwat - if (nwat>=3 ) then + if (nwat >= 3) then liq_wat = get_tracer_index (MODEL_ATMOS, 'liq_wat') ice_wat = get_tracer_index (MODEL_ATMOS, 'ice_wat') endif - if ( nwat==6 ) then + if ( nwat== 5) then + rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat') + snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') + elseif (nwat == 6) then rainwat = get_tracer_index (MODEL_ATMOS, 'rainwat') snowwat = get_tracer_index (MODEL_ATMOS, 'snowwat') graupel = get_tracer_index (MODEL_ATMOS, 'graupel') diff --git a/atmos_model.F90 b/atmos_model.F90 index 5ad927c8f..9b3408de3 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -81,9 +81,9 @@ module atmos_model_mod use IPD_typedefs, only: IPD_init_type, IPD_control_type, & IPD_data_type, IPD_diag_type, & IPD_restart_type, kind_phys -use IPD_driver, only: IPD_initialize, IPD_setup_step, & - IPD_radiation_step, & - IPD_physics_step1, & +use IPD_driver, only: IPD_initialize, IPD_setup_step, & + IPD_radiation_step, & + IPD_physics_step1, & IPD_physics_step2 use FV3GFS_io_mod, only: FV3GFS_restart_read, FV3GFS_restart_write, & FV3GFS_IPD_checksum, & @@ -119,13 +119,10 @@ module atmos_model_mod type(grid_box_type) :: grid ! hold grid information needed for 2nd order conservative flux exchange ! to calculate gradient on cubic sphere grid. integer :: layout(2) ! computer task laytout - real(kind=8), pointer, dimension(:) :: ak - real(kind=8), pointer, dimension(:) :: bk - real(kind=8), pointer, dimension(:,:,:) :: layer_hgt - real(kind=8), pointer, dimension(:,:,:) :: level_hgt - real(kind=kind_phys), pointer, dimension(:,:) :: dx - real(kind=kind_phys), pointer, dimension(:,:) :: dy - real(kind=8), pointer, dimension(:,:) :: area + real(kind=8), pointer, dimension(:) :: ak, bk + real(kind=kind_phys), pointer, dimension(:,:) :: dx, dy + real(kind=8), pointer, dimension(:,:) :: area + real(kind=8), pointer, dimension(:,:,:) :: layer_hgt, level_hgt end type atmos_data_type ! @@ -137,8 +134,10 @@ module atmos_model_mod logical :: dycore_only = .false. logical :: debug = .false. logical :: sync = .false. -real, dimension(2048) :: fdiag = 0. -namelist /atmos_model_nml/ blocksize, chksum_debug, dycore_only, debug, sync, fdiag +integer, parameter :: maxhr = 4096 +real, dimension(maxhr) :: fdiag = 0. +real :: fhmax=240.0, fhmaxhf=120.0, fhout=3.0, fhouthf=1.0 +namelist /atmos_model_nml/ blocksize, chksum_debug, dycore_only, debug, sync, fdiag, fhmax, fhmaxhf, fhout, fhouthf type (time_type) :: diag_time !--- concurrent and decoupled radiation and physics variables @@ -223,9 +222,11 @@ subroutine update_atmos_radiation_physics (Atmos) call mpp_clock_end(setupClock) if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "radiation driver" + !--- execute the IPD atmospheric radiation subcomponent (RRTM) + call mpp_clock_begin(radClock) -!$OMP parallel do default (none) & +!$OMP parallel do default (none) & !$OMP schedule (dynamic,1), & !$OMP shared (Atm_block, IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) & !$OMP private (nb) @@ -240,7 +241,9 @@ subroutine update_atmos_radiation_physics (Atmos) endif if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "physics driver" + !--- execute the IPD atmospheric physics step1 subcomponent (main physics driver) + call mpp_clock_begin(physClock) !$OMP parallel do default (none) & !$OMP schedule (dynamic,1), & @@ -257,7 +260,9 @@ subroutine update_atmos_radiation_physics (Atmos) endif if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "stochastic physics driver" + !--- execute the IPD atmospheric physics step2 subcomponent (stochastic physics driver) + call mpp_clock_begin(physClock) !$OMP parallel do default (none) & !$OMP schedule (dynamic,1), & @@ -301,15 +306,15 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) integer :: isd, ied, jsd, jed integer :: blk, ibs, ibe, jbs, jbe real(kind=kind_phys) :: dt_phys - real, allocatable :: q(:,:,:,:), p_half(:,:,:) - character(len=80) :: control - character(len=64) :: filename, filename2, pelist_name - character(len=132) :: text - logical :: p_hydro, hydro, fexist - logical, save :: block_message = .true. - type(IPD_init_type) :: Init_parm - integer :: bdat(8), cdat(8) - integer :: ntracers + real, allocatable :: q(:,:,:,:), p_half(:,:,:) + character(len=80) :: control + character(len=64) :: filename, filename2, pelist_name + character(len=132) :: text + logical :: p_hydro, hydro, fexist + logical, save :: block_message = .true. + type(IPD_init_type) :: Init_parm + integer :: bdat(8), cdat(8) + integer :: ntracers, maxhf, maxh character(len=32), allocatable, target :: tracer_names(:) !----------------------------------------------------------------------- @@ -344,6 +349,7 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) 10 call close_file (unit) #endif endif + !----------------------------------------------------------------------- call atmosphere_resolution (nlon, nlat, global=.false.) call atmosphere_resolution (mlon, mlat, global=.true.) @@ -416,7 +422,9 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) #endif call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) - Atm(mytile)%flagstruct%do_skeb=IPD_Control%do_skeb + + Atm(mytile)%flagstruct%do_skeb = IPD_Control%do_skeb + ! initialize the IAU module call iau_initialize (IPD_Control,IAU_data,Init_parm) @@ -453,9 +461,23 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) #ifdef GFS_PHYS !--- check fdiag to see if it is an interval or a list if (nint(fdiag(2)) == 0) then - do i = 2, size(fdiag,1) - fdiag(i) = fdiag(i-1) + fdiag(1) - enddo + if (fhmaxhf > 0) then + maxhf = fhmaxhf / fhouthf + maxh = maxhf + (fhmax-fhmaxhf) / fhout + fdiag(1) = fhouthf + do i=2,maxhf + fdiag(i) = fdiag(i-1) + fhouthf + enddo + do i=maxhf+1,maxh + fdiag(i) = fdiag(i-1) + fhout + enddo + else + maxh = fhmax / fhout + fdiag(1) = fdiag(1) + fhout + do i = 2, maxh + fdiag(i) = fdiag(i-1) + fhout + enddo + endif endif if (mpp_pe() == mpp_root_pe()) write(6,*) "---fdiag",fdiag(1:40) #endif @@ -521,8 +543,8 @@ subroutine update_atmos_model_state (Atmos) call get_time (Atmos%Time - diag_time, isec) call get_time (Atmos%Time - Atmos%Time_init, seconds) - if (mpp_pe() == mpp_root_pe()) write(6,*) "---isec,seconds",isec,seconds if (ANY(nint(fdiag(:)*3600.0) == seconds) .or. (IPD_Control%kdt == 1) ) then + if (mpp_pe() == mpp_root_pe()) write(6,*) "---isec,seconds",isec,seconds time_int = real(isec) time_intfull = real(seconds) if (mpp_pe() == mpp_root_pe()) write(6,*) ' gfs diags time since last bucket empty: ',time_int/3600.,'hrs' @@ -530,8 +552,8 @@ subroutine update_atmos_model_state (Atmos) call gfdl_diag_output(Atmos%Time, Atm_block, IPD_Control%nx, IPD_Control%ny, & IPD_Control%levs, 1, 1, 1.d0, time_int, time_intfull) if (mod(isec,3600*nint(IPD_Control%fhzero)) == 0) diag_time = Atmos%Time + call diag_send_complete_extra (Atmos%Time) endif - call diag_send_complete_extra (Atmos%Time) end subroutine update_atmos_model_state ! diff --git a/configure b/configure index 30104e048..98add240c 100755 --- a/configure +++ b/configure @@ -1,5 +1,5 @@ #!/bin/bash -set -eu +set -eux # copy_diff_files copy_diff_files(){ diff --git a/fms/fms/fms_io.F90 b/fms/fms/fms_io.F90 index f264573b0..2e443358f 100644 --- a/fms/fms/fms_io.F90 +++ b/fms/fms/fms_io.F90 @@ -253,20 +253,20 @@ module fms_io_mod logical :: is_compressed = .FALSE. logical :: unlimited_axis = .FALSE. integer :: tile_count = 1 - type(ax_type), allocatable :: axes(:) ! Currently define X,Y,Compressed, unlimited and maybe Z - type(meta_type), pointer :: first =>NULL() ! pointer to first additional global metadata element - type(var_type), dimension(:), pointer :: var => NULL() - type(Ptr0Dr), dimension(:,:), pointer :: p0dr => NULL() - type(Ptr1Dr), dimension(:,:), pointer :: p1dr => NULL() - type(Ptr2Dr), dimension(:,:), pointer :: p2dr => NULL() - type(Ptr3Dr), dimension(:,:), pointer :: p3dr => NULL() - type(Ptr2Dr8), dimension(:,:), pointer :: p2dr8 => NULL() - type(Ptr3Dr8), dimension(:,:), pointer :: p3dr8 => NULL() - type(Ptr4Dr), dimension(:,:), pointer :: p4dr => NULL() - type(Ptr0Di), dimension(:,:), pointer :: p0di => NULL() - type(Ptr1Di), dimension(:,:), pointer :: p1di => NULL() - type(Ptr2Di), dimension(:,:), pointer :: p2di => NULL() - type(Ptr3Di), dimension(:,:), pointer :: p3di => NULL() + type(ax_type), allocatable :: axes(:) ! Currently define X,Y,Compressed, unlimited and maybe Z + type(meta_type), pointer :: first => NULL() ! pointer to first additional global metadata element + type(var_type), dimension(:), pointer :: var => NULL() + type(Ptr0Dr), dimension(:,:), pointer :: p0dr => NULL() + type(Ptr1Dr), dimension(:,:), pointer :: p1dr => NULL() + type(Ptr2Dr), dimension(:,:), pointer :: p2dr => NULL() + type(Ptr3Dr), dimension(:,:), pointer :: p3dr => NULL() + type(Ptr2Dr8), dimension(:,:), pointer :: p2dr8 => NULL() + type(Ptr3Dr8), dimension(:,:), pointer :: p3dr8 => NULL() + type(Ptr4Dr), dimension(:,:), pointer :: p4dr => NULL() + type(Ptr0Di), dimension(:,:), pointer :: p0di => NULL() + type(Ptr1Di), dimension(:,:), pointer :: p1di => NULL() + type(Ptr2Di), dimension(:,:), pointer :: p2di => NULL() + type(Ptr3Di), dimension(:,:), pointer :: p3di => NULL() end type restart_file_type interface read_data diff --git a/fms/tracer_manager/tracer_manager.F90 b/fms/tracer_manager/tracer_manager.F90 index 6676c993b..7af4ed8cd 100644 --- a/fms/tracer_manager/tracer_manager.F90 +++ b/fms/tracer_manager/tracer_manager.F90 @@ -111,7 +111,7 @@ module tracer_manager_mod integer, parameter :: MAX_TRACER_FIELDS = 150 integer, parameter :: MAX_TRACER_METHOD = 20 integer, parameter :: NO_TRACER = 1-HUGE(1) -integer, parameter :: NOTRACER = -HUGE(1) +integer, parameter :: NOTRACER = -HUGE(1) integer :: total_tracers(NUM_MODELS), prog_tracers(NUM_MODELS), diag_tracers(NUM_MODELS) logical :: model_registered(NUM_MODELS) = .FALSE. diff --git a/fv3_cap.F90 b/fv3_cap.F90 index 6bdc529a9..9301d935f 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -243,6 +243,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if(mype==0) print *,'af nems config,quilting=',quilting,'calendar=', & trim(calendar) ! + nfhout=0; nfhmax_hf=0; nfhout_hf=0; nsout=0 if ( quilting ) then CALL ESMF_ConfigGetAttribute(config=CF,value=write_groups, & label ='write_groups:',rc=rc) @@ -749,13 +750,13 @@ subroutine ModelAdvance(gcomp, rc) character(len=*),parameter :: subname='(fv3_cap:ModelAdvance)' character(240) :: msgString !jw debug - character(ESMF_MAXSTR) :: name - type(ESMF_VM) :: vm + character(ESMF_MAXSTR) :: name + type(ESMF_VM) :: vm integer :: mype,date(6), fieldcount, fcst_nfld real(kind=ESMF_KIND_R4), pointer :: dataPtr(:,:,:), dataPtr2d(:,:) character(64) :: fcstbdl_name - real(kind=8) :: MPI_Wtime - real(kind=8) :: timeri,timewri, timewr, timerhi, timerh + real(kind=8) :: MPI_Wtime + real(kind=8) :: timeri, timewri, timewr, timerhi, timerh !----------------------------------------------------------------------------- @@ -867,7 +868,7 @@ subroutine ModelAdvance(gcomp, rc) time_elapsed = currtime - starttime na = nint(time_elapsed/timeStep) ! - if(mype==0) print *,'n fv3_cap,in model run, advance,na=',na +! if(mype==0) print *,'in fv3_cap,in model run, advance,na=',na !------------------------------------------------------------------------------- !*** if alarms ring, call data transfer and write grid comp run @@ -891,8 +892,8 @@ subroutine ModelAdvance(gcomp, rc) if(ESMF_AlarmIsEnabled(alarm = ALARM_OUTPUT, rc = RC)) then if(ESMF_AlarmIsRinging(alarm = ALARM_OUTPUT,rc = Rc)) LALARM = .true. endif - if (mype == 0 .or. mype == lead_wrttask(1)) print *,' aft fcst run lalarm=',lalarm, & - 'FBcount=',FBcount,'na=',na +! if (mype == 0 .or. mype == lead_wrttask(1)) print *,' aft fcst run lalarm=',lalarm, & +! 'FBcount=',FBcount,'na=',na output: IF(lalarm .or. na==1 ) then @@ -912,8 +913,8 @@ subroutine ModelAdvance(gcomp, rc) ! !end FBcount enddo - if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, & - ' time=', timerh- timerhi +! if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, & +! ' time=', timerh- timerhi ! if(mype==0 .or. mype==lead_wrttask(1)) print *,'on wrt bf wrt run, na=',na call ESMF_LogWrite('Model Advance: before wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) @@ -933,8 +934,8 @@ subroutine ModelAdvance(gcomp, rc) line=__LINE__, & file=__FILE__)) & call ESMF_Finalize(endflag=ESMF_END_ABORT) - if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft wrtgridcomp run,na=',na, & - ' time=', timerh- timerhi +! if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft wrtgridcomp run,na=',na, & +! ' time=', timerh- timerhi call ESMF_LogWrite('Model Advance: after wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, & @@ -942,8 +943,8 @@ subroutine ModelAdvance(gcomp, rc) file=__FILE__)) & call ESMF_Finalize(endflag=ESMF_END_ABORT) - if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'fv3_cap,aft model advance,na=', & - na,' time=', mpi_wtime()- timewri +! if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'fv3_cap,aft model advance,na=', & +! na,' time=', mpi_wtime()- timewri if(n_group == write_groups) then diff --git a/gfsphysics/GFS_layer/GFS_driver.F90 b/gfsphysics/GFS_layer/GFS_driver.F90 index a4404fa6e..9e9c5976b 100644 --- a/gfsphysics/GFS_layer/GFS_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_driver.F90 @@ -13,6 +13,10 @@ module GFS_driver use module_radlw_parameters, only: topflw_type, sfcflw_type use funcphys, only: gfuncphys use gfdl_cloud_microphys_mod, only: gfdl_cloud_microphys_init + use physcons, only: gravit => con_g, rair => con_rd, & + rh2o => con_rv, & + tmelt => con_ttp, cpair => con_cp, & + latvap => con_hvap, latice => con_hfus implicit none @@ -98,12 +102,13 @@ module GFS_driver !-------------- ! GFS initialze !-------------- - subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & + subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & Coupling, Grid, Tbd, Cldprop, Radtend, & Diag, Init_parm) - use module_microphysics, only: gsmconst +! use module_microphysics, only: gsmconst use cldwat2m_micro, only: ini_micro + use micro_mg2_0, only: micro_mg_init use aer_cloud, only: aer_cloud_init use module_ras, only: ras_init use module_mp_thompson, only: thompson_init @@ -126,6 +131,7 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & integer :: nb integer :: nblks integer :: ntrac + integer :: ix real(kind=kind_phys), allocatable :: si(:) real(kind=kind_phys), parameter :: p_ref = 101325.0d0 @@ -155,16 +161,18 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & call read_h2odata (Model%h2o_phys, Model%me, Model%master) do nb = 1,nblks - call Statein (nb)%create (Init_parm%blksz(nb), Model) - call Stateout (nb)%create (Init_parm%blksz(nb), Model) - call Sfcprop (nb)%create (Init_parm%blksz(nb), Model) - call Coupling (nb)%create (Init_parm%blksz(nb), Model) - call Grid (nb)%create (Init_parm%blksz(nb), Model) - call Tbd (nb)%create (Init_parm%blksz(nb), Model) - call Cldprop (nb)%create (Init_parm%blksz(nb), Model) - call Radtend (nb)%create (Init_parm%blksz(nb), Model) - !--- internal representation of diagnostics - call Diag (nb)%create (Init_parm%blksz(nb), Model) + ix = Init_parm%blksz(nb) +! write(0,*)' ix in gfs_driver=',ix,' nb=',nb + call Statein (nb)%create (ix, Model) + call Stateout (nb)%create (ix, Model) + call Sfcprop (nb)%create (ix, Model) + call Coupling (nb)%create (ix, Model) + call Grid (nb)%create (ix, Model) + call Tbd (nb)%create (ix, Model) + call Cldprop (nb)%create (ix, Model) + call Radtend (nb)%create (ix, Model) +!--- internal representation of diagnostics + call Diag (nb)%create (ix, Model) enddo !--- populate the grid components @@ -188,7 +196,7 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & !--- Call gfuncphys (funcphys.f) to compute all physics function tables. call gfuncphys () - call gsmconst (Model%dtp, Model%me, .TRUE.) +! call gsmconst (Model%dtp, Model%me, .TRUE.) ! This is for Ferrier microphysics - notused - moorthi !--- define sigma level for radiation initialization !--- The formula converting hybrid sigma pressure coefficients to sigma coefficients follows Eckermann (2009, MWR) @@ -197,47 +205,63 @@ subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & allocate(si(Model%levr+1)) si = (Init_parm%ak + Init_parm%bk * p_ref - Init_parm%ak(Model%levr+1)) & / (p_ref - Init_parm%ak(Model%levr+1)) - call rad_initialize (si, Model%levr, Model%ictm, Model%isol, & - Model%ico2, Model%iaer, Model%ialb, Model%iems, & - Model%ntcw, Model%num_p2d, Model%num_p3d, & - Model%npdf3d, Model%ntoz, & - Model%iovr_sw, Model%iovr_lw, Model%isubc_sw, & - Model%isubc_lw, Model%crick_proof, Model%ccnorm, & - Model%imp_physics, & - Model%norad_precip, Model%idate,Model%iflip, Model%me) + + call rad_initialize (si, Model%levr, Model%ictm, Model%isol, & + Model%ico2, Model%iaer, Model%ialb, Model%iems, & + Model%ntcw, Model%num_p2d, Model%num_p3d, Model%npdf3d, & + Model%ntoz, Model%iovr_sw, Model%iovr_lw, Model%isubc_sw, & + Model%isubc_lw, Model%crick_proof, Model%ccnorm, & + Model%imp_physics, Model%norad_precip, Model%idate, Model%iflip, Model%me) deallocate (si) - !--- initialize Morrison-Gettleman microphysics -! if (Model%ncld == 2) then - if(Model%imp_physics == 8) then !--- initialize Thompson Cloud microphysics - call thompson_init() !--- add aerosol version later - if(Model%do_shoc) then - print *,'SHOC is not currently compatible with Thompson MP -- shutting down' - stop - endif - if(Model%ltaerosol) then - print *,'Aerosol awareness is not included in this version of Thompson MP -- shutting down' - stop - endif - else if(Model%imp_physics == 6) then !--- initialize WSM6 Cloud microphysics - call wsm6init() - if(Model%do_shoc) then - print *,'SHOC is not currently compatible with WSM6 -- shutting down' - stop - endif - - else if(Model%imp_physics == 11) then !--- initialize GFDL Cloud microphysics +! microphysics initialization calls +! --------------------------------- + + if (Model%imp_physics == 10) then !--- initialize Morrison-Gettleman microphysics + if (Model%fprcp <= 0) then + call ini_micro (Model%mg_dcs, Model%mg_qcvar, Model%mg_ts_auto_ice) + else + call micro_mg_init( kind_phys, gravit, rair, rh2o, cpair, & + tmelt, latvap, latice, 1.01_kind_phys, & + Model%mg_dcs,Model%mg_ts_auto_ice, & + Model%mg_qcvar, & + Model%microp_uniform, Model%do_cldice, & + Model%hetfrz_classnuc, & +! .false., .true., .false., & +! 'in_cloud ', 2._kind_phys, & +! .true., .true., .false., & + 'max_overlap ', 2._kind_phys, & + .true., .true., & + .false., .false., 100.e6_kind_phys, 0.15e6_kind_phys ) + endif + call aer_cloud_init () +! + elseif (Model%imp_physics == 8) then !--- initialize Thompson Cloud microphysics + if(Model%do_shoc) then + print *,'SHOC is not currently compatible with Thompson MP -- shutting down' + stop + endif + call thompson_init() !--- add aerosol version later + if(Model%ltaerosol) then + print *,'Aerosol awareness is not included in this version of Thompson MP -- shutting down' + stop + endif +! + elseif(Model%imp_physics == 6) then !--- initialize WSM6 Cloud microphysics + if(Model%do_shoc) then + print *,'SHOC is not currently compatible with WSM6 -- shutting down' + stop + endif + call wsm6init() +! + else if(Model%imp_physics == 11) then !--- initialize GFDL Cloud microphysics + if(Model%do_shoc) then + print *,'SHOC is not currently compatible with GFDL MP -- shutting down' + stop + endif call gfdl_cloud_microphys_init (Model%me, Model%master, Model%nlunit, Model%input_nml_file, & Init_parm%logunit, Model%fn_nml) - if(Model%do_shoc) then - print *,'SHOC is not currently compatible with GFDL MP -- shutting down' - stop - endif - else if(Model%imp_physics == 10) then !--- initialize MG Cloud microphysics - call ini_micro (Model%mg_dcs, Model%mg_qcvar, Model%mg_ts_auto_ice) - call aer_cloud_init () endif -! endif !--- initialize ras if (Model%ras) call ras_init (Model%levs, Model%me) @@ -288,7 +312,7 @@ subroutine GFS_time_vary_step (Model, Statein, Stateout, Sfcprop, Coupling, & type(GFS_radtend_type), intent(inout) :: Radtend(:) type(GFS_diag_type), intent(inout) :: Diag(:) !--- local variables - integer :: nb, nblks,k + integer :: nb, nblks, k real(kind=kind_phys) :: rinc(5) real(kind=kind_phys) :: sec @@ -443,7 +467,7 @@ subroutine GFS_stochastic_driver (Model, Statein, Stateout, Sfcprop, Coupling, & !negative humidity check qnew = Statein%qgrs(i,k,1)+qpert - if (qnew .GE. 1.0e-10) then + if (qnew >= 1.0e-10) then Stateout%gq0(i,k,1) = qnew Stateout%gt0(i,k) = Statein%tgrs(i,k) + tpert + Tbd%dtdtr(i,k) endif @@ -508,8 +532,8 @@ subroutine GFS_rad_time_vary (Model, Statein, Tbd, sec) nblks = size(blksz,1) - call radupdate (Model%idat, Model%jdat, Model%fhswr, Model%dtf, Model%lsswr, & - Model%me, Model%slag, Model%sdec, Model%cdec, Model%solcon ) + call radupdate (Model%idat, Model%jdat, Model%fhswr, Model%dtf, Model%lsswr, & + Model%me, Model%slag, Model%sdec, Model%cdec, Model%solcon) !--- set up random seed index in a reproducible way for entire cubed-sphere face (lat-lon grid) if ((Model%isubc_lw==2) .or. (Model%isubc_sw==2)) then @@ -523,7 +547,7 @@ subroutine GFS_rad_time_vary (Model, Statein, Tbd, sec) do j = 1,Model%ny do i = 1,Model%nx ix = ix + 1 - if (ix .gt. blksz(nb)) then + if (ix > blksz(nb)) then ix = 1 nb = nb + 1 endif @@ -607,7 +631,7 @@ subroutine GFS_phys_time_vary (Model, Grid, Tbd) do j = 1,Model%ny do i = 1,Model%nx ix = ix + 1 - if (ix .gt. blksz(nb)) then + if (ix > blksz(nb)) then ix = 1 nb = nb + 1 endif @@ -620,7 +644,7 @@ subroutine GFS_phys_time_vary (Model, Grid, Tbd) !--- o3 interpolation if (Model%ntoz > 0) then do nb = 1, nblks - call ozinterpol (Model%me, blksz(nb), Model%idate, Model%fhour, & + call ozinterpol (Model%me, blksz(nb), Model%idate, Model%fhour, & Grid(nb)%jindx1_o3, Grid(nb)%jindx2_o3, & Tbd(nb)%ozpl, Grid(nb)%ddy_o3) enddo @@ -661,7 +685,7 @@ subroutine GFS_grid_populate (Grid, xlon, xlat, area) do j = 1,size(xlon,2) do i = 1,size(xlon,1) ix=ix+1 - if (ix .gt. blksz) then + if (ix > blksz) then nb = nb + 1 ix = 1 endif diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 843f691f0..f32f10a50 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -1,9 +1,9 @@ module module_physics_driver use machine, only: kind_phys - use physcons, only: con_cp, con_fvirt, con_g, con_rd, & - con_rv, con_hvap, con_hfus, & - con_rerth, con_pi, rhc_max, dxmin,& + use physcons, only: con_cp, con_fvirt, con_g, con_rd, & + con_rv, con_hvap, con_hfus, & + con_rerth, con_pi, rhc_max, dxmin, & dxinv, pa2mb, rlapse, con_eps, con_epsm1 use cs_conv, only: cs_convr use ozne_def, only: levozp, oz_coeff, oz_pres @@ -30,12 +30,11 @@ module module_physics_driver real(kind=kind_phys), parameter :: epsq = 1.e-20 real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) - real(kind=kind_phys), parameter :: onebg = 1.0/con_g + real(kind=kind_phys), parameter :: one = 1.0d0, onebg = one/con_g real(kind=kind_phys), parameter :: albdf = 0.06 + real(kind=kind_phys), parameter :: tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf) real(kind=kind_phys), parameter :: con_p001= 0.001d0 real(kind=kind_phys), parameter :: con_day = 86400.d0 - real(kind=kind_phys) tf, tcr, tcrf - parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) !> GFS Physics Implementation Layer @@ -46,7 +45,7 @@ module module_physics_driver ! ! ! usage: ! ! ! -! call gbphys ! +! call GFS_physics_driver ! ! ! ! --- interface variables ! ! type(GFS_control_type), intent(in) :: Model ! @@ -157,8 +156,15 @@ module module_physics_driver ! jul 2016 S. Moorthi fix some bugs in shoc/2m microphysics ! ! au-nv2016a S. Moorthi CS with AW and connect with shoc/2m ! ! Dec 2016 Anning C. Add prognostic rain and snow with 2M ! +! Oct 2017 S. Moorthi fix tracers to account for ice, snow etc! +! with this RAS and CSAW advect condensates! ! Mar 2017 Ruiyu S. Add Thompson's 2M aerosol MP ! ! May 2017 Ruiyu S. Add WSM6 MP ! +! Dec 2017 S. Moorthi Merge/update Ruiyu's update on vertical ! +! diffusion of tracers for all monins ! +! Jan 04 2018 S. Moorthi fix a bug in rhc for use in MG ! +! macrophysics and replace ntrac by nvdiff! +! in call to moninshoc ! ! ! ==================== end of description ===================== ! ==================== definition of variables ==================== ! @@ -390,9 +396,9 @@ module module_physics_driver CONTAINS !******************************************************************************************* - subroutine GFS_physics_driver & - (Model, Statein, Stateout, Sfcprop, Coupling, & - Grid, Tbd, Cldprop, Radtend, Diag) + subroutine GFS_physics_driver & + (Model, Statein, Stateout, Sfcprop, Coupling, & + Grid, Tbd, Cldprop, Radtend, Diag) implicit none ! @@ -410,39 +416,40 @@ subroutine GFS_physics_driver & ! ! --- local variables - !--- INTEGER VARIABLES - integer :: me, lprint, ipr, ix, im, levs, ntrac, nvdiff, kdt - integer :: i, kk, ic, k, n, k1, iter, levshcm, tracers, & - trc_shft, tottracer, num2, num3, nshocm, nshoc, ntk - integer :: seconds +!--- INTEGER VARIABLES + integer :: me, lprint, ipr, ix, im, levs, ntrac, nvdiff, kdt, & + ntoz, ntcw, ntiw, ncld, ntke, ntlnc, ntinc, lsoil, & + ntrw, ntsw, ntrnc, ntsnc, ntot3d, ntgl, ntclamt, & + ims, ime, kms, kme, its, ite, kts, kte, imp_physics, & + ntwa, ntia - integer :: ims, ime, kms, kme - integer :: its, ite, kts, kte + integer :: i, kk, ic, k, n, k1, iter, levshcm, tracers, & + tottracer, num2, num3, nshocm, nshoc, ntk, nn, nncl, & + seconds integer, dimension(size(Grid%xlon,1)) :: & kbot, ktop, kcnv, soiltyp, vegtype, kpbl, slopetyp, kinver, & lmh, levshc, islmsk, & - !--- coupling inputs for physics +!--- coupling inputs for physics islmsk_cice - !--- LOGICAL VARIABLES - logical :: lprnt, revap, do_awdd +!--- LOGICAL VARIABLES + logical :: lprnt, revap logical, dimension(size(Grid%xlon,1)) :: & flag_iter, flag_guess, invrsn, skip_macro, & - !--- coupling inputs for physics +!--- coupling inputs for physics flag_cice - logical, dimension(Model%ntrac-Model%ncld+2,2) :: & - otspt + logical, dimension(Model%ntrac+1,2) :: otspt - !--- REAL VARIABLES +!--- REAL VARIABLES real(kind=kind_phys) :: & dtf, dtp, rhbbot, rhbtop, rhpbl, frain, tem, tem1, tem2, & xcosz_loc, zsea1, zsea2, eng0, eng1, dpshc, & - !--- experimental for shoc sub-stepping +!--- experimental for shoc sub-stepping dtshoc, & - !--- GFDL Cloud microphysics +!--- GFDL Cloud microphysics crain, csnow real(kind=kind_phys), dimension(Model%ntrac-Model%ncld+2) :: & @@ -461,10 +468,10 @@ subroutine GFS_physics_driver & snohf, dlqfac, work3, ctei_rml, cldf, domr, domzr, domip, & doms, psautco_l, prautco_l, ocalnirbm_cpl, ocalnirdf_cpl, & ocalvisbm_cpl, ocalvisdf_cpl, dtzm, temrain1, & - !--- coupling inputs for physics +!--- coupling inputs for physics dtsfc_cice, dqsfc_cice, dusfc_cice, dvsfc_cice, ulwsfc_cice, & tisfc_cice, tsea_cice, hice_cice, fice_cice, & - !--- for CS-convection +!--- for CS-convection wcbmax real(kind=kind_phys), dimension(size(Grid%xlon,1),1) :: & @@ -480,63 +487,84 @@ subroutine GFS_physics_driver & del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & ud_mf, dd_mf, dt_mf, prnum, dkt, sigmatot, sigmafrac - !--- GFDL modification for FV3 +!--- GFDL modification for FV3 + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs+1) ::& del_gz - - real(kind=kind_phys), dimension(size(Grid%xlon,1),1,Model%levs) ::& + real(kind=kind_phys), allocatable, dimension(:,:,:) :: & delp, dz, uin, vin, pt, qv1, ql1, qr1, qg1, qa1, qn1, qi1, & qs1, pt_dt, qa_dt, udt, vdt, w, qv_dt, ql_dt, qr_dt, qi_dt, & qs_dt, qg_dt - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%ntrac) :: & +! + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%ntrac) :: & dqdt - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%nctp) :: & - sigmai, vverti - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,oz_coeff+5) :: & dq3dt_loc - !--- ALLOCATABLE ELEMENTS +!--- ALLOCATABLE ELEMENTS !--- in clw, the first two varaibles are cloud water and ice. !--- from third to ntrac are convective transportable tracers, !--- third being the ozone, when ntrac=3 (valid only with ras) !--- Anning Cheng 9/21/2016 leave a hook here for diagnosed snow, - !--- rain, and their number + !--- rain, and their numbers real(kind=kind_phys), allocatable :: & - clw(:,:,:), qpl(:,:), qpi(:,:), ncpl(:,:), ncpi(:,:), & - qrn(:,:), qsnw(:,:), ncpr(:,:), ncps(:,:), cnvc(:,:), & - cnvw(:,:) - !--- for 2 M microphysics + clw(:,:,:), qrn(:,:), qsnw(:,:), ncpl(:,:), ncpi(:,:), & + ncpr(:,:), ncps(:,:), cnvc(:,:), cnvw(:,:) +!--- for 2 M microphysics real(kind=kind_phys), allocatable, dimension(:) :: & cn_prc, cn_snr real(kind=kind_phys), allocatable, dimension(:,:) :: & qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & CLCN, CNV_FICE, CNV_NDROP, CNV_NICE + real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.02, & + turnrhcrit = 0.900, turnrhcrit_upper = 0.150 +! !--- for 2 M Thmpson MP real(kind=kind_phys), allocatable, dimension(:,:,:) :: & - pbltra, dpbltra + vdftra, dvdftra real(kind=kind_phys), allocatable, dimension(:,:) :: & ice00, liq0 ! real(kind=kind_phys), allocatable, dimension(:) :: nwfa2d real(kind=kind_phys), parameter :: liqm = 4./3.*con_pi*1.e-12, & icem = 4./3.*con_pi*3.2768*1.e-14*890. -! ! !===> ... begin here - me = Model%me - ix = size(Grid%xlon,1) - im = size(Grid%xlon,1) - levs = Model%levs - ntrac = Model%ntrac - dtf = Model%dtf - dtp = Model%dtp - kdt = Model%kdt - lprnt = Model%lprnt - nvdiff = ntrac ! vertical diffusion of all tracers! + me = Model%me + ix = size(Grid%xlon,1) + im = size(Grid%xlon,1) + ipr = min(im,10) + levs = Model%levs + lsoil = Model%lsoil + ntrac = Model%ntrac + dtf = Model%dtf + dtp = Model%dtp + kdt = Model%kdt + lprnt = Model%lprnt + nvdiff = ntrac ! vertical diffusion of all tracers! + ntcw = Model%ntcw + ntoz = Model%ntoz + ntiw = Model%ntiw + ncld = Model%ncld + ntke = Model%ntke + ntlnc = Model%ntlnc + ntinc = Model%ntinc + ntrw = Model%ntrw + ntsw = Model%ntsw + ntrnc = Model%ntrnc + ntsnc = Model%ntsnc + ntgl = Model%ntgl + ntclamt = Model%ntclamt + ntot3d = Model%ntot3d + ntwa = MOdel%ntwa + ntia = MOdel%ntia + + imp_physics = Model%imp_physics + + nncl = ncld + ims = 1 ime = ix kms = 1 @@ -545,57 +573,67 @@ subroutine GFS_physics_driver & ite = ix kts = 1 kte = levs - if(Model%imp_physics == 8) then - if(Model%ltaerosol) then + if (imp_physics == 8) then + if (Model%ltaerosol) then nvdiff = 8 else nvdiff = 5 endif + nncl = 5 + elseif (imp_physics == 6) then + nvdiff = ntrac -3 + nncl = 5 + elseif (ntclamt > 0) then ! for GFDL MP don't diffuse cloud amount + nvdiff = ntrac - 1 endif - if(Model%imp_physics==6) then - nvdiff = ntrac -3 - endif - ipr = min(im,10) - do i = 1, im + if (imp_physics == 10 .and. abs(Model%fprcp) == 1) nncl = 4 ! MG2 with rain and snow + +!------------------------------------------------------------------------------------------- +! lprnt = .false. + +! do i=1,im +! lprnt = kdt >= 0 .and. abs(grid%xlon(i)*57.29578-140.77) < 0.501 & +! .and. abs(grid%xlat(i)*57.29578-45.50) < 0.501 +! lprnt = kdt >= 0 .and. abs(grid%xlon(i)*57.29578-108.41) < 0.501 & +! .and. abs(grid%xlat(i)*57.29578-32.97) < 0.501 +! if (kdt == 1) & +! write(2000+me,*)' i=',i,' xlon=',grid%xlon(i)*57.29578, & +! ' xlat=',grid%xlat(i)*57.29578,' me=',me +! if (lprnt) then +! ipr = i +! write(0,*)' ipr=',ipr,'xlon=',grid%xlon(i)*57.29578,' xlat=',grid%xlat(i)*57.29578 +! exit +! endif +! enddo +! lprnt = .false. +! if (lprnt) write(0,*)' cloudsdriverdriver=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt +!------------------------------------------------------------------------------------------- + + do i=1,im if(nint(Sfcprop%slmsk(i)) == 1) then frland(i) = 1.0 else frland(i) = 0. endif enddo + ! -! --- ... figure out number of extra tracers -! - tottracer = 0 ! no convective transport of tracers - if (Model%trans_trac .or. Model%cscnv) then - if (Model%ntcw > 0) then - if (Model%ntoz < Model%ntcw) then - trc_shft = Model%ntcw + Model%ncld - 1 - else - trc_shft = Model%ntoz - endif - elseif (Model%ntoz > 0) then - trc_shft = Model%ntoz + skip_macro = .false. + + if (ntiw > 0) then + if (ntclamt > 0) then + nn = ntrac - 2 else - trc_shft = 1 + nn = ntrac - 1 endif - - tracers = Model%ntrac - trc_shft - tottracer = tracers - if (Model%ntoz > 0) tottracer = tottracer + 1 ! ozone is added separately + elseif (ntcw > 0) then + nn = ntrac + else + nn = ntrac + 1 endif - if (Model%ntke > 0) ntk = Model%ntke - trc_shft + 3 - -! if (lprnt) write(0,*)' trans_trac=',trans_trac,' tottracer=', & -! write(0,*)' trans_trac=',trans_trac,' tottracer=', & -! & tottracer,' trc_shft=',trc_shft,' kdt=',kdt -! &, ntrac-ncld+2,' clstp=',clstp,' kdt=',kdt -! &,' ntk=',ntk,' lat=',lat + allocate (clw(ix,levs,nn)) - skip_macro = .false. - - allocate ( clw(ix,levs,tottracer+2) ) if (Model%imfdeepcnv >= 0 .or. Model%imfshalcnv > 0) then allocate (cnvc(ix,levs), cnvw(ix,levs)) endif @@ -603,25 +641,29 @@ subroutine GFS_physics_driver & ! --- set initial quantities for stochastic physics deltas if (Model%do_sppt) then Tbd%dtdtr = 0.0 - Tbd%drain_cpl (:) = Coupling%rain_cpl (:) - Tbd%dsnow_cpl (:) = Coupling%snow_cpl (:) + do i=1,im + Tbd%drain_cpl(i) = Coupling%rain_cpl (i) + Tbd%dsnow_cpl(i) = Coupling%snow_cpl (i) + enddo endif +! + allocate(vdftra(ix,levs,nvdiff), dvdftra(im,levs,nvdiff)) + dvdftra(:,:,:) = 0.0 + if (Model%do_shoc) then - allocate (qpl(im,levs), qpi(im,levs), ncpl(im,levs), ncpi(im,levs)) + allocate (qrn(im,levs), qsnw(im,levs), ncpl(im,levs), ncpi(im,levs)) do k=1,levs do i=1,im ncpl(i,k) = 0.0 ncpi(i,k) = 0.0 + qrn(i,k) = 0.0 + qsnw(i,k) = 0.0 enddo enddo endif - - allocate(pbltra(im,levs,nvdiff)) - allocate(dpbltra(im,levs,nvdiff)) - dpbltra(:,:,:) = 0.0 - - if (Model%imp_physics == 8 ) then +! + if (imp_physics == 8 ) then if(Model%ltaerosol) then allocate(ice00(im,levs)) allocate(liq0(im,levs)) @@ -629,17 +671,39 @@ subroutine GFS_physics_driver & else allocate(ice00(im,levs)) endif - else if (Model%imp_physics == 10 ) then ! For MGB double moment microphysics - allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs), & - cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & - CNV_DQLDT(im,levs), clcn(im,levs), cnv_fice(im,levs), & - cnv_ndrop(im,levs), cnv_nice(im,levs)) - allocate (cn_prc(im), cn_snr(im)) - allocate (qrn(im,levs), qsnw(im,levs), ncpr(im,levs), ncps(im,levs)) + endif + + if (imp_physics == 10) then ! For MGB double moment microphysics + allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs), & + cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & + CNV_DQLDT(im,levs), clcn(im,levs), cnv_fice(im,levs), & + cnv_ndrop(im,levs), cnv_nice(im,levs)) + allocate (cn_prc(im), cn_snr(im)) + allocate (ncpr(im,levs), ncps(im,levs)) + if (.not. allocated(qrn)) allocate (qrn(im,levs)) + if (.not. allocated(qsnw)) allocate (qsnw(im,levs)) + do k=1,levs + do i=1,im + qrn(i,k) = 0.0 + qsnw(i,k) = 0.0 + ncpr(i,k) = 0.0 + ncps(i,k) = 0.0 + enddo + enddo +! else - allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & - CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & - clcn(1,1), cnv_fice(1,1), cnv_ndrop(1,1), cnv_nice(1,1)) + allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & + CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & + clcn(1,1), cnv_fice(1,1), cnv_ndrop(1,1), cnv_nice(1,1)) + if (imp_physics == 11) then ! GFDL MP + allocate (delp(im,1,levs), dz(im,1,levs), uin(im,1,levs), & + vin(im,1,levs), pt(im,1,levs), qv1(im,1,levs), ql1(im,1,levs), & + qr1(im,1,levs), qg1(im,1,levs), qa1(im,1,levs), qn1(im,1,levs), & + qi1(im,1,levs), qs1(im,1,levs), pt_dt(im,1,levs), qa_dt(im,1,levs),& + udt(im,1,levs), vdt(im,1,levs), w(im,1,levs), qv_dt(im,1,levs),& + ql_dt(im,1,levs), qr_dt(im,1,levs), qi_dt(im,1,levs), qs_dt(im,1,levs),& + qg_dt(im,1,levs)) + endif endif #ifdef GFS_HYDRO @@ -661,7 +725,7 @@ subroutine GFS_physics_driver & frain = dtf / dtp - do i = 1, im + do i=1,im sigmaf(i) = max( Sfcprop%vfrac(i),0.01 ) islmsk(i) = nint(Sfcprop%slmsk(i)) @@ -687,7 +751,7 @@ subroutine GFS_physics_driver & cice(i) = Sfcprop%fice(i) tice(i) = Sfcprop%tisfc(i) ! -!GFDL work1(i) = (log(coslat(i) / (nlons(i)*latr)) - dxmin) * dxinv +!GFDL work1(i) = (log(coslat(i) / (nlons(i)*latr)) - dxmin) * dxinv !GFS Moorthi thinks this should be area and not dx ! work1(i) = (log(Grid%dx(i)) - dxmin) * dxinv work1(i) = (log(Grid%area(i)) - dxmin) * dxinv @@ -695,19 +759,19 @@ subroutine GFS_physics_driver & work2(i) = 1.0 - work1(i) Diag%psurf(i) = Statein%pgr(i) work3(i) = Statein%prsik(i,1) / Statein%prslk(i,1) -!GFDL tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i) -!GFDL tem2 = con_rerth * con_pi / latr -!GFDL garea(i) = tem1 * tem2 +!GFDL tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i) +!GFDL tem2 = con_rerth * con_pi / latr +!GFDL garea(i) = tem1 * tem2 tem1 = Grid%dx(i) tem2 = Grid%dx(i) garea(i) = Grid%area(i) dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) - cldf(i) = Model%cgwf(1)*work1(i) + Model%cgwf(2)*work2(i) - wcbmax(i) = Model%cs_parm(1)*work1(i) + Model%cs_parm(2)*work2(i) + cldf(i) = Model%cgwf(1) * work1(i) + Model%cgwf(2) * work2(i) + wcbmax(i) = Model%cs_parm(1) * work1(i) + Model%cs_parm(2) * work2(i) enddo ! if (Model%cplflx) then - do i = 1, im + do i=1,im islmsk_cice(i) = nint(Coupling%slimskin_cpl(i)) flag_cice(i) = (islmsk_cice(i) == 4) @@ -724,14 +788,29 @@ subroutine GFS_physics_driver & endif ! --- ... transfer soil moisture and temperature from global to local variables - smsoil(:,:) = Sfcprop%smc(:,:) - stsoil(:,:) = Sfcprop%stc(:,:) - slsoil(:,:) = Sfcprop%slc(:,:) !! clu: slc -> slsoil - dudt(:,:) = 0. - dvdt(:,:) = 0. - dtdt(:,:) = 0. - dtdtc(:,:) = 0. - dqdt(:,:,:) = 0. + do k=1,lsoil + do i=1,im + smsoil(i,k) = Sfcprop%smc(i,k) + stsoil(i,k) = Sfcprop%stc(i,k) + slsoil(i,k) = Sfcprop%slc(i,k) !! clu: slc -> slsoil + enddo + enddo + + do k=1,levs + do i=1,im + dudt(i,k) = 0. + dvdt(i,k) = 0. + dtdt(i,k) = 0. + dtdtc(i,k) = 0. + enddo + enddo + do n=1,ntrac + do k=1,levs + do i=1,im + dqdt(i,k,n) = 0. + enddo + enddo + enddo ! --- ... initialize dtdt with heating rate from dcyc2 @@ -765,8 +844,8 @@ subroutine GFS_physics_driver & ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & Statein%tgrs(1,1), Radtend%tsflw, Radtend%semis, & - Coupling%sfcdsw, Coupling%sfcnsw, Coupling%sfcdlw, & - Radtend%htrsw, Radtend%swhc, Radtend%htrlw, Radtend%lwhc, & + Coupling%sfcdsw, Coupling%sfcnsw, Coupling%sfcdlw, & + Radtend%htrsw, Radtend%swhc, Radtend%htrlw, Radtend%lwhc,& Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & @@ -813,7 +892,7 @@ subroutine GFS_physics_driver & ! interval) that solar radiation falling on a plane perpendicular to the ! direction of the sun >= 120 w/m2 - do i = 1, im + do i=1,im if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg tem1 = adjsfcdsw(i) / xcosz(i) if ( tem1 >= 120.0 ) then @@ -825,48 +904,59 @@ subroutine GFS_physics_driver & ! --- ... sfc lw fluxes used by atmospheric model are saved for output if (Model%cplflx) then - do i = 1, im + do i=1,im if (flag_cice(i)) adjsfculw(i) = ulwsfc_cice(i) enddo endif - Diag%dlwsfc(:) = Diag%dlwsfc(:) + adjsfcdlw(:)*dtf - Diag%ulwsfc(:) = Diag%ulwsfc(:) + adjsfculw(:)*dtf - Diag%psmean(:) = Diag%psmean(:) + Statein%pgr(:)*dtf ! mean surface pressure + do i=1,im + Diag%dlwsfc(i) = Diag%dlwsfc(i) + adjsfcdlw(i)*dtf + Diag%ulwsfc(i) = Diag%ulwsfc(i) + adjsfculw(i)*dtf + Diag%psmean(i) = Diag%psmean(i) + Statein%pgr(i)*dtf ! mean surface pressure + enddo if (Model%ldiag3d) then if (Model%lsidea) then - Diag%dt3dt(:,:,1) = Diag%dt3dt(:,:,1) + Radtend%lwhd(:,:,1)*dtf - Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + Radtend%lwhd(:,:,2)*dtf - Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + Radtend%lwhd(:,:,3)*dtf - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + Radtend%lwhd(:,:,4)*dtf - Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + Radtend%lwhd(:,:,5)*dtf - Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + Radtend%lwhd(:,:,6)*dtf + do k=1,levs + do i=1,im + Diag%dt3dt(i,k,1) = Diag%dt3dt(i,k,1) + Radtend%lwhd(i,k,1)*dtf + Diag%dt3dt(i,k,2) = Diag%dt3dt(i,k,2) + Radtend%lwhd(i,k,2)*dtf + Diag%dt3dt(i,k,3) = Diag%dt3dt(i,k,3) + Radtend%lwhd(i,k,3)*dtf + Diag%dt3dt(i,k,4) = Diag%dt3dt(i,k,4) + Radtend%lwhd(i,k,4)*dtf + Diag%dt3dt(i,k,5) = Diag%dt3dt(i,k,5) + Radtend%lwhd(i,k,5)*dtf + Diag%dt3dt(i,k,6) = Diag%dt3dt(i,k,6) + Radtend%lwhd(i,k,6)*dtf + enddo + enddo else - do k = 1, levs - Diag%dt3dt(:,k,1) = Diag%dt3dt(:,k,1) + Radtend%htrlw(:,k)*dtf - Diag%dt3dt(:,k,2) = Diag%dt3dt(:,k,2) + Radtend%htrsw(:,k)*dtf*xmu(:) + do k=1,levs + do i=1,im + Diag%dt3dt(i,k,1) = Diag%dt3dt(i,k,1) + Radtend%htrlw(i,k)*dtf + Diag%dt3dt(i,k,2) = Diag%dt3dt(i,k,2) + Radtend%htrsw(i,k)*dtf*xmu(i) + enddo enddo endif endif endif ! end if_lssav_block - kcnv(:) = 0 - kinver(:) = levs - invrsn(:) = .false. - tx1(:) = 0.0 - tx2(:) = 10.0 - ctei_r(:) = 10.0 + do i=1,im + kcnv(i) = 0 + kinver(i) = levs + invrsn(i) = .false. + tx1(i) = 0.0 + tx2(i) = 10.0 + ctei_r(i) = 10.0 + enddo ! Only used for old shallow convection with mstrat=.true. - if (((Model%imfshalcnv == 0 .and. Model%shal_cnv) .or. Model%old_monin) & - .and. Model%mstrat) then + if ((((Model%imfshalcnv == 0 .and. Model%shal_cnv) .or. Model%old_monin) & + .and. Model%mstrat) .or. Model%do_shoc) then ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) - do k = 1, levs/2 - do i = 1, im + do k=1,levs/2 + do i=1,im if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35*Statein%prsi(i,1) & .and. (.not. invrsn(i))) then - tem = (Statein%tgrs(i,k+1)-Statein%tgrs(i,k)) / (Statein%prsl(i,k)-Statein%prsl(i,k+1)) + tem = (Statein%tgrs(i,k+1) - Statein%tgrs(i,k)) & + / (Statein%prsl(i,k) - Statein%prsl(i,k+1)) if (((tem > 0.00010) .and. (tx1(i) < 0.0)) .or. & ((tem-abs(tx1(i)) > 0.0) .and. (tx2(i) < 0.0))) then @@ -880,7 +970,7 @@ subroutine GFS_physics_driver & ! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI ctei_r(i) = (1.0/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & - + Statein%qgrs(i,k+1,Model%ntcw)-Statein%qgrs(i,k,Model%ntcw)) + + Statein%qgrs(i,k+1,ntcw)-Statein%qgrs(i,k,ntcw)) else ctei_r(i) = 10 endif @@ -901,33 +991,35 @@ subroutine GFS_physics_driver & ! --- ... lu: initialize flag_guess, flag_iter, tsurf - tsurf(:) = Sfcprop%tsfc(:) - flag_guess(:) = .false. - flag_iter(:) = .true. - drain(:) = 0.0 - ep1d(:) = 0.0 - runof(:) = 0.0 - hflx(:) = 0.0 - evap(:) = 0.0 - evbs(:) = 0.0 - evcw(:) = 0.0 - trans(:) = 0.0 - sbsno(:) = 0.0 - snowc(:) = 0.0 - snohf(:) = 0.0 - Diag%zlvl(:) = Statein%phil(:,1) * onebg - Diag%smcwlt2(:) = 0.0 - Diag%smcref2(:) = 0.0 + do i=1,im + tsurf(i) = Sfcprop%tsfc(i) + flag_guess(i) = .false. + flag_iter(i) = .true. + drain(i) = 0.0 + ep1d(i) = 0.0 + runof(i) = 0.0 + hflx(i) = 0.0 + evap(i) = 0.0 + evbs(i) = 0.0 + evcw(i) = 0.0 + trans(i) = 0.0 + sbsno(i) = 0.0 + snowc(i) = 0.0 + snohf(i) = 0.0 + Diag%zlvl(i) = Statein%phil(i,1) * onebg + Diag%smcwlt2(i) = 0.0 + Diag%smcref2(i) = 0.0 + enddo ! --- ... lu: iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice) - do iter = 1, 2 + do iter=1,2 ! --- ... surface exchange coefficients ! -! if (lprnt) write(0,*)' tsea=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! if (lprnt) write(0,*)' tsfc=',Sfcprop%tsfc(ipr),' tsurf=',tsurf(ipr),iter - call sfc_diff (im,Statein%pgr, Statein%ugrs, Statein%vgrs, & + call sfc_diff (im, Statein%pgr, Statein%ugrs, Statein%vgrs, & Statein%tgrs, Statein%qgrs, Diag%zlvl, & Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%zorl, cd, & cdq, rb, Statein%prsl(1,1), work3, islmsk, stress, & @@ -938,7 +1030,7 @@ subroutine GFS_physics_driver & ! --- ... lu: update flag_guess - do i = 1, im + do i=1,im if (iter == 1 .and. wind(i) < 2.0) then flag_guess(i) = .true. endif @@ -946,15 +1038,15 @@ subroutine GFS_physics_driver & if (Model%nstf_name(1) > 0) then - do i = 1, im - if ( islmsk(i) == 0 ) then + do i=1,im + if (islmsk(i) == 0) then tem = (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse - tseal(i) = Sfcprop%tsfc(i) + tem - tsurf(i) = tsurf(i) + tem + tseal(i) = Sfcprop%tsfc(i) + tem + tsurf(i) = tsurf(i) + tem endif enddo - call sfc_nst (im, Model%lsoil, Statein%pgr, Statein%ugrs, & + call sfc_nst (im, lsoil, Statein%pgr, Statein%ugrs, & Statein%vgrs, Statein%tgrs, Statein%qgrs, & Sfcprop%tref, cd, cdq, Statein%prsl(1,1), work3, & islmsk, Grid%xlon, Grid%sinlat, stress, & @@ -971,11 +1063,11 @@ subroutine GFS_physics_driver & ! --- outputs: qss, gflx, Diag%cmm, Diag%chh, evap, hflx, ep1d) -! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), -! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), +! if (lprnt) write(0,*)' tseaz2=',tseal(ipr),' tref=', Sfcprop%tref(ipr), & +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), & ! & ' kdt=',kdt - do i = 1, im + do i=1,im if ( islmsk(i) == 0 ) then tsurf(i) = tsurf(i) - (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse endif @@ -986,10 +1078,10 @@ subroutine GFS_physics_driver & if (Model%nstf_name(1) > 1) then zsea1 = 0.001*real(Model%nstf_name(4)) zsea2 = 0.001*real(Model%nstf_name(5)) - call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & + call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & Sfcprop%z_c, Sfcprop%slmsk, zsea1, zsea2, & im, 1, dtzm) - do i = 1, im + do i=1,im if ( islmsk(i) == 0 ) then Sfcprop%tsfc(i) = max(271.2,Sfcprop%tref(i) + dtzm(i)) - & (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse @@ -997,7 +1089,7 @@ subroutine GFS_physics_driver & enddo endif -! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & +! if (lprnt) print *,' tseaz2=',Sfcprop%tsfc(ipr),' tref=',tref(ipr), & ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt else @@ -1014,21 +1106,21 @@ subroutine GFS_physics_driver & endif ! if ( nstf_name(1) > 0 ) then -! if (lprnt) write(0,*)' sfalb=',sfalb(ipr),' ipr=',ipr & -! &, ' weasd=',weasd(ipr),' snwdph=',snwdph(ipr) & -! &, ' tprcp=',tprcp(ipr),' kdt=',kdt,' iter=',iter & -! &,' tseabefland=',tsea(ipr) +! if (lprnt) write(0,*)' sfalb=',Radtend%sfalb(ipr),' ipr=',ipr & +! , ' weasd=',Sfcprop%weasd(ipr) & +! , ' tprcp=',Sfcprop%tprcp(ipr),' kdt=',kdt,' iter=',iter & +! ,' tseabefland=',Sfcprop%tsfc(ipr) ! --- ... surface energy balance over land ! if (Model%lsm == 1) then ! noah lsm call -! if (lprnt) write(0,*)' tsead=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! if (lprnt) write(0,*)' tsead=',tsea(ipr),' tsurf=',tsurf(ipr),iter & ! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr) call sfc_drv & ! --- inputs: - (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & + (im, lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & Statein%tgrs, Statein%qgrs, soiltyp, vegtype, sigmaf, & Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & Sfcprop%tg3, cd, cdq, Statein%prsl(1,1), work3, Diag%zlvl, & @@ -1045,18 +1137,18 @@ subroutine GFS_physics_driver & Diag%cmm, Diag%chh, evbs, evcw, sbsno, snowc, Diag%soilm, & snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) -! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter & ! &,' phy_f2d=',phy_f2d(ipr,num_p2d) endif -! if (lprnt) write(0,*)' tseabeficemodel =',tsea(ipr),' me=',me & +! if (lprnt) write(0,*)' tseabeficemodel =',Sfcprop%tsfc(ipr),' me=',me & ! &, ' kdt=',kdt ! --- ... surface energy balance over seaice if (Model%cplflx) then - do i = 1, im + do i=1,im if (flag_cice(i)) then islmsk (i) = islmsk_cice(i) endif @@ -1065,7 +1157,7 @@ subroutine GFS_physics_driver & call sfc_sice & ! --- inputs: - (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & + (im, lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & Statein%tgrs, Statein%qgrs, dtf, Radtend%semis, gabsbdlw, & adjsfcnsw, adjsfcdsw, Sfcprop%srflag, cd, cdq, & Statein%prsl(1,1), work3, islmsk, & @@ -1079,7 +1171,7 @@ subroutine GFS_physics_driver & hflx) if (Model%cplflx) then - do i = 1, im + do i=1,im if (flag_cice(i)) then islmsk(i) = nint(Sfcprop%slmsk(i)) endif @@ -1097,7 +1189,7 @@ subroutine GFS_physics_driver & ! --- ... lu: update flag_iter and flag_guess - do i = 1, im + do i=1,im flag_iter(i) = .false. flag_guess(i) = .false. @@ -1118,53 +1210,57 @@ subroutine GFS_physics_driver & enddo ! end iter_loop - Diag%epi(:) = ep1d(:) - Diag%dlwsfci(:) = adjsfcdlw(:) - Diag%ulwsfci(:) = adjsfculw(:) - Diag%uswsfci(:) = adjsfcdsw(:) - adjsfcnsw(:) - Diag%dswsfci(:) = adjsfcdsw(:) - Diag%gfluxi(:) = gflx(:) - Diag%t1(:) = Statein%tgrs(:,1) - Diag%q1(:) = Statein%qgrs(:,1,1) - Diag%u1(:) = Statein%ugrs(:,1) - Diag%v1(:) = Statein%vgrs(:,1) + do i=1,im + Diag%epi(i) = ep1d(i) + Diag%dlwsfci(i) = adjsfcdlw(i) + Diag%ulwsfci(i) = adjsfculw(i) + Diag%uswsfci(i) = adjsfcdsw(i) - adjsfcnsw(i) + Diag%dswsfci(i) = adjsfcdsw(i) + Diag%gfluxi(i) = gflx(i) + Diag%t1(i) = Statein%tgrs(i,1) + Diag%q1(i) = Statein%qgrs(i,1,1) + Diag%u1(i) = Statein%ugrs(i,1) + Diag%v1(i) = Statein%vgrs(i,1) + enddo ! --- ... update near surface fields call sfc_diag (im, Statein%pgr, Statein%ugrs, Statein%vgrs, & Statein%tgrs, Statein%qgrs, Sfcprop%tsfc, qss, & - Sfcprop%f10m, Diag%u10m, Diag%v10m, & - Sfcprop%t2m, Sfcprop%q2m, work3, evap, & + Sfcprop%f10m, Diag%u10m, Diag%v10m, & + Sfcprop%t2m, Sfcprop%q2m, work3, evap, & Sfcprop%ffmm, Sfcprop%ffhh, fm10, fh2) Tbd%phy_f2d(:,Model%num_p2d) = 0.0 if (Model%cplflx) then - Coupling%dlwsfci_cpl (:) = adjsfcdlw(:) - Coupling%dswsfci_cpl (:) = adjsfcdsw(:) - Coupling%dlwsfc_cpl (:) = Coupling%dlwsfc_cpl(:) + adjsfcdlw(:)*dtf - Coupling%dswsfc_cpl (:) = Coupling%dswsfc_cpl(:) + adjsfcdsw(:)*dtf - Coupling%dnirbmi_cpl (:) = adjnirbmd(:) - Coupling%dnirdfi_cpl (:) = adjnirdfd(:) - Coupling%dvisbmi_cpl (:) = adjvisbmd(:) - Coupling%dvisdfi_cpl (:) = adjvisdfd(:) - Coupling%dnirbm_cpl (:) = Coupling%dnirbm_cpl(:) + adjnirbmd(:)*dtf - Coupling%dnirdf_cpl (:) = Coupling%dnirdf_cpl(:) + adjnirdfd(:)*dtf - Coupling%dvisbm_cpl (:) = Coupling%dvisbm_cpl(:) + adjvisbmd(:)*dtf - Coupling%dvisdf_cpl (:) = Coupling%dvisdf_cpl(:) + adjvisdfd(:)*dtf - Coupling%nlwsfci_cpl (:) = adjsfcdlw(:) - adjsfculw(:) - Coupling%nlwsfc_cpl (:) = Coupling%nlwsfc_cpl(:) + Coupling%nlwsfci_cpl(:)*dtf - Coupling%t2mi_cpl (:) = Sfcprop%t2m(:) - Coupling%q2mi_cpl (:) = Sfcprop%q2m(:) - Coupling%u10mi_cpl (:) = Diag%u10m(:) - Coupling%v10mi_cpl (:) = Diag%v10m(:) - Coupling%tsfci_cpl (:) = Sfcprop%tsfc(:) - Coupling%psurfi_cpl (:) = Statein%pgr(:) + do i=1,im + Coupling%dlwsfci_cpl (i) = adjsfcdlw(i) + Coupling%dswsfci_cpl (i) = adjsfcdsw(i) + Coupling%dlwsfc_cpl (i) = Coupling%dlwsfc_cpl(i) + adjsfcdlw(i)*dtf + Coupling%dswsfc_cpl (i) = Coupling%dswsfc_cpl(i) + adjsfcdsw(i)*dtf + Coupling%dnirbmi_cpl (i) = adjnirbmd(i) + Coupling%dnirdfi_cpl (i) = adjnirdfd(i) + Coupling%dvisbmi_cpl (i) = adjvisbmd(i) + Coupling%dvisdfi_cpl (i) = adjvisdfd(i) + Coupling%dnirbm_cpl (i) = Coupling%dnirbm_cpl(i) + adjnirbmd(i)*dtf + Coupling%dnirdf_cpl (i) = Coupling%dnirdf_cpl(i) + adjnirdfd(i)*dtf + Coupling%dvisbm_cpl (i) = Coupling%dvisbm_cpl(i) + adjvisbmd(i)*dtf + Coupling%dvisdf_cpl (i) = Coupling%dvisdf_cpl(i) + adjvisdfd(i)*dtf + Coupling%nlwsfci_cpl (i) = adjsfcdlw(i) - adjsfculw(i) + Coupling%nlwsfc_cpl (i) = Coupling%nlwsfc_cpl(i) + Coupling%nlwsfci_cpl(i)*dtf + Coupling%t2mi_cpl (i) = Sfcprop%t2m(i) + Coupling%q2mi_cpl (i) = Sfcprop%q2m(i) + Coupling%u10mi_cpl (i) = Diag%u10m(i) + Coupling%v10mi_cpl (i) = Diag%v10m(i) + Coupling%tsfci_cpl (i) = Sfcprop%tsfc(i) + Coupling%psurfi_cpl (i) = Statein%pgr(i) + enddo ! --- estimate mean albedo for ocean point without ice cover and apply ! them to net SW heat fluxes - do i = 1, im + do i=1,im if (islmsk(i) /= 1) then ! not a land point ! --- compute open water albedo xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) @@ -1196,31 +1292,33 @@ subroutine GFS_physics_driver & endif if (Model%lssav) then - Diag%gflux(:) = Diag%gflux(:) + gflx(:) * dtf - Diag%evbsa(:) = Diag%evbsa(:) + evbs(:) * dtf - Diag%evcwa(:) = Diag%evcwa(:) + evcw(:) * dtf - Diag%transa(:) = Diag%transa(:) + trans(:) * dtf - Diag%sbsnoa(:) = Diag%sbsnoa(:) + sbsno(:) * dtf - Diag%snowca(:) = Diag%snowca(:) + snowc(:) * dtf - Diag%snohfa(:) = Diag%snohfa(:) + snohf(:) * dtf - Diag%ep(:) = Diag%ep(:) + ep1d(:) * dtf - - Diag%tmpmax(:) = max(Diag%tmpmax(:),Sfcprop%t2m(:)) - Diag%tmpmin(:) = min(Diag%tmpmin(:),Sfcprop%t2m(:)) - - Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) - Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) + do i=1,im + Diag%gflux(i) = Diag%gflux(i) + gflx(i) * dtf + Diag%evbsa(i) = Diag%evbsa(i) + evbs(i) * dtf + Diag%evcwa(i) = Diag%evcwa(i) + evcw(i) * dtf + Diag%transa(i) = Diag%transa(i) + trans(i) * dtf + Diag%sbsnoa(i) = Diag%sbsnoa(i) + sbsno(i) * dtf + Diag%snowca(i) = Diag%snowca(i) + snowc(i) * dtf + Diag%snohfa(i) = Diag%snohfa(i) + snohf(i) * dtf + Diag%ep(i) = Diag%ep(i) + ep1d(i) * dtf + + Diag%tmpmax(i) = max(Diag%tmpmax(i),Sfcprop%t2m(i)) + Diag%tmpmin(i) = min(Diag%tmpmin(i),Sfcprop%t2m(i)) + + Diag%spfhmax(i) = max(Diag%spfhmax(i),Sfcprop%q2m(i)) + Diag%spfhmin(i) = min(Diag%spfhmin(i),Sfcprop%q2m(i)) + enddo do i=1, im - !find max wind speed then decompose - tem = sqrt(Diag%u10m(i)**2 + Diag%v10m(i)**2 ) +! find max wind speed then decompose + tem = sqrt(Diag%u10m(i)*Diag%u10m(i) + Diag%v10m(i)*Diag%v10m(i)) if (tem > Diag%wind10mmax(i)) then Diag%wind10mmax(i) = tem Diag%u10mmax(i) = Diag%u10m(i) Diag%v10mmax(i) = Diag%v10m(i) endif - !Compute dew point, first using vapor pressure +! Compute dew point, first using vapor pressure tem = max(Statein%pgr(i) * Sfcprop%q2m(i) / ( con_eps - con_epsm1 * Sfcprop%q2m(i)), 1.e-8) Diag%dpt2m(i) = 243.5 / ( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 enddo @@ -1230,7 +1328,7 @@ subroutine GFS_physics_driver & endif !!!!!!!!!!!!!!!!!Commented by Moorthi on July 18, 2012 !!!!!!!!!!!!!!!!!!! -! do i = 1, im +! do i=1,im ! --- ... compute coefficient of evaporation in evapc ! ! if (evapc(i) > 1.0e0) evapc(i) = 1.0e0 @@ -1241,11 +1339,11 @@ subroutine GFS_physics_driver & ! --- ... Boundary Layer and Free atmospheic turbulence parameterization -! if (lprnt) write(0,*)' tsea3=',tsea(ipr),' slmsk=',slmsk(ipr) & +! if (lprnt) write(0,*)' tsea3=',Sfcprop%tsfc(ipr),' slmsk=',Sfcprop%slmsk(ipr) & ! &, ' kdt=',kdt,' evap=',evap(ipr) ! if (lprnt) write(0,*)' dtdtb=',(dtdt(ipr,k),k=1,15) -! do i = 1, im +! do i=1,im ! if (islmsk(i) == 0) then ! oro_land(i) = 0.0 ! else @@ -1254,48 +1352,116 @@ subroutine GFS_physics_driver & ! enddo ! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat - - if (Model%do_shoc) then - call moninshoc(ix, im, levs, ntrac, Model%ntcw, dvdt, dudt, dtdt, dqdt, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), prnum, Model%ntke, & - Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & - Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx,& - evap, stress, wind, kpbl, Statein%prsi, del, Statein%prsl,& - Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & - dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & - Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) +! if (lprnt) write(0,*)'befmonshoc=',Statein%tgrs(ipr,:) +! if (lprnt) write(0,*)'befmonshocdtdt=',dtdt(ipr,1:10) +! if (lprnt) write(0,*)'befmonshoctkh=',Tbd%phy_f3d(ipr,1:10,ntot3d-1) +! if (lprnt) write(0,*)'befmonshochflx=',hflx(ipr),' tsea=',Sfcprop%tsfc(ipr),& +! ' evap=',evap(ipr) + + if (nvdiff == ntrac) then + + do n=1,ntrac + do k=1,levs + do i=1,im + vdftra(i,k,n) = Statein%qgrs(i,k,n) + enddo + enddo + enddo else - if(Model%imp_physics==6) then - pbltra(:,:,1) = Statein%qgrs(:,:,1) - pbltra(:,:,2) = Statein%qgrs(:,:,Model%ntcw) - pbltra(:,:,3) = Statein%qgrs(:,:,Model%ntiw) - pbltra(:,:,4) = Statein%qgrs(:,:,Model%ntoz) - else if(Model%imp_physics==8) then + if (imp_physics == 6) then + do k=1,levs + do i=1,im + vdftra(i,k,1) = Statein%qgrs(i,k,1) + vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) + vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) + vdftra(i,k,4) = Statein%qgrs(i,k,ntoz) + enddo + enddo + elseif (imp_physics == 8) then if(Model%ltaerosol) then - pbltra(:,:,1) = Statein%qgrs(:,:,1) - pbltra(:,:,2) = Statein%qgrs(:,:,Model%ntcw) - pbltra(:,:,3) = Statein%qgrs(:,:,Model%ntiw) - pbltra(:,:,4) = Statein%qgrs(:,:,Model%ntlnc) - pbltra(:,:,5) = Statein%qgrs(:,:,Model%ntinc) - pbltra(:,:,6) = Statein%qgrs(:,:,Model%ntoz) - pbltra(:,:,7) = Statein%qgrs(:,:,Model%ntwa) - pbltra(:,:,8) = Statein%qgrs(:,:,Model%ntia) + do k=1,levs + do i=1,im + vdftra(i,k,1) = Statein%qgrs(i,k,1) + vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) + vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) + vdftra(i,k,4) = Statein%qgrs(i,k,ntlnc) + vdftra(i,k,5) = Statein%qgrs(i,k,ntinc) + vdftra(i,k,6) = Statein%qgrs(i,k,ntoz) + vdftra(i,k,7) = Statein%qgrs(i,k,ntwa) + vdftra(i,k,8) = Statein%qgrs(i,k,ntia) + enddo + enddo + else + do k=1,levs + do i=1,im + vdftra(i,k,1) = Statein%qgrs(i,k,1) + vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) + vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) + vdftra(i,k,4) = Statein%qgrs(i,k,ntinc) + vdftra(i,k,5) = Statein%qgrs(i,k,ntoz) + enddo + enddo + endif + + elseif (imp_physics == 10) then + if (abs(Model%fprcp) == 0) then + do k=1,levs + do i=1,im + vdftra(i,k,1) = Statein%qgrs(i,k,1) + vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) + vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) + vdftra(i,k,4) = Statein%qgrs(i,k,ntlnc) + vdftra(i,k,5) = Statein%qgrs(i,k,ntinc) + vdftra(i,k,6) = Statein%qgrs(i,k,ntoz) + enddo + enddo else - pbltra(:,:,1) = Statein%qgrs(:,:,1) - pbltra(:,:,2) = Statein%qgrs(:,:,Model%ntcw) - pbltra(:,:,3) = Statein%qgrs(:,:,Model%ntiw) - pbltra(:,:,4) = Statein%qgrs(:,:,Model%ntinc) - pbltra(:,:,5) = Statein%qgrs(:,:,Model%ntoz) + do k=1,levs + do i=1,im + vdftra(i,k,1) = Statein%qgrs(i,k,1) + vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) + vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) + vdftra(i,k,4) = Statein%qgrs(i,k,ntlnc) + vdftra(i,k,5) = Statein%qgrs(i,k,ntinc) + vdftra(i,k,6) = Statein%qgrs(i,k,ntrw) + vdftra(i,k,7) = Statein%qgrs(i,k,ntsw) + vdftra(i,k,8) = Statein%qgrs(i,k,ntrnc) + vdftra(i,k,9) = Statein%qgrs(i,k,ntsnc) + vdftra(i,k,10) = Statein%qgrs(i,k,ntoz) + enddo + enddo endif - else ! for all other MPs - pbltra(:,:,:)= Statein%qgrs(:,:,:) - endif + elseif (imp_physics == 11) then + do k=1,levs + do i=1,im + vdftra(i,k,1) = Statein%qgrs(i,k,1) + vdftra(i,k,2) = Statein%qgrs(i,k,ntcw) + vdftra(i,k,3) = Statein%qgrs(i,k,ntiw) + vdftra(i,k,4) = Statein%qgrs(i,k,ntrw) + vdftra(i,k,5) = Statein%qgrs(i,k,ntsw) + vdftra(i,k,6) = Statein%qgrs(i,k,ntgl) + vdftra(i,k,7) = Statein%qgrs(i,k,ntoz) + enddo + enddo + endif + endif +! + if (Model%do_shoc) then + call moninshoc(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Tbd%phy_f3d(1,1,ntot3d-1), prnum, ntke, & + Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & + Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx, & + evap, stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & + dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & + Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) +! if (lprnt) write(0,*)'aftmonshoc=',Statein%tgrs(ipr,:) +! if (lprnt) write(0,*)'aftmonshocdtdt=',dtdt(ipr,1:10) + else if (Model%hybedmf) then -!rsun call moninedmf(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt,& - call moninedmf(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dpbltra,& -!rsun Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, pbltra, & + call moninedmf(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, stress, & @@ -1308,75 +1474,134 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)' dtdtm=',(dtdt(ipr,k),k=1,15) ! if (lprnt) write(0,*)' dqdtm=',(dqdt(ipr,k,1),k=1,15) elseif (.not. Model%old_monin) then -! call moninq(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt, & - call moninq(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dpbltra, & -! Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, pbltra, & - Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb,& - Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap,& - stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & - Statein%prslk, Statein%phii, Statein%phil, dtp, & - Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & - gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & - Model%xkzm_s, lprnt, ipr, & + call moninq(ix, im, levs, nvdiff, ntcw, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, & + stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr, & Model%xkzminv, Model%moninq_fac, Model%rbcr) else if (Model%mstrat) then -! call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & - call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dpbltra, & -! Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs,& - Statein%ugrs, Statein%vgrs, Statein%tgrs, pbltra, & - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%prslk, & - Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & - dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & + call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%prslk, & + Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & + dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & Model%xkzm_m, Model%xkzm_h) else -! call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & - call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dpbltra, & -! Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & - Statein%ugrs, Statein%vgrs, Statein%tgrs, pbltra, & - Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & - Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & - Statein%prsi, del, Statein%prsl, Statein%phii, & - Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & + call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dvdftra, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, vdftra, & + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%phii, & + Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & Diag%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) endif endif ! end if_hybedmf - if(Model%imp_physics==6) then - dqdt(:,:,1) = dpbltra (:,:,1) - dqdt(:,:,Model%ntcw) = dpbltra (:,:,2) - dqdt(:,:,Model%ntiw) = dpbltra (:,:,3) - dqdt(:,:,Model%ntoz) = dpbltra (:,:,4) - else if(Model%imp_physics==8) then + endif ! end if_do_shoc +! + if (nvdiff == ntrac) then + + do n=1,ntrac + do k=1,levs + do i=1,im + dqdt(i,k,n) = dvdftra(i,k,n) + enddo + enddo + enddo + else + if (imp_physics == 6) then + do k=1,levs + do i=1,im + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntoz) = dvdftra(i,k,4) + enddo + enddo + elseif (imp_physics == 8) then if(Model%ltaerosol) then - dqdt(:,:,1) = dpbltra (:,:,1) - dqdt(:,:,Model%ntcw) = dpbltra (:,:,2) - dqdt(:,:,Model%ntlnc) = dpbltra (:,:,3) - dqdt(:,:,Model%ntiw) = dpbltra (:,:,4) - dqdt(:,:,Model%ntinc )= dpbltra (:,:,5) - dqdt(:,:,Model%ntoz) = dpbltra (:,:,6) - dqdt(:,:,Model%ntwa) = dpbltra (:,:,7) - dqdt(:,:,Model%ntia) = dpbltra (:,:,8) + do k=1,levs + do i=1,im + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntlnc) = dvdftra(i,k,3) + dqdt(i,k,ntiw) = dvdftra(i,k,4) + dqdt(i,k,ntinc) = dvdftra(i,k,5) + dqdt(i,k,ntoz) = dvdftra(i,k,6) + dqdt(i,k,ntwa) = dvdftra(i,k,7) + dqdt(i,k,ntia) = dvdftra(i,k,8) + enddo + enddo + else + do k=1,levs + do i=1,im + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntinc) = dvdftra(i,k,4) + dqdt(i,k,ntoz) = dvdftra(i,k,5) + enddo + enddo + endif + + elseif (imp_physics == 10) then + if (abs(Model%fprcp) == 0) then + do k=1,levs + do i=1,im + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntlnc) = dvdftra(i,k,4) + dqdt(i,k,ntinc) = dvdftra(i,k,5) + dqdt(i,k,ntoz) = dvdftra(i,k,6) + enddo + enddo else - dqdt(:,:,1) = dpbltra (:,:,1) - dqdt(:,:,Model%ntcw) = dpbltra (:,:,2) - dqdt(:,:,Model%ntiw) = dpbltra (:,:,3) - dqdt(:,:,Model%ntinc )= dpbltra (:,:,4) - dqdt(:,:,Model%ntoz) = dpbltra (:,:,5) + do k=1,levs + do i=1,im + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntlnc) = dvdftra(i,k,4) + dqdt(i,k,ntinc) = dvdftra(i,k,5) + dqdt(i,k,ntrw) = dvdftra(i,k,6) + dqdt(i,k,ntsw) = dvdftra(i,k,7) + dqdt(i,k,ntrnc) = dvdftra(i,k,8) + dqdt(i,k,ntlnc) = dvdftra(i,k,9) + dqdt(i,k,ntoz) = dvdftra(i,k,10) + enddo + enddo endif - else ! for other MPs - dqdt(:,:,:) = dpbltra (:,:,:) - endif - endif ! end if_do_shoc + elseif (imp_physics == 11) then + do k=1,levs + do i=1,im + dqdt(i,k,1) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntsw) = dvdftra(i,k,5) + dqdt(i,k,ntgl) = dvdftra(i,k,6) + dqdt(i,k,ntoz) = dvdftra(i,k,7) + enddo + enddo + endif + endif + + deallocate(vdftra, dvdftra) if (Model%cplflx) then - do i = 1, im + do i=1,im if (flag_cice(i)) then - cice(i) = fice_cice(i) - Sfcprop%tsfc(i) = tsea_cice(i) + cice(i) = fice_cice(i) + Sfcprop%tsfc(i) = tsea_cice(i) dusfc1(i) = dusfc_cice(i) dvsfc1(i) = dvsfc_cice(i) dqsfc1(i) = dqsfc_cice(i) @@ -1397,25 +1622,29 @@ subroutine GFS_physics_driver & ! --- ... coupling insertion if (Model%cplflx) then - Coupling%dusfc_cpl (:) = Coupling%dusfc_cpl(:) + dusfc1(:)*dtf - Coupling%dvsfc_cpl (:) = Coupling%dvsfc_cpl(:) + dvsfc1(:)*dtf - Coupling%dtsfc_cpl (:) = Coupling%dtsfc_cpl(:) + dtsfc1(:)*dtf - Coupling%dqsfc_cpl (:) = Coupling%dqsfc_cpl(:) + dqsfc1(:)*dtf - Coupling%dusfci_cpl(:) = dusfc1(:) - Coupling%dvsfci_cpl(:) = dvsfc1(:) - Coupling%dtsfci_cpl(:) = dtsfc1(:) - Coupling%dqsfci_cpl(:) = dqsfc1(:) + do i=1,im + Coupling%dusfc_cpl (i) = Coupling%dusfc_cpl(i) + dusfc1(i)*dtf + Coupling%dvsfc_cpl (i) = Coupling%dvsfc_cpl(i) + dvsfc1(i)*dtf + Coupling%dtsfc_cpl (i) = Coupling%dtsfc_cpl(i) + dtsfc1(i)*dtf + Coupling%dqsfc_cpl (i) = Coupling%dqsfc_cpl(i) + dqsfc1(i)*dtf + Coupling%dusfci_cpl(i) = dusfc1(i) + Coupling%dvsfci_cpl(i) = dvsfc1(i) + Coupling%dtsfci_cpl(i) = dtsfc1(i) + Coupling%dqsfci_cpl(i) = dqsfc1(i) + enddo endif !-------------------------------------------------------lssav if loop ---------- if (Model%lssav) then - Diag%dusfc (:) = Diag%dusfc(:) + dusfc1(:)*dtf - Diag%dvsfc (:) = Diag%dvsfc(:) + dvsfc1(:)*dtf - Diag%dtsfc (:) = Diag%dtsfc(:) + dtsfc1(:)*dtf - Diag%dqsfc (:) = Diag%dqsfc(:) + dqsfc1(:)*dtf - Diag%dusfci(:) = dusfc1(:) - Diag%dvsfci(:) = dvsfc1(:) - Diag%dtsfci(:) = dtsfc1(:) - Diag%dqsfci(:) = dqsfc1(:) + do i=1,im + Diag%dusfc (i) = Diag%dusfc(i) + dusfc1(i)*dtf + Diag%dvsfc (i) = Diag%dvsfc(i) + dvsfc1(i)*dtf + Diag%dtsfc (i) = Diag%dtsfc(i) + dtsfc1(i)*dtf + Diag%dqsfc (i) = Diag%dqsfc(i) + dqsfc1(i)*dtf + Diag%dusfci(i) = dusfc1(i) + Diag%dvsfci(i) = dvsfc1(i) + Diag%dtsfci(i) = dtsfc1(i) + Diag%dqsfci(i) = dqsfc1(i) + enddo ! if (lprnt) then ! write(0,*)' dusfc=',dusfc(ipr),' dusfc1=',dusfc1(ipr),' dtf=', ! & dtf,' kdt=',kdt,' lat=',lat @@ -1423,35 +1652,43 @@ subroutine GFS_physics_driver & if (Model%ldiag3d) then if (Model%lsidea) then - Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + dtdt(:,:)*dtf + Diag%dt3dt(1:im,:,3) = Diag%dt3dt(1:im,:,3) + dtdt(1:im,:)*dtf else - do k = 1, levs - do i = 1, im - tem = dtdt(i,k) - (Radtend%htrlw(i,k)+Radtend%htrsw(i,k)*xmu(i)) + do k=1,levs + do i=1,im + tem = dtdt(i,k) - (Radtend%htrlw(i,k)+Radtend%htrsw(i,k)*xmu(i)) Diag%dt3dt(i,k,3) = Diag%dt3dt(i,k,3) + tem*dtf enddo enddo endif - Diag%du3dt(:,:,1) = Diag%du3dt(:,:,1) + dudt(:,:) * dtf - Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) - dudt(:,:) * dtf - Diag%dv3dt(:,:,1) = Diag%dv3dt(:,:,1) + dvdt(:,:) * dtf - Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) - dvdt(:,:) * dtf + do k=1,levs + do i=1,im + Diag%du3dt(i,k,1) = Diag%du3dt(i,k,1) + dudt(i,k) * dtf + Diag%du3dt(i,k,2) = Diag%du3dt(i,k,2) - dudt(i,k) * dtf + Diag%dv3dt(i,k,1) = Diag%dv3dt(i,k,1) + dvdt(i,k) * dtf + Diag%dv3dt(i,k,2) = Diag%dv3dt(i,k,2) - dvdt(i,k) * dtf + enddo + enddo ! update dqdt_v to include moisture tendency due to vertical diffusion ! if (lgocart) then -! do k = 1, levs -! do i = 1, im +! do k=1,levs +! do i=1,im ! dqdt_v(i,k) = dqdt(i,k,1) * dtf ! enddo ! enddo ! endif - do k = 1, levs - do i = 1, im + do k=1,levs + do i=1,im tem = dqdt(i,k,1) * dtf Diag%dq3dt(i,k,1) = Diag%dq3dt(i,k,1) + tem enddo enddo - if (Model%ntoz > 0) then - Diag%dq3dt(:,:,5) = Diag%dq3dt(:,:,5) + dqdt(i,k,Model%ntoz) * dtf + if (ntoz > 0) then + do k=1,levs + do i=1,im + Diag%dq3dt(i,k,5) = Diag%dq3dt(i,k,5) + dqdt(i,k,ntoz) * dtf + enddo + enddo endif endif @@ -1462,45 +1699,52 @@ subroutine GFS_physics_driver & ! --------------------------------------------- if (Model%nmtvr == 14) then ! current operational - as of 2014 - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = Sfcprop%hprime(:,7) - clx(:,2) = Sfcprop%hprime(:,8) - clx(:,3) = Sfcprop%hprime(:,9) - clx(:,4) = Sfcprop%hprime(:,10) - theta(:) = Sfcprop%hprime(:,11) - gamma(:) = Sfcprop%hprime(:,12) - sigma(:) = Sfcprop%hprime(:,13) - elvmax(:) = Sfcprop%hprime(:,14) + do i=1,im + oc(i) = Sfcprop%hprime(i,2) + oa4(i,1) = Sfcprop%hprime(i,3) + oa4(i,2) = Sfcprop%hprime(i,4) + oa4(i,3) = Sfcprop%hprime(i,5) + oa4(i,4) = Sfcprop%hprime(i,6) + clx(i,1) = Sfcprop%hprime(i,7) + clx(i,2) = Sfcprop%hprime(i,8) + clx(i,3) = Sfcprop%hprime(i,9) + clx(i,4) = Sfcprop%hprime(i,10) + theta(i) = Sfcprop%hprime(i,11) + gamma(i) = Sfcprop%hprime(i,12) + sigma(i) = Sfcprop%hprime(i,13) + elvmax(i) = Sfcprop%hprime(i,14) + enddo elseif (Model%nmtvr == 10) then - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = Sfcprop%hprime(:,7) - clx(:,2) = Sfcprop%hprime(:,8) - clx(:,3) = Sfcprop%hprime(:,9) - clx(:,4) = Sfcprop%hprime(:,10) + do i=1,im + oc(i) = Sfcprop%hprime(i,2) + oa4(i,1) = Sfcprop%hprime(i,3) + oa4(i,2) = Sfcprop%hprime(i,4) + oa4(i,3) = Sfcprop%hprime(i,5) + oa4(i,4) = Sfcprop%hprime(i,6) + clx(i,1) = Sfcprop%hprime(i,7) + clx(i,2) = Sfcprop%hprime(i,8) + clx(i,3) = Sfcprop%hprime(i,9) + clx(i,4) = Sfcprop%hprime(i,10) + enddo elseif (Model%nmtvr == 6) then - oc(:) = Sfcprop%hprime(:,2) - oa4(:,1) = Sfcprop%hprime(:,3) - oa4(:,2) = Sfcprop%hprime(:,4) - oa4(:,3) = Sfcprop%hprime(:,5) - oa4(:,4) = Sfcprop%hprime(:,6) - clx(:,1) = 0.0 - clx(:,2) = 0.0 - clx(:,3) = 0.0 - clx(:,4) = 0.0 + do i=1,im + oc(i) = Sfcprop%hprime(i,2) + oa4(i,1) = Sfcprop%hprime(i,3) + oa4(i,2) = Sfcprop%hprime(i,4) + oa4(i,3) = Sfcprop%hprime(i,5) + oa4(i,4) = Sfcprop%hprime(i,6) + clx(i,1) = 0.0 + clx(i,2) = 0.0 + clx(i,3) = 0.0 + clx(i,4) = 0.0 + enddo else oc = 0 ; oa4 = 0 ; clx = 0 ; theta = 0 ; gamma = 0 ; sigma = 0 elvmax = 0 endif ! end if_nmtvr +! if (lprnt) write(0,*)' dtdtbgwd=',(dtdt(ipr,k),k=1,10) ! write(0,*)' before gwd clstp=',clstp,' kdt=',kdt,' lat=',lat call gwdps(im, ix, im, levs, dvdt, dudt, dtdt, & Statein%ugrs, Statein%vgrs, Statein%tgrs, & @@ -1516,18 +1760,25 @@ subroutine GFS_physics_driver & ! if (lprnt) print *,' dudtg=',dudt(ipr,:) if (Model%lssav) then - Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf - Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf + do i=1,im + Diag%dugwd(i) = Diag%dugwd(i) + dusfcg(i)*dtf + Diag%dvgwd(i) = Diag%dvgwd(i) + dvsfcg(i)*dtf + enddo ! if (lprnt) print *,' dugwd=',dugwd(ipr),' dusfcg=',dusfcg(ipr) ! if (lprnt) print *,' dvgwd=',dvgwd(ipr),' dvsfcg=',dvsfcg(ipr) if (Model%ldiag3d) then - Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) + dudt(:,:) * dtf - Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) + dvdt(:,:) * dtf - Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + dtdt(:,:) * dtf + do k=1,levs + do i=1,im + Diag%du3dt(i,k,2) = Diag%du3dt(i,k,2) + dudt(i,k) * dtf + Diag%dv3dt(i,k,2) = Diag%dv3dt(i,k,2) + dvdt(i,k) * dtf + Diag%dt3dt(i,k,2) = Diag%dt3dt(i,k,2) + dtdt(i,k) * dtf + enddo + enddo endif endif +! if (lprnt) write(0,*)' dtdtray=',(dtdt(ipr,k),k=1,10) ! Rayleigh damping near the model top if( .not. Model%lsidea .and. Model%ral_ts > 0.0) then @@ -1538,15 +1789,20 @@ subroutine GFS_physics_driver & endif ! if (lprnt) then -! write(0,*)' tgrs1=',(tgrs(ipr,ik),k=1,10) -! write(0,*)' dtdt=',(dtdt(ipr,ik),k=1,10) +! write(0,*)' tgrs1=',(Statein%tgrs(ipr,k),k=1,10) +! write(0,*)' dtdt=',(dtdt(ipr,k),k=1,10) ! endif - Stateout%gt0(:,:) = Statein%tgrs(:,:) + dtdt(:,:) * dtp - Stateout%gu0(:,:) = Statein%ugrs(:,:) + dudt(:,:) * dtp - Stateout%gv0(:,:) = Statein%vgrs(:,:) + dvdt(:,:) * dtp - Stateout%gq0(:,:,:) = Statein%qgrs(:,:,:) + dqdt(:,:,:) * dtp + do k=1,levs + do i=1,im + Stateout%gt0(i,k) = Statein%tgrs(i,k) + dtdt(i,k) * dtp + Stateout%gu0(i,k) = Statein%ugrs(i,k) + dudt(i,k) * dtp + Stateout%gv0(i,k) = Statein%vgrs(i,k) + dvdt(i,k) * dtp + enddo + enddo + Stateout%gq0(1:im,:,:) = Statein%qgrs(1:im,:,:) + dqdt(1:im,:,:) * dtp +! if (lprnt) write(0,*)' gt00=',(Stateout%gt0(ipr,k),k=1,10) ! if (lprnt) then ! write(7000,*)' ugrs=',ugrs(ipr,:) ! &,' lat=',lat,' kdt=',kdt,' me=',me @@ -1563,32 +1819,40 @@ subroutine GFS_physics_driver & ! --- ... ozone physics - if ((Model%ntoz > 0) .and. (ntrac >= Model%ntoz)) then + if (ntoz > 0 .and. ntrac >= ntoz) then if (oz_coeff > 4) then call ozphys_2015 (ix, im, levs, levozp, dtp, & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gq0(1,1,Model%ntoz), & + Stateout%gq0(1,1,ntoz), & + Stateout%gq0(1,1,ntoz), & Stateout%gt0, oz_pres, Statein%prsl, & Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & dq3dt_loc(1,1,6), me) if (Model%ldiag3d) then - Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) - Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) - Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) - Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) + do k=1,levs + do i=1,im + Diag%dq3dt(i,k,6) = dq3dt_loc(i,k,6) + Diag%dq3dt(i,k,7) = dq3dt_loc(i,k,7) + Diag%dq3dt(i,k,8) = dq3dt_loc(i,k,8) + Diag%dq3dt(i,k,9) = dq3dt_loc(i,k,9) + enddo + enddo endif else call ozphys (ix, im, levs, levozp, dtp, & - Stateout%gq0(1,1,Model%ntoz), & - Stateout%gq0(1,1,Model%ntoz), & + Stateout%gq0(1,1,ntoz), & + Stateout%gq0(1,1,ntoz), & Stateout%gt0, oz_pres, Statein%prsl, & Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & dq3dt_loc(1,1,6), me) if (Model%ldiag3d) then - Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) - Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) - Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) - Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) + do k=1,levs + do i=1,im + Diag%dq3dt(i,k,6) = dq3dt_loc(i,k,6) + Diag%dq3dt(i,k,7) = dq3dt_loc(i,k,7) + Diag%dq3dt(i,k,8) = dq3dt_loc(i,k,8) + Diag%dq3dt(i,k,9) = dq3dt_loc(i,k,9) + enddo + enddo endif endif endif @@ -1617,8 +1881,8 @@ subroutine GFS_physics_driver & ! print *,' prsl=',prsl(ipr,:) ! print *,' prslk=',prslk(ipr,:) ! print *,' rann=',rann(ipr,1) -! write(0,*)' gt0=',gt0(ipr,:) & -! &, ' kdt=',kdt,' xlon=',xlon(ipr),' xlat=',xlat(ipr) +! write(0,*)' gt0=',Stateout%gt0(ipr,:) & +! &, ' kdt=',kdt,' xlon=',grid%xlon(ipr),' xlat=',grid%xlat(ipr) ! print *,' dtdt=',dtdt(ipr,:) ! print *,' gu0=',gu0(ipr,:) ! print *,' gv0=',gv0(ipr,:) @@ -1633,15 +1897,19 @@ subroutine GFS_physics_driver & ! if (lprnt) write(7000,*)' bef convection gv0=',gv0(ipr,:) if (Model%ldiag3d) then - dtdt(:,:) = Stateout%gt0(:,:) - dudt(:,:) = Stateout%gu0(:,:) - dvdt(:,:) = Stateout%gv0(:,:) + do k=1,levs + do i=1,im + dtdt(i,k) = Stateout%gt0(i,k) + dudt(i,k) = Stateout%gu0(i,k) + dvdt(i,k) = Stateout%gv0(i,k) + enddo + enddo elseif (Model%cnvgwd) then - dtdt(:,:) = Stateout%gt0(:,:) + dtdt(1:im,:) = Stateout%gt0(1:im,:) endif ! end if_ldiag3d/cnvgwd if (Model%ldiag3d .or. Model%lgocart) then - dqdt(:,:,1) = Stateout%gq0(:,:,1) + dqdt(1:im,:,1) = Stateout%gq0(1:im,:,1) endif ! end if_ldiag3d/lgocart #ifdef GFS_HYDRO @@ -1660,14 +1928,22 @@ subroutine GFS_physics_driver & ! print *,' phil2=',phil(ipr,:) ! endif - clw(:,:,1) = 0.0 - clw(:,:,2) = -999.9 + do k=1,levs + do i=1,im + clw(i,k,1) = 0.0 + clw(i,k,2) = -999.9 + enddo + enddo if ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then - cnvc(:,:) = 0.0 - cnvw(:,:) = 0.0 + do k=1,levs + do i=1,im + cnvc(i,k) = 0.0 + cnvw(i,k) = 0.0 + enddo + enddo endif - if(Model%imp_physics==8) then + if(imp_physics == 8) then if(Model%ltaerosol) then ice00 (:,:) = 0.0 liq0 (:,:) = 0.0 @@ -1678,94 +1954,188 @@ subroutine GFS_physics_driver & ! write(0,*)' before cnv clstp=',clstp,' kdt=',kdt,' lat=',lat -! --- ... for convective tracer transport (while using ras) - - if (Model%ras .or. Model%cscnv) then - if (tottracer > 0) then - if (Model%ntoz > 0) then - clw(:,:,3) = Stateout%gq0(:,:,Model%ntoz) - if (tracers > 0) then - do n=1,tracers - clw(:,:,3+n) = Stateout%gq0(:,:,n+trc_shft) +! --- ... for convective tracer transport (while using ras or csaw) +! (the code here implicitly assumes that ntiw=ntcw+1) + + ntk = 0 + tottracer = 0 + if (Model%cscnv .or. Model%trans_trac ) then + otspt(:,:) = .true. ! otspt is used only for cscnv + otspt(1:3,:) = .false. ! this is for sp.hum, ice and liquid water + tracers = 2 + do n=2,ntrac + if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & + n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntsnc .and. n /= ntgl) then + tracers = tracers + 1 + do k=1,levs + do i=1,im + clw(i,k,tracers) = Stateout%gq0(i,k,n) enddo - endif - else - do n=1,tracers - clw(:,:,2+n) = Stateout%gq0(:,:,n+trc_shft) enddo + if (ntke == n ) then + otspt(tracers+1,1) = .false. + ntk = tracers + endif + if (ntlnc == n .or. ntinc == n .or. ntrnc == n .or. ntsnc == n) & +! if (ntlnc == n .or. ntinc == n .or. ntrnc == n .or. ntsnc == n .or.& +! ntrw == n .or. ntsw == n .or. ntgl == n) & + otspt(tracers+1,1) = .false. endif - endif + enddo + tottracer = tracers - 2 endif ! end if_ras or cfscnv - ktop(:) = 1 - kbot(:) = levs + if (kdt == 1 .and. me == 0) & + write(0,*)' trans_trac=',Model%trans_trac,' tottracer=', & + & tottracer,' kdt=',kdt,' ntk=',ntk + + do i=1,im + ktop(i) = 1 + kbot(i) = levs + enddo ! --- ... calling condensation/precipitation processes ! -------------------------------------------- - if (Model%ntcw > 0) then - do k=1,levs + if (ntcw > 0) then + if (imp_physics == 10 .and. .not. Model%do_shoc) then ! compute rhc for GMAO macro physics cloud pdf do i=1,im - tem = rhbbot - (rhbbot-rhbtop) * (1.0-Statein%prslk(i,k)) - tem = rhc_max * work1(i) + tem * work2(i) - rhc(i,k) = max(0.0, min(1.0,tem)) + tx1(i) = 1.0 / Statein%prsi(i,1) + tx2(i) = 1.0 - rhbbot enddo - enddo - if (Model%imp_physics == 99 .or. Model%imp_physics==98) then - psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) - prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) - clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) - else if (Model%imp_physics == 11) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) - else if (Model%imp_physics == 8) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - if(Model%ltaerosol) then - ice00(:,:) = clw(:,:,1) - liq0(:,:) = clw(:,:,2) - else - ice00(:,:) = clw(:,:,1) - endif - else if (Model%imp_physics == 6.or.Model%imp_physics == 10) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - endif + do k = 1, levs + do i = 1, im + tem = Statein%prsl(i,k) * tx1(i) + tem1 = min(max((tem-turnrhcrit)/slope_mg, -20.0), 20.0) +! tem2 = min(max((0.3-0.2*abs(cos(Grid%xlat(i)))-tem)/slope_upmg, -20.0), 20.0) ! Anning + tem2 = min(max((turnrhcrit_upper-tem)/slope_upmg, -20.0), 20.0) + if (islmsk(i) > 0) then + tem1 = 1.0 / (1.0+exp(tem1+tem1)) + else + tem1 = 2.0 / (1.0+exp(tem1+tem1)) + endif + tem2 = 1.0 / (1.0+exp(tem2)) - else ! if_ntcw - psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) - prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) - rhc(:,:) = 1.0 - endif ! end if_ntcw -! -! Call SHOC if do_shoc is true and shocaftcnv is false -! - if (Model%do_shoc .and. .not. Model%shocaftcnv) then - if (Model%ncld == 2) then - skip_macro = Model%do_shoc - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) - ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) - elseif (Model%num_p3d == 4) then +! rhc(i,k) = min(rhc_max, max(0.7, 1.0-tx2(i)*tem1*tem2)) + rhc(i,k) = min(rhc_max, rhc_max*work1(i) + (1.0-tx2(i)*tem1*tem2)*work2(i)) + enddo + enddo + else do k=1,levs do i=1,im - qpl(i,k) = 0.0 - qpi(i,k) = 0.0 - if (abs(Stateout%gq0(i,k,Model%ntcw)) < epsq) then - Stateout%gq0(i,k,Model%ntcw) = 0.0 + kk = max(10,kpbl(i)) + if (k < kk) then + tem = rhbbot - (rhbbot-rhpbl) * (1.0-Statein%prslk(i,k)) & + / (1.0-Statein%prslk(i,kk)) + else + tem = rhpbl - (rhpbl-rhbtop) * (Statein%prslk(i,kk)-Statein%prslk(i,k)) & + / Statein%prslk(i,kk) endif - tem = Stateout%gq0(i,k,Model%ntcw) & - & * max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) - clw(i,k,1) = tem ! ice - clw(i,k,2) = Stateout%gq0(i,k,Model%ntcw) - tem ! water + tem = rhc_max * work1(i) + tem * work2(i) + rhc(i,k) = max(0.0, min(1.0,tem)) enddo enddo endif + endif ! ntcw > 0 +! if(kdt == 1) write(1000+me,*)' rhc=',rhc(1,:) +! if (lprnt) write(0,*)' rhc=',rhc(ipr,:) +! if(kdt == 1) write(1000+me,*)' rhc=',rhc(1,:),' work1=',work1(1),' work2=',work2(1) +! + if (imp_physics == 99 .or. imp_physics == 98) then ! zhao-carr microphysics + do i=1,im + psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) + prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) + enddo + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntcw) + enddo + enddo + elseif (imp_physics == 11) then + clw(1:im,:,1) = Stateout%gq0(1:im,:,ntcw) + elseif (imp_physics == 8) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + enddo + enddo + if(Model%ltaerosol) then + ice00(:,:) = clw(:,:,1) + liq0(:,:) = clw(:,:,2) + else + ice00(:,:) = clw(:,:,1) + endif + elseif (imp_physics == 6 .or. imp_physics == 10) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + enddo + enddo + else ! if_ntcw + do i=1,im + psautco_l(i) = Model%psautco(1)*work1(i) + Model%psautco(2)*work2(i) + prautco_l(i) = Model%prautco(1)*work1(i) + Model%prautco(2)*work2(i) + enddo + rhc(:,:) = 1.0 + endif ! end if_ntcw +! +! Call SHOC if do_shoc is true and shocaftcnv is false +! + if (Model%do_shoc .and. .not. Model%shocaftcnv) then + if (imp_physics == 10) then + skip_macro = Model%do_shoc + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + ncpl(i,k) = Stateout%gq0(i,k,ntlnc) + ncpi(i,k) = Stateout%gq0(i,k,ntinc) + enddo + enddo + if (abs(Model%fprcp) == 1) then + do k=1,levs + do i=1,im + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + enddo + enddo + endif + elseif (imp_physics == 11) then ! GFDL MP - needs modify for condensation + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + enddo + enddo + elseif (imp_physics == 99 .or. imp_physics == 98) then + do k=1,levs + do i=1,im + if (abs(Stateout%gq0(i,k,ntcw)) < epsq) then + Stateout%gq0(i,k,ntcw) = 0.0 + endif + tem = Stateout%gq0(i,k,ntcw) & + & * max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) + clw(i,k,1) = tem ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) - tem ! water + enddo + enddo + endif + +! if (lprnt) write(0,*)'gt01=',Stateout%gt0(ipr,:) +! if (lprnt) write(0,*)'gq01=',Stateout%gq0(ipr,1:20,1) +! if (lprnt) write(0,*)'clwi=',clw(ipr,1:20,1) +! if (lprnt) write(0,*)'clwl=',clw(ipr,1:10,2) ! dtshoc = 60.0 ! dtshoc = 120.0 ! dtshoc = dtp -! nshocm = (dtp/dtshoc) + 0.001 +! dtshoc = min(dtp, 300.0) +! nshocm = max(1, nint(dtp/dtshoc)) ! dtshoc = dtp / nshocm ! do nshoc=1,nshocm ! if (lprnt) write(1000+me,*)' before shoc tke=',clw(ipr,:,ntk), @@ -1780,27 +2150,36 @@ subroutine GFS_physics_driver & ! dqdt(1:im,:,3) = gq0(1:im,:,ntcw) !GFDL lat has no meaning inside of shoc - changed to "1" !GFDL call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, +! call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & +! call shoc (ix, im, 1, levs, levs+1, dtshoc, me, 1, Statein%prsl(1,1), & call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & - Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl, & - rhc, Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qsnw, qrn, & + rhc, Model%sup, Model%shoc_pcrit, & + Tbd%phy_f3d(1,1,ntot3d-2), & clw(1,1,ntk), hflx, evap, prnum, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), & - Tbd%phy_f3d(1,1,Model%ntot3d), lprnt, ipr, ncpl, ncpi, kdt) + Tbd%phy_f3d(1,1,ntot3d-1), & + Tbd%phy_f3d(1,1,ntot3d), lprnt, ipr, ncpl, ncpi) -! if (lprnt) write(0,*)' aftshoccld=',phy_f3d(ipr,:,ntot3d-2)*100 +! enddo +! if (lprnt) write(0,*)'aftshocgt0=',Stateout%gt0(ipr,:) +! if (lprnt) write(0,*)' aftshoccld=',tbd%phy_f3d(ipr,:,ntot3d-2)*100 ! if (lprnt) write(0,*)' aftshocice=',clw(ipr,:,1) ! if (lprnt) write(0,*)' aftshocwat=',clw(ipr,:,1) ! write(1000+me,*)' at latitude = ',lat ! rain1 = 0.0 ! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 -! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) -! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),'shoc ') +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),'shoc ') - if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then - Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) - Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) + if (ntlnc > 0 .and. ntinc > 0 .and. ncld >= 2) then + do k=1,levs + do i=1,im + Stateout%gq0(i,k,ntlnc) = ncpl(i,k) + Stateout%gq0(i,k,ntinc) = ncpi(i,k) + enddo + enddo endif ! do k=1,levs ! do i=1,im @@ -1826,133 +2205,120 @@ subroutine GFS_physics_driver & ! endif ! if(do_shoc) -! --- ... calling convective parameterization ! - if (.not. Model%ras .and. .not. Model%cscnv) then - - if (Model%do_deep) then +! --- ... calling convective parameterization +! ----------------------------------- + if (Model%do_deep) then + if (.not. Model%ras .and. .not. Model%cscnv) then if (Model%imfdeepcnv == 1) then ! no random cloud top - call sascnvn (im, ix, levs, Model%jcap, dtp, del, & - Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & + call sascnvn (im, ix, levs, Model%jcap, dtp, del, & + Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & Stateout%gq0(:,:,1), Stateout%gt0, Stateout%gu0, & - Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & - islmsk, Statein%vvl, Model%ncld, ud_mf, dd_mf, & - dt_mf, cnvw, cnvc, & - Model%clam_deep, Model%c0s_deep, & - Model%c1_deep, Model%betal_deep, Model%betas_deep, & + Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, Statein%vvl, ncld, ud_mf, dd_mf, & + dt_mf, cnvw, cnvc, & + Model%clam_deep, Model%c0s_deep, & + Model%c1_deep, Model%betal_deep, Model%betas_deep, & Model%evfact_deep, Model%evfactl_deep, & Model%pgcon_deep) elseif (Model%imfdeepcnv == 2) then - call samfdeepcnv (im, ix, levs, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw(:,:,1:2), & - Stateout%gq0(:,:,1), & - Stateout%gt0, Stateout%gu0, Stateout%gv0, & - cld1d, rain1, kbot, ktop, kcnv, islmsk, & - garea, Statein%vvl, Model%ncld, ud_mf, dd_mf, & - dt_mf, cnvw, cnvc, & - Model%clam_deep, Model%c0s_deep, & - Model%c1_deep, Model%betal_deep, Model%betas_deep, & - Model%evfact_deep, Model%evfactl_deep, & - Model%pgcon_deep, Model%asolfac_deep) + call samfdeepcnv(im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0(:,:,1), & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + cld1d, rain1, kbot, ktop, kcnv, islmsk, & + garea, Statein%vvl, ncld, ud_mf, dd_mf, & + dt_mf, cnvw, cnvc, & + Model%clam_deep, Model%c0s_deep, & + Model%c1_deep, Model%betal_deep, Model%betas_deep,& + Model%evfact_deep, Model%evfactl_deep, & + Model%pgcon_deep, Model%asolfac_deep) ! if (lprnt) print *,' rain1=',rain1(ipr) elseif (Model%imfdeepcnv == 0) then ! random cloud top - call sascnv (im, ix, levs, Model%jcap, dtp, del, & - Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & + call sascnv (im, ix, levs, Model%jcap, dtp, del, & + Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & Stateout%gq0(:,:,1), Stateout%gt0, Stateout%gu0, & - Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & - islmsk, Statein%vvl, Tbd%rann, Model%ncld, & + Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, Statein%vvl, Tbd%rann, ncld, & ud_mf, dd_mf, dt_mf, cnvw, cnvc) ! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1) endif - else ! no deep convection - cld1d = 0. - rain1 = 0. - ud_mf = 0. - dd_mf = 0. - dt_mf = 0. - cnvw = 0. - cnvc = 0. - endif - else ! ras or cscnv - if (Model%cscnv) then ! Chikira-Sugiyama convection scheme (via CSU) - otspt(:,:) = .true. - otspt(1:3,:) = .false. - if (Model%ntke > 0) then - otspt(Model%ntke-trc_shft+4,1) = .false. - endif - if (Model%ncld == 2) then - otspt(Model%ntlnc-trc_shft+4,1) = .false. - otspt(Model%ntinc-trc_shft+4,1) = .false. - endif + else ! ras or cscnv + fscav(:) = 0.0 + if (Model%cscnv) then ! Chikira-Sugiyama convection scheme (via CSU) - fscav(:) = 0.0 - fswtr(:) = 0.0 + fswtr(:) = 0.0 ! write(0,*)' bef cs_cconv phii=',phii(ipr,:) ! &,' sizefsc=',size(fscav) ! write(0,*)' bef cs_cconv otspt=',otspt,' kdt=',kdt,' me=',me - dqdt(:,:,1) = Stateout%gq0(:,:,1) - dqdt(:,:,2) = max(0.0,clw(:,:,2)) - dqdt(:,:,3) = max(0.0,clw(:,:,1)) -! if (lprnt) write(0,*)' gq0bfcs=',gq0(ipr,1:35,1) -! if (lprnt) write(0,*)' gq0bfcs3=',gq0(ipr,1:35,3) -! if (lprnt) write(0,*)' gq0bfcs4=',gq0(ipr,1:35,4) - - do_awdd = ((Model%do_aw) .and. (Model%cs_parm(6) > 0.0)) -! if (lprnt) write(0,*)' do_awdd=',do_awdd -!GFDL again lat replaced with "1" -!GFDL & otspt, lat, kdt , & - call cs_convr (ix, im, levs, tottracer+3, Model%nctp, otspt, 1, & - kdt, Stateout%gt0, Stateout%gq0(:,:,1:1), rain1, & - clw, Statein%phil, Statein%phii, Statein%prsl, & - Statein%prsi, dtp, dtf, ud_mf, dd_mf, dt_mf, & - Stateout%gu0, Stateout%gv0, fscav, fswtr, & - Tbd%phy_fctd, me, wcbmax, Model%cs_parm(3), & - Model%cs_parm(4), sigmai, sigmatot, vverti, & - Model%do_aw, do_awdd, lprnt, ipr, QLCN, QICN, & - w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld) - -! if (lprnt) write(0,*)' gq0afcs=',gq0(ipr,1:35,1) -! if (lprnt) write(0,*)' gq0afcs3=',gq0(ipr,1:35,3) -! if (lprnt) write(0,*)' gq0afcs4=',gq0(ipr,1:35,4) + do k=1,levs + do i=1,im + dqdt(i,k,1) = Stateout%gq0(i,k,1) + dqdt(i,k,2) = max(0.0,clw(i,k,2)) + dqdt(i,k,3) = max(0.0,clw(i,k,1)) + enddo + enddo + +! if (lprnt) write(0,*)'befcsgt0=',Stateout%gt0(ipr,:) + + call cs_convr (ix, im, levs, tottracer+3, Model%nctp, & + otspt(1:tottracer+3,1:2), 1, & + kdt, Stateout%gt0, Stateout%gq0(:,:,1:1), rain1, & + clw, Statein%phil, Statein%phii, Statein%prsl, & + Statein%prsi, dtp, dtf, ud_mf, dd_mf, dt_mf, & + Stateout%gu0, Stateout%gv0, fscav, fswtr, & + Tbd%phy_fctd, me, wcbmax, Model%cs_parm(3), & + Model%cs_parm(4), sigmatot, & +! Model%cs_parm(4), sigmai, sigmatot, vverti, & + Model%do_aw, Model%do_awdd, Model%flx_form, & + lprnt, ipr, kcnv, QLCN, QICN, & + w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, imp_physics) + +! if (lprnt) write(0,*)'aftcsgt0=',Stateout%gt0(ipr,:) + ! write(1000+me,*)' at latitude = ',lat ! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 ! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) ! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' cs_conv') - rain1(:) = rain1(:) * (dtp*0.001) - if (Model%do_aw) then - do k=1,levs - kk = min(k+1,levs) ! assuming no cloud top reaches the model top - do i = 1,im !DD - sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + rain1(:) = rain1(:) * (dtp*0.001) + if (Model%do_aw) then + do k=1,levs + kk = min(k+1,levs) ! assuming no cloud top reaches the model top + do i=1,im !DD + sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + enddo enddo - enddo - endif + endif -! if (lprnt) then -! write(0,*)' gt01=',gt0(ipr,:),' kdt=',kdt -! write(0,*)' gq01=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*)' clw1=',clw(ipr,:,1),' kdt=',kdt -! write(0,*)' clw2=',clw(ipr,:,1),' kdt=',kdt -! write(0,*)' aft cs rain1=',rain1(ipr)*86400 -! write(0,*)' aft cs rain1=',rain1(ipr) -! endif +! if (lprnt) then +! write(0,*)' gt01=',stateout%gt0(ipr,:),' kdt=',kdt +! write(0,*)' gq01=',stateout%gq0(ipr,:,1),' kdt=',kdt +! write(0,*)' clw1=',clw(ipr,:,1),' kdt=',kdt +! write(0,*)' clw2=',clw(ipr,:,1),' kdt=',kdt +! write(0,*)' aft cs rain1=',rain1(ipr)*86400 +! write(0,*)' aft cs rain1=',rain1(ipr) +! endif - else ! ras version 2 + else ! ras version 2 - if ((Model%ccwf(1) >= 0.0) .or. (Model%ccwf(2) >= 0)) then - ccwfac(:) = Model%ccwf(1)*work1(:) + Model%ccwf(2)*work2(:) - dlqfac(:) = Model%dlqf(1)*work1(:) + Model%dlqf(2)*work2(:) - lmh (:) = levs - else - ccwfac(:) = -999.0 - dlqfac(:) = 0.0 - lmh (:) = levs - endif + if ((Model%ccwf(1) >= 0.0) .or. (Model%ccwf(2) >= 0)) then + do i=1,im + ccwfac(i) = Model%ccwf(1)*work1(i) + Model%ccwf(2)*work2(i) + dlqfac(i) = Model%dlqf(1)*work1(i) + Model%dlqf(2)*work2(i) + lmh (i) = levs + enddo + else + do i=1,im + ccwfac(i) = -999.0 + dlqfac(i) = 0.0 + lmh (i) = levs + enddo + endif ! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me & ! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr) @@ -1963,22 +2329,20 @@ subroutine GFS_physics_driver & ! dqdt(i,k,3) = max(0.0,clw(i,k,1)) ! enddo ! enddo -! if (lat == 64 .and. kdt == 1) write(0,*)' qliq=',clw(1,:,1) -! if (lat == 64 .and. kdt == 1) write(0,*)' qice=',clw(1,:,2) - revap = .true. + revap = .true. ! if (ncld ==2) revap = .false. - call rascnv (im, ix, levs, dtp, dtf, Tbd%rann, Stateout%gt0, & - Stateout%gq0, Stateout%gu0, Stateout%gv0, clw, & - tottracer, fscav, Statein%prsi, Statein%prsl, & - Statein%prsik, Statein%prslk, Statein%phil, & - Statein%phii, kpbl, cd, rain1, kbot, ktop, kcnv, & - Tbd%phy_f2d(1,Model%num_p2d), Model%flipv, pa2mb, & - me, garea, lmh, ccwfac, Model%nrcm, rhc, ud_mf, & - dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt, revap, QLCN, & - QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & - CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld ) - endif + call rascnv (im, ix, levs, dtp, dtf, Tbd%rann, Stateout%gt0, & + Stateout%gq0, Stateout%gu0, Stateout%gv0, clw, & + tottracer, fscav, Statein%prsi, Statein%prsl, & + Statein%prsik, Statein%prslk, Statein%phil, & + Statein%phii, kpbl, cd, rain1, kbot, ktop, kcnv, & + Tbd%phy_f2d(1,Model%num_p2d), Model%flipv, pa2mb, & + me, garea, lmh, ccwfac, Model%nrcm, rhc, ud_mf, & + dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt, revap, QLCN, & + QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, imp_physics) + endif ! write(1000+me,*)' at latitude = ',lat ! tx1 = 1000.0 @@ -1990,88 +2354,135 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10) ! if (lprnt) write(0,*)' gq04=',gq0(ipr,:,1) - cld1d = 0 + cld1d = 0 - if (Model%ldiag3d .or. Model%lgocart) then - Coupling%upd_mfi(:,:) = 0. - Coupling%dwn_mfi(:,:) = 0. - Coupling%det_mfi(:,:) = 0. - endif - if (Model%lgocart) then - Coupling%dqdti(:,:) = 0. - Coupling%cnvqci(:,:) = 0. - endif + if (Model%ldiag3d .or. Model%lgocart) then + do k=1,levs + do i=1,im + Coupling%upd_mfi(i,k) = 0. + Coupling%dwn_mfi(i,k) = 0. + Coupling%det_mfi(i,k) = 0. + enddo + enddo + endif + if (Model%lgocart) then + do k=1,levs + do i=1,im + Coupling%dqdti(i,k) = 0. + Coupling%cnvqci(i,k) = 0. + enddo + enddo + endif - if (Model%lgocart) then - Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain - Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain - Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain - Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2) - & - Stateout%gq0(:,:,Model%ntcw)) * frain - endif ! if (lgocart) + if (Model%lgocart) then + do k=1,levs + do i=1,im + Coupling%upd_mfi(i,k) = Coupling%upd_mfi(i,k) + ud_mf(i,k) * frain + Coupling%dwn_mfi(i,k) = Coupling%dwn_mfi(i,k) + dd_mf(i,k) * frain + Coupling%det_mfi(i,k) = Coupling%det_mfi(i,k) + dt_mf(i,k) * frain + Coupling%cnvqci (i,k) = Coupling%cnvqci (i,k) + (clw(i,k,1)+clw(i,k,2) - & + Stateout%gq0(i,k,ntcw)) * frain + enddo + enddo + endif ! if (lgocart) ! --- ... update the tracers due to convective transport - - if (tottracer > 0) then - if (Model%ntoz > 0) then ! for ozone - Stateout%gq0(:,:,Model%ntoz) = clw(:,:,3) - - if (tracers > 0) then ! for other tracers - do n=1,tracers - Stateout%gq0(:,:,n+trc_shft) = clw(:,:,3+n) - enddo - endif - else - do n=1,tracers - Stateout%gq0(:,:,n+trc_shft) = clw(:,:,2+n) +! (except for suspended water and ice) + + if (tottracer > 0) then + tracers = 2 + do n=2,ntrac +! if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt) then + if ( n /= ntcw .and. n /= ntiw .and. n /= ntclamt .and. & + n /= ntrw .and. n /= ntsw .and. n /= ntrnc .and. & + n /= ntsnc .and. n /= ntgl) then + tracers = tracers + 1 + do k=1,levs + do i=1,im + Stateout%gq0(i,k,n) = clw(i,k,tracers) + enddo + enddo + endif enddo endif - endif - endif ! end if_not_ras + + endif ! end if_not_ras + else ! no parameterized deep convection + cld1d = 0. + rain1 = 0. + ud_mf = 0. + dd_mf = 0. + dt_mf = 0. + cnvw = 0. + cnvc = 0. + endif ! if (lprnt) then -! write(0,*)' aftcnvgt0=',gt0(ipr,:),' kdt=',kdt,' lat=',lat -! write(0,*)' aftcnvgq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat -! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat -! write(0,*)' aftcnvgq1=',(gq0(ipr,k,ntcw),k=1,levs) +! write(0,*)' aftcnvgt0=',stateout%gt0(ipr,:),' kdt=',kdt +! write(0,*)' aftcnvgq0=',(stateout%gq0(ipr,k,1),k=1,levs) +! write(0,*)' gq0i2=',(stateout%gq0(ipr,k,ntiw),k=1,levs) +! write(0,*)' aftcnvgq1=',(stateout%gq0(ipr,k,ntcw),k=1,levs) ! endif ! - Diag%rainc(:) = frain * rain1(:) + do i=1,im + Diag%rainc(i) = frain * rain1(i) + enddo ! if (Model%lssav) then - Diag%cldwrk (:) = Diag%cldwrk (:) + cld1d(:) * dtf - Diag%cnvprcp(:) = Diag%cnvprcp(:) + Diag%rainc(:) + do i=1,im + Diag%cldwrk (i) = Diag%cldwrk (i) + cld1d(i) * dtf + Diag%cnvprcp(i) = Diag%cnvprcp(i) + Diag%rainc(i) + enddo if (Model%ldiag3d) then - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain - Diag%du3dt(:,:,3) = Diag%du3dt(:,:,3) + (Stateout%gu0(:,:)-dudt(:,:)) * frain - Diag%dv3dt(:,:,3) = Diag%dv3dt(:,:,3) + (Stateout%gv0(:,:)-dvdt(:,:)) * frain - - Diag%upd_mf(:,:) = Diag%upd_mf(:,:) + ud_mf(:,:) * (con_g*frain) - Diag%dwn_mf(:,:) = Diag%dwn_mf(:,:) + dd_mf(:,:) * (con_g*frain) - Diag%det_mf(:,:) = Diag%det_mf(:,:) + dt_mf(:,:) * (con_g*frain) + do k=1,levs + do i=1,im + Diag%dt3dt(i,k,4) = Diag%dt3dt(i,k,4) + (Stateout%gt0(i,k)-dtdt(i,k)) * frain + Diag%dq3dt(i,k,2) = Diag%dq3dt(i,k,2) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + Diag%du3dt(i,k,3) = Diag%du3dt(i,k,3) + (Stateout%gu0(i,k)-dudt(i,k)) * frain + Diag%dv3dt(i,k,3) = Diag%dv3dt(i,k,3) + (Stateout%gv0(i,k)-dvdt(i,k)) * frain + + Diag%upd_mf(i,k) = Diag%upd_mf(i,k) + ud_mf(i,k) * (con_g*frain) + Diag%dwn_mf(i,k) = Diag%dwn_mf(i,k) + dd_mf(i,k) * (con_g*frain) + Diag%det_mf(i,k) = Diag%det_mf(i,k) + dt_mf(i,k) * (con_g*frain) + enddo + enddo endif ! if (ldiag3d) endif ! end if_lssav ! ! update dqdt_v to include moisture tendency due to deep convection if (Model%lgocart) then - Coupling%dqdti (:,:) = (Stateout%gq0(:,:,1) - dqdt(:,:,1)) * frain - Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain - Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain - Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain - Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2))*frain + do k=1,levs + do i=1,im + Coupling%dqdti (i,k) = (Stateout%gq0(i,k,1) - dqdt(i,k,1)) * frain + Coupling%upd_mfi(i,k) = Coupling%upd_mfi(i,k) + ud_mf(i,k) * frain + Coupling%dwn_mfi(i,k) = Coupling%dwn_mfi(i,k) + dd_mf(i,k) * frain + Coupling%det_mfi(i,k) = Coupling%det_mfi(i,k) + dt_mf(i,k) * frain + Coupling%cnvqci (i,k) = Coupling%cnvqci (i,k) + (clw(i,k,1)+clw(i,k,2))*frain + enddo + enddo endif ! if (lgocart) ! if ((Model%npdf3d == 3) .and. (Model%num_p3d == 4)) then num2 = Model%num_p3d + 2 num3 = num2 + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = cnvc(:,:) + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = cnvw(i,k) + Tbd%phy_f3d(i,k,num3) = cnvc(i,k) + cnvw(i,k) = 0.0 + cnvc(i,k) = 0.0 + enddo + enddo elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = cnvw(i,k) + cnvw(i,k) = 0.0 + enddo + enddo endif ! if (lprnt) write(7000,*)' bef cnvgwd gu0=',gu0(ipr,:) @@ -2085,10 +2496,12 @@ subroutine GFS_physics_driver & ! --- ... calculate maximum convective heating rate ! cuhr = temperature change due to deep convection - cumabs(:) = 0.0 - work3 (:) = 0.0 - do k = 1, levs - do i = 1, im + do i=1,im + cumabs(i) = 0.0 + work3 (i) = 0.0 + enddo + do k=1,levs + do i=1,im if (k >= kbot(i) .and. k <= ktop(i)) then cumabs(i) = cumabs(i) + (Stateout%gt0(i,k)-dtdt(i,k)) * del(i,k) work3(i) = work3(i) + del(i,k) @@ -2196,19 +2609,25 @@ subroutine GFS_physics_driver & ! --- ... write out cloud top stress and wind tendencies if (Model%lssav) then - Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf - Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf + do i=1,im + Diag%dugwd(i) = Diag%dugwd(i) + dusfcg(i)*dtf + Diag%dvgwd(i) = Diag%dvgwd(i) + dvsfcg(i)*dtf + enddo if (Model%ldiag3d) then - Diag%du3dt(:,:,4) = Diag%du3dt(:,:,4) + gwdcu(:,:) * dtf - Diag%dv3dt(:,:,4) = Diag%dv3dt(:,:,4) + gwdcv(:,:) * dtf + do k=1,levs + do i=1,im + Diag%du3dt(i,k,4) = Diag%du3dt(i,k,4) + gwdcu(i,k) * dtf + Diag%dv3dt(i,k,4) = Diag%dv3dt(i,k,4) + gwdcv(i,k) * dtf + enddo + enddo endif endif ! end if_lssav ! --- ... update the wind components with gwdc tendencies - do k = 1, levs - do i = 1, im + do k=1,levs + do i=1,im eng0 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp @@ -2248,10 +2667,18 @@ subroutine GFS_physics_driver & !----------------Convective gravity wave drag parameterization over -------- if (Model%ldiag3d) then - dtdt(:,:) = Stateout%gt0(:,:) + do k=1,levs + do i=1,im + dtdt(i,k) = Stateout%gt0(i,k) + enddo + enddo endif if (Model%ldiag3d .or. Model%lgocart) then - dqdt(:,:,1) = Stateout%gq0(:,:,1) + do k=1,levs + do i=1,im + dqdt(i,k,1) = Stateout%gq0(i,k,1) + enddo + enddo endif ! write(0,*)' before do_shoc shal clstp=',clstp,' kdt=',kdt, @@ -2274,65 +2701,83 @@ subroutine GFS_physics_driver & call shalcnv (im, ix, levs, Model%jcap, dtp, del, Statein%prsl, & Statein%pgr, Statein%phil, clw, Stateout%gq0, & Stateout%gt0, Stateout%gu0, Stateout%gv0, rain1, & - kbot, ktop, kcnv, islmsk, Statein%vvl, Model%ncld,& + kbot, ktop, kcnv, islmsk, Statein%vvl, ncld, & Diag%hpbl, hflx, evap, ud_mf, dt_mf, cnvw, cnvc, & Model%clam_shal, Model%c0s_shal, Model%c1_shal, & Model%pgcon_shal) - raincs(:) = frain * rain1(:) - Diag%rainc(:) = Diag%rainc(:) + raincs(:) + do i=1,im + raincs(i) = frain * rain1(i) + Diag%rainc(i) = Diag%rainc(i) + raincs(i) + enddo if (Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) + do i=1,im + Diag%cnvprcp(i) = Diag%cnvprcp(i) + raincs(i) + enddo endif ! in shalcnv, 'cnvw' and 'cnvc' are not set to zero: if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then - num2 = Model%num_p3d + 2 - num3 = num2 + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = cnvc(:,:) + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) + Tbd%phy_f3d(i,k,num3) = Tbd%phy_f3d(i,k,num3) + cnvc(i,k) + enddo + enddo elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) + enddo + enddo endif elseif (Model%imfshalcnv == 2) then - call samfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & - Statein%pgr, Statein%phil, clw(:,:,1:2), & - Stateout%gq0(:,:,1:1), & - Stateout%gt0, Stateout%gu0, Stateout%gv0, & - rain1, kbot, ktop, kcnv, islmsk, garea, & - Statein%vvl, Model%ncld, DIag%hpbl, ud_mf, & - dt_mf, cnvw, cnvc, & - Model%clam_shal, Model%c0s_shal, Model%c1_shal, & - Model%pgcon_shal, Model%asolfac_shal) - - raincs(:) = frain * rain1(:) - Diag%rainc(:) = Diag%rainc(:) + raincs(:) + call samfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0(:,:,1:1), & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + rain1, kbot, ktop, kcnv, islmsk, garea, & + Statein%vvl, ncld, DIag%hpbl, ud_mf, & + dt_mf, cnvw, cnvc, & + Model%clam_shal, Model%c0s_shal, Model%c1_shal, & + Model%pgcon_shal, Model%asolfac_shal) + + do i=1,im + raincs(i) = frain * rain1(i) + Diag%rainc(i) = Diag%rainc(i) + raincs(i) + enddo if (Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + raincs(:) + do i=1,im + Diag%cnvprcp(i) = Diag%cnvprcp(i) + raincs(i) + enddo endif ! in mfshalcnv, 'cnvw' and 'cnvc' are set to zero before computation starts: if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then - num2 = Model%num_p3d + 2 - num3 = num2 + 1 - Tbd%phy_f3d(:,:,num2) = Tbd%phy_f3d(:,:,num2) + cnvw(:,:) - Tbd%phy_f3d(:,:,num3) = Tbd%phy_f3d(:,:,num3) + cnvc(:,:) + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) + Tbd%phy_f3d(i,k,num3) = Tbd%phy_f3d(i,k,num3) + cnvc(i,k) + enddo + enddo elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then - num2 = Model%num_p3d + 1 - Tbd%phy_f3d(:,:,num2) = Tbd%phy_f3d(:,:,num2) + cnvw(:,:) + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = Tbd%phy_f3d(i,k,num2) + cnvw(i,k) + enddo + enddo endif elseif (Model%imfshalcnv == 0) then ! modified Tiedtke Shallow convecton !----------------------------------- levshc(:) = 0 - do k = 2, levs - do i = 1, im + do k=2,levs + do i=1,im dpshc = 0.3 * Statein%prsi(i,1) if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k enddo enddo levshcm = 1 - do i = 1, im + do i=1,im levshcm = max(levshcm, levshc(i)) enddo @@ -2357,21 +2802,25 @@ subroutine GFS_physics_driver & if (Model%lssav) then ! update dqdt_v to include moisture tendency due to shallow convection if (Model%lgocart) then - do k = 1, levs - do i = 1, im + do k=1,levs + do i=1,im tem = (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain Coupling%dqdti(i,k) = Coupling%dqdti(i,k) + tem enddo enddo endif if (Model%ldiag3d) then - Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,3) = Diag%dq3dt(:,:,3) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + do k=1,levs + do i=1,im + Diag%dt3dt(i,k,5) = Diag%dt3dt(i,k,5) + (Stateout%gt0(i,k) -dtdt(i,k)) * frain + Diag%dq3dt(i,k,3) = Diag%dq3dt(i,k,3) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + enddo + enddo endif endif ! end if_lssav ! - do k = 1, levs - do i = 1, im + do k=1,levs + do i=1,im if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 enddo enddo @@ -2384,10 +2833,14 @@ subroutine GFS_physics_driver & ! endif elseif (Model%shocaftcnv) then ! if do_shoc is true and shocaftcnv is true call shoc - if (Model%ncld == 2) then + if (ncld == 2) then skip_macro = Model%do_shoc - ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) - ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) + do k=1,levs + do i=1,im + ncpl(i,k) = Stateout%gq0(i,k,ntlnc) + ncpi(i,k) = Stateout%gq0(i,k,ntinc) + enddo + enddo ! else ! if (clw(1,1,2) < -999.0) then ! if clw is not partitioned to ice and water @@ -2400,11 +2853,19 @@ subroutine GFS_physics_driver & ! enddo ! enddo ! endif ! Anning ncld ==2 + if (abs(Model%fprcp) == 1) then + do k=1,levs + do i=1,im + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + enddo + enddo + endif endif - qpl(:,:) = 0.0 - qpi(:,:) = 0.0 + ! dtshoc = 60.0 -! nshocm = (dtp/dtshoc) + 0.001 +! dtshoc = min(dtp, 300.0) +! nshocm = max(1, nint(dtp/dtshoc)) ! dtshoc = dtp / nshocm ! do nshoc=1,nshocm ! call shoc(im, 1, levs, levs+1, dtp, me, lat, & @@ -2412,7 +2873,7 @@ subroutine GFS_physics_driver & ! & prsl(1:im,:), phii (1:im,:), phil(1:im,:),& ! & gu0(1:im,:),gv0(1:im,:), vvl(1:im,:), gt0(1:im,:), & ! & gq0(1:im,:,1), & -! & clw(1:im,:,1), clw(1:im,:,2), qpi, qpl, sgs_cld(1:im,:)& +! & clw(1:im,:,1), clw(1:im,:,2), qsnw, qrn, sgs_cld(1:im,:)& ! &, gq0(1:im,:,ntke), & ! & phy_f3d(1:im,:,ntot3d-1), phy_f3d(1:im,:,ntot3d), & ! & lprnt, ipr, & @@ -2421,18 +2882,25 @@ subroutine GFS_physics_driver & !GFDL replace lat with "1: ! call shoc(ix, im, 1, levs, levs+1, dtshoc, me, lat, & - call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & - Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & - Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & - Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl,rhc, & - Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & - Stateout%gq0(1,1,Model%ntke), hflx, evap, prnum, & - Tbd%phy_f3d(1,1,Model%ntot3d-1), Tbd%phy_f3d(1,1,Model%ntot3d),& - lprnt, ipr, ncpl, ncpi, kdt) - - if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then - Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) - Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) + call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & + Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & + Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qsnw, qrn, & + rhc, Model%sup, Model%shoc_pcrit, & + Tbd%phy_f3d(1,1,ntot3d-2), & + Model%sup, Tbd%phy_f3d(1,1,ntot3d-2), & + Stateout%gq0(1,1,ntke), hflx, evap, prnum, & + Tbd%phy_f3d(1,1,ntot3d-1), Tbd%phy_f3d(1,1,ntot3d), & + lprnt, ipr, ncpl, ncpi) +! enddo + + if (ntlnc > 0 .and. ntinc > 0 .and. ncld >= 2) then + do k=1,levs + do i=1,im + Stateout%gq0(i,k,ntlnc) = ncpl(i,k) + Stateout%gq0(i,k,ntinc) = ncpi(i,k) + enddo + enddo endif ! @@ -2454,35 +2922,51 @@ subroutine GFS_physics_driver & ! write(0,*) ' aftshgq0=',gq0(ipr,:,1) ! endif - if (Model%ntcw > 0) then + if (ntcw > 0) then ! for microphysics - if (Model%imp_physics == 99.or.Model%imp_physics == 98 & - .or.Model%imp_physics == 11) then - Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) - else if (Model%imp_physics == 8) then - Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice - Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water - if(Model%ltaerosol) then - Stateout%gq0(:,:,Model%ntlnc) = Stateout%gq0(:,:,Model%ntlnc) + & - max(0.0,(clw(:,:,2) - liq0(:,:)))/liqm - Stateout%gq0(:,:,Model%ntinc) = Stateout%gq0(:,:,Model%ntinc) + & - max(0.0,(clw(:,:,1) - ice00(:,:)))/icem - else - Stateout%gq0(:,:,Model%ntinc) = Stateout%gq0(:,:,Model%ntinc) + & - max(0.0,(clw(:,:,1) - ice00(:,:)))/icem + if (imp_physics == 99 .or. imp_physics == 98 & + .or. imp_physics == 11) then + Stateout%gq0(1:im,:,ntcw) = clw(1:im,:,1) + clw(1:im,:,2) + elseif (ntiw > 0) then + do k=1,levs + do i=1,im + Stateout%gq0(i,k,ntiw) = clw(i,k,1) ! ice + Stateout%gq0(i,k,ntcw) = clw(i,k,2) ! water + enddo + enddo + if (imp_physics == 8) then + if (Model%ltaerosol) then + do k=1,levs + do i=1,im + Stateout%gq0(i,k,ntlnc) = Stateout%gq0(i,k,ntlnc) & + + max(0.0, (clw(i,k,2)-liq0(i,k))) / liqm + Stateout%gq0(i,k,ntinc) = Stateout%gq0(i,k,ntinc) & + + max(0.0, (clw(i,k,1)-ice00(i,k))) / icem + enddo + enddo + else + do k=1,levs + do i=1,im + Stateout%gq0(i,k,ntinc) = Stateout%gq0(i,k,ntinc) & + + max(0.0, (clw(i,k,1)-ice00(i,k))) / icem + enddo + enddo + endif endif - else if(Model%imp_physics == 6.or.Model%imp_physics == 10) then - Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice - Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water - endif - - - else ! if_ntcw - - clw(:,:,1) = clw(:,:,1) + clw(:,:,2) - - + else + do k=1,levs + do i=1,im + Stateout%gq0(i,k,ntcw) = clw(i,k,1) + clw(i,k,2) + enddo + enddo + endif ! end if_ntiw + else + do k=1,levs + do i=1,im + clw(i,k,1) = clw(i,k,1) + clw(i,k,2) + enddo + enddo endif ! end if_ntcw ! Legacy routine which determines convectve clouds - should be removed at some point @@ -2504,16 +2988,20 @@ subroutine GFS_physics_driver & call mstcnv (im, ix, levs, dtp, Stateout%gt0, Stateout%gq0, & Statein%prsl,del, Statein%prslk, rain1, & - Stateout%gq0(1,1,Model%ntcw), rhc, lprnt, ipr) + Stateout%gq0(1,1,ntcw), rhc, lprnt, ipr) ! if (lprnt) then ! print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr) ! print *,' gt0a=',gt0(ipr,:) ! print *,' gq0a=',gq0(ipr,:,1) ! endif - Diag%rainc(:) = Diag%rainc(:) + frain * rain1(:) + do i=1,im + Diag%rainc(i) = Diag%rainc(i) + frain * rain1(i) + enddo if(Model%lssav) then - Diag%cnvprcp(:) = Diag%cnvprcp(:) + rain1(:) * frain + do i=1,im + Diag%cnvprcp(i) = Diag%cnvprcp(i) + rain1(i) * frain + enddo ! update dqdt_v to include moisture tendency due to surface processes ! dqdt_v : instaneous moisture tendency (kg/kg/sec) @@ -2527,79 +3015,88 @@ subroutine GFS_physics_driver & ! enddo ! endif if (Model%ldiag3d) then - Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:) -dtdt(:,:) ) * frain - Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + do k=1,levs + do i=1,im + Diag%dt3dt(i,k,4) = Diag%dt3dt(i,k,4) + (Stateout%gt0(i,k) -dtdt(i,k) ) * frain + Diag%dq3dt(i,k,2) = Diag%dq3dt(i,k,2) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + enddo + enddo endif - endif + endif endif ! moist convective adjustment over ! if (Model%ldiag3d .or. Model%do_aw) then - dtdt(:,:) = Stateout%gt0(:,:) - dqdt(:,:,1) = Stateout%gq0(:,:,1) - do n=Model%ntcw,Model%ntcw+Model%ncld-1 - dqdt(:,:,n) = Stateout%gq0(:,:,n) + do k=1,levs + do i=1,im + dtdt(i,k) = Stateout%gt0(i,k) + dqdt(i,k,1) = Stateout%gq0(i,k,1) + enddo + enddo + do n=ntcw,ntcw+nncl-1 + dqdt(1:im,:,n) = Stateout%gq0(1:im,:,n) enddo endif ! dqdt_v : instaneous moisture tendency (kg/kg/sec) if (Model%lgocart) then - Coupling%dqdti(:,:) = Coupling%dqdti(:,:) / dtf + do k=1,levs + do i=1,im + Coupling%dqdti(i,k) = Coupling%dqdti(i,k) * (1.0 / dtf) + enddo + enddo endif ! ! grid-scale condensation/precipitations and microphysics parameterization ! ------------------------------------------------------------------------ - if (Model%ncld == 0) then ! no cloud microphysics + if (ncld == 0) then ! no cloud microphysics call lrgscl (ix, im, levs, dtp, Stateout%gt0, Stateout%gq0, & Statein%prsl, del, Statein%prslk, rain1, clw) - else ! all microphysics - if (Model%imp_physics == 99) then ! call zhao/carr/sundqvist microphysics + else ! all microphysics + if (imp_physics == 99) then ! call zhao/carr/sundqvist microphysics + ! ------------ -! if (Model%num_p3d == 4) then ! call zhao/carr/sundqvist microphysics -! -! if (Model%npdf3d /= 3) then ! without pdf clouds - -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' beflsgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' beflsgq0=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' beflsgw0=',gq0(ipr,:,3),' kdt=',kdt -! endif +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' beflsgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' beflsgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' beflsgw0=',gq0(ipr,:,3),' kdt=',kdt +! endif ! ------------------ - if (Model%do_shoc) then - call precpd_shoc (im, ix, levs, dtp, del, Statein%prsl, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, & - psautco_l, prautco_l, Model%evpco, Model%wminco, & - Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) - else - call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & - Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & - Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & - Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) - - call precpd (im, ix, levs, dtp, del, Statein%prsl, & - Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & - Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & - prautco_l, Model%evpco, Model%wminco, lprnt, ipr) - endif -! if (lprnt) then -! write(0,*)' prsl=',prsl(ipr,:) -! write(0,*) ' del=',del(ipr,:) -! write(0,*) ' aftlsgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt -! write(0,*) ' aftlsgw0=',gq0(ipr,:,3),' kdt=',kdt -! write(0,*)' aft precpd rain1=',rain1(1:3),' lat=',lat + if (Model%do_shoc) then + call precpd_shoc (im, ix, levs, dtp, del, Statein%prsl, & + Stateout%gq0(1,1,1), Stateout%gq0(1,1,ntcw), & + Stateout%gt0, rain1, Diag%sr, rainp, rhc, & + psautco_l, prautco_l, Model%evpco, Model%wminco, & + Tbd%phy_f3d(1,1,ntot3d-2), lprnt, ipr) + else + call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & + Stateout%gq0(1,1,1), Stateout%gq0(1,1,ntcw), & + Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & + Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & + Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) + + call precpd (im, ix, levs, dtp, del, Statein%prsl, & + Stateout%gq0(1,1,1), Stateout%gq0(1,1,ntcw), & + Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & + prautco_l, Model%evpco, Model%wminco, lprnt, ipr) + endif +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' aftlsgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' aftlsgw0=',gq0(ipr,:,3),' kdt=',kdt +! write(0,*)' aft precpd rain1=',rain1(1:3),' lat=',lat ! endif - else if(Model%imp_physics == 98) then ! with pdf clouds + elseif (imp_physics == 98) then ! with pdf clouds call gscondp (im, ix, levs, dtp, dtf, Statein%prsl, & Statein%pgr, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & + Stateout%gq0(1,1,ntcw), Stateout%gt0, & Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc, & @@ -2608,7 +3105,7 @@ subroutine GFS_physics_driver & call precpdp (im, ix, levs, dtp, del, Statein%prsl, & Statein%pgr, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & + Stateout%gq0(1,1,ntcw), Stateout%gt0, & rain1, Diag%sr, rainp, rhc, & Tbd%phy_f3d(1,1,Model%num_p3d+1), psautco_l, & prautco_l, Model%evpco, Model%wminco, lprnt, ipr) @@ -2617,9 +3114,10 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr),' lat=',lat - else if(Model%imp_physics == 8) then ! Thompson MP - if(Model%ltaerosol) then - print*,'aerosol verision of the Thompson scheme is not included' + elseif (imp_physics == 8) then ! Thompson MP + ! ------------ + if (Model%ltaerosol) then + print*,'aerosol version of the Thompson scheme is not included' ! call mp_gt_driver(ims,ime,kms,kme,its,ite,kts,kte, & ! Stateout%gq0(1:im,1:levs,1), & @@ -2645,7 +3143,7 @@ subroutine GFS_physics_driver & Stateout%gq0(1:im,1:levs,Model%ntcw), Stateout%gq0(1:im,1:levs,Model%ntrw), & Stateout%gq0(1:im,1:levs,Model%ntiw), Stateout%gq0(1:im,1:levs,Model%ntsw), & Stateout%gq0(1:im,1:levs,Model%ntgl), Stateout%gq0(1:im,1:levs,Model%ntinc),& - Stateout%gq0(1:im,1:im,Model%ntrnc), & + Stateout%gq0(1:im,1:levs,Model%ntrnc), & !2014v Stateout%gt0, Statein%prsl, Statein%vvl, del, dtp, kdt, & Stateout%gt0, Statein%prsl, del, dtp, kdt, & rain1, & @@ -2655,7 +3153,8 @@ subroutine GFS_physics_driver & Tbd%phy_f3d(:,:,1),Tbd%phy_f3d(:,:,2),Tbd%phy_f3d(:,:,3),me,Statein%phii) endif - else if(Model%imp_physics == 6) then ! WSM6 + elseif (imp_physics == 6) then ! WSM6 + ! ----- call wsm6(Stateout%gt0, Statein%phii(1:im,1:levs+1), & Stateout%gq0(1:im,1:levs,1), & Stateout%gq0(1:im,1:levs,Model%ntcw), & @@ -2669,200 +3168,247 @@ subroutine GFS_physics_driver & Tbd%phy_f3d(:,:,1),Tbd%phy_f3d(:,:,2),Tbd%phy_f3d(:,:,3), & ims,ime, kms,kme, & its,ite, kts,kte) +! + elseif (imp_physics == 10) then ! MGB double-moment microphysics + ! ------------------------------ - else if(Model%imp_physics == 11) then - land (:,1) = frland(:) - area (:,1) = Grid%area(:) - rain0 (:,1) = 0.0 - snow0 (:,1) = 0.0 - ice0 (:,1) = 0.0 - graupel0 (:,1) = 0.0 - qn1 (:,1,:) = 0.0 - qv_dt (:,1,:) = 0.0 - ql_dt (:,1,:) = 0.0 - qr_dt (:,1,:) = 0.0 - qi_dt (:,1,:) = 0.0 - qs_dt (:,1,:) = 0.0 - qg_dt (:,1,:) = 0.0 - qa_dt (:,1,:) = 0.0 - pt_dt (:,1,:) = 0.0 - udt (:,1,:) = 0.0 - vdt (:,1,:) = 0.0 - do k = 1, levs - qv1 (:,1,k) = Stateout%gq0(:,levs-k+1,1 ) - ql1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntcw) - qr1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntrw) - qi1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntiw) - qs1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntsw) - qg1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntgl) - qa1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntclamt) - pt (:,1,k) = Stateout%gt0(:,levs-k+1) - w (:,1,k) = -Statein%vvl(:,levs-k+1)*con_rd*Stateout%gt0(:,levs-k+1) & - & /Statein%prsl(:,levs-k+1)/con_g - uin (:,1,k) = Stateout%gu0(:,levs-k+1) - vin (:,1,k) = Stateout%gv0(:,levs-k+1) - delp (:,1,k) = del(:,levs-k+1) - dz (:,1,k) = (Statein%phii(:,levs-k+1)-Statein%phii(:,levs-k+2))/con_g - enddo - - seconds = mod(nint(Model%fhour*3600),86400) - - call gfdl_cloud_microphys_driver(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, udt, vdt, dz, delp, & - area, dtp, land, rain0, snow0, & - ice0, graupel0, .false., .true., & - 1, im, 1, 1, 1, levs, 1, levs, & - seconds) - - rain1(:) = (rain0(:,1)+snow0(:,1)+ice0(:,1)+graupel0(:,1)) & - * dtp * con_p001 / con_day - Diag%ice(:) = ice0 (:,1) * dtp * con_p001 / con_day - Diag%snow(:) = snow0 (:,1) * dtp * con_p001 / con_day - Diag%graupel(:) = graupel0(:,1) * dtp * con_p001 / con_day - do i = 1, im - if (rain1(i) .gt. 0.0) then - Diag%sr(i) = (snow0(i,1) + ice0(i,1) + graupel0(i,1)) & - /(rain0(i,1) + snow0(i,1) + ice0(i,1) + graupel0(i,1)) - else - Diag%sr(i) = 0.0 - endif - enddo - do k = 1, levs - Stateout%gq0(:,k,1 ) = qv1(:,1,levs-k+1) + qv_dt(:,1,levs-k+1) * dtp - Stateout%gq0(:,k,Model%ntcw) = ql1(:,1,levs-k+1) + ql_dt(:,1,levs-k+1) * dtp - Stateout%gq0(:,k,Model%ntrw) = qr1(:,1,levs-k+1) + qr_dt(:,1,levs-k+1) * dtp - Stateout%gq0(:,k,Model%ntiw) = qi1(:,1,levs-k+1) + qi_dt(:,1,levs-k+1) * dtp - Stateout%gq0(:,k,Model%ntsw) = qs1(:,1,levs-k+1) + qs_dt(:,1,levs-k+1) * dtp - Stateout%gq0(:,k,Model%ntgl) = qg1(:,1,levs-k+1) + qg_dt(:,1,levs-k+1) * dtp - Stateout%gq0(:,k,Model%ntclamt) = qa1(:,1,levs-k+1) + qa_dt(:,1,levs-k+1) * dtp - Stateout%gt0(:,k) = Stateout%gt0(:,k) + pt_dt(:,1,levs-k+1) * dtp - Stateout%gu0(:,k) = Stateout%gu0(:,k) + udt (:,1,levs-k+1) * dtp - Stateout%gv0(:,k) = Stateout%gv0(:,k) + vdt (:,1,levs-k+1) * dtp - enddo - -! else - else if(Model%imp_physics == 10) then ! MG ! Acheng used clw here for other code to run smoothly and minimum change ! to make the code work. However, the nc and clw should be treated ! in other procceses too. August 28/2015; Hope that can be done next ! year. I believe this will make the physical interaction more reasonable ! Anning 12/5/2015 changed ntcw hold liquid only - if (Model%do_shoc) then - if (Model%fprcp == 0) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc - end if - elseif ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then - if (Model%fprcp == 0) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) - ! clouds from t-dt and cnvc - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) + if (Model%do_shoc) then + if (Model%fprcp == 0) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc + enddo + enddo + else + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + ncpr(i,k) = Stateout%gq0(i,k,ntrnc) + ncps(i,k) = Stateout%gq0(i,k,ntsnc) + Tbd%phy_f3d(i,k,1) = Tbd%phy_f3d(i,k,ntot3d-2) ! clouds from shoc + enddo + enddo + endif + elseif ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then + if (Model%fprcp == 0) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + Tbd%phy_f3d(i,k,1) = max(0.0, min(1.0,Tbd%phy_f3d(i,k,1)+cnvc(i,k))) ! clouds from t-dt and cnvc - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - endif + tem = cnvw(i,k)* max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) + qlcn(i,k) = qlcn(i,k) + cnvw(i,k) - tem + qicn(i,k) = qicn(i,k) + tem + cf_upi(i,k) = cf_upi(i,k) + cnvc(i,k) + enddo + enddo else + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + Tbd%phy_f3d(i,k,1) = max(0.0, min(1.0,Tbd%phy_f3d(i,k,1)+cnvc(i,k))) + ! clouds from t-dt and cnvc + tem = cnvw(i,k)* max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) + qlcn(i,k) = qlcn(i,k) + cnvw(i,k) - tem + qicn(i,k) = qicn(i,k) + tem + cf_upi(i,k) = cf_upi(i,k) + cnvc(i,k) + + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + ncpr(i,k) = Stateout%gq0(i,k,ntrnc) + ncps(i,k) = Stateout%gq0(i,k,ntsnc) + enddo + enddo + endif + else ! clouds from t-dt and cnvc - if (Model%fprcp == 0 ) then - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = 0. - qsnw(:,:) = 0. - ncpr(:,:) = 0. - ncps(:,:) = 0. - Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) - else - clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice - clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water - qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) - qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) - ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) - ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) - Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) - endif + if (Model%fprcp == 0 ) then + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water +! Tbd%phy_f3d(i,k,1) = min(1.0, Tbd%phy_f3d(i,k,1)) + enddo + enddo + else + do k=1,levs + do i=1,im + clw(i,k,1) = Stateout%gq0(i,k,ntiw) ! ice + clw(i,k,2) = Stateout%gq0(i,k,ntcw) ! water + qrn(i,k) = Stateout%gq0(i,k,ntrw) + qsnw(i,k) = Stateout%gq0(i,k,ntsw) + ncpr(i,k) = Stateout%gq0(i,k,ntrnc) + ncps(i,k) = Stateout%gq0(i,k,ntsnc) +! Tbd%phy_f3d(i,k,1) = min(1.0, Tbd%phy_f3d(i,k,1)) + enddo + enddo endif + endif ! notice clw ix instead of im ! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi, ! & prslk,prsik,pgr,vvl,clw(1,1,2), QLCN, clw(1,1,1),QICN, -! if (lprnt) write(0,*)' cnv_mfdbef=',cnv_mfd(ipr,:),' flipv=',flipv -! if(lprnt) write(0,*) ' befgq0=',gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw2bef=',clw(ipr,:,2),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsb=',phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' cnv_mfdbef=',cnv_mfd(ipr,:),' flipv=',flipv +! if(lprnt) write(0,*) ' befgt0=',Stateout%gt0(ipr,:),' kdt=',kdt +! if(lprnt) write(0,*) ' befgq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw2bef=',clw(ipr,:,2),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsb=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clcn=',clcn(ipr,:)*100,' kdt=',kdt ! txa(:,:) = gq0(:,:,1) - call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & - Statein%prsi, Statein%prslk, Statein%prsik, & +! do k=1,levs +! write(1000+me,*)' maxwatncb=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt',kdt +! enddo + call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & + Statein%prsi, Statein%phil, Statein%phii, & Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & - Stateout%gq0(1,1,Model%ntcw), & - Stateout%gq0(1,1,Model%ntiw), Stateout%gt0, rain1, & - Diag%sr, Stateout%gq0(1,1,Model%ntlnc), & - Stateout%gq0(1,1,Model%ntinc), Model%fprcp, qrn, & + Stateout%gq0(1,1,ntcw), & + Stateout%gq0(1,1,ntiw), Stateout%gt0, rain1, & + Diag%sr, Stateout%gq0(1,1,ntlnc), & + Stateout%gq0(1,1,ntinc), Model%fprcp, qrn, & qsnw, ncpr, ncps, Tbd%phy_f3d(1,1,1), kbot, & + Tbd%phy_f3d(1,1,2),Tbd%phy_f3d(1,1,3), & + Tbd%phy_f3d(1,1,4),Tbd%phy_f3d(1,1,5), & Model%aero_in, skip_macro, cn_prc, cn_snr, lprnt, & - ipr, kdt, Grid%xlat, Grid%xlon) - +! ipr, kdt, Grid%xlat, Grid%xlon) + ipr, kdt, Grid%xlat, Grid%xlon, rhc) +! do k=1,levs +! write(1000+me,*)' maxwatnca=',maxval(Stateout%gq0(1:im,k,ntlnc)),' k=',k,' kdt=',kdt +! enddo ! write(1000+me,*)' at latitude = ',lat ! tx1 = 1000.0 ! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 ! &, txa, clw(1,1,2), clw(1,1,1) ! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') -! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, -! &' rainc=',rainc(ipr)*86400.0 +! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, & +! &' rainc=',diag%rainc(ipr)*86400.0 & ! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) -! if (lprnt) write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt -! if (lprnt) write(0,*)' clw1aft=',gq0(ipr,:,ntiw),' kdt=',kdt -! if (lprnt) write(0,*)' cloudsm=',phy_f3d(ipr,:,1)*100,' kdt=',kdt -! if (lprnt) write(0,*)' clw2aft=',gq0(ipr,:,ntcw),' kdt=',kdt - - if (Model%fprcp == 1) then - Stateout%gq0(:,:,Model%ntrw) = qrn(:,:) - Stateout%gq0(:,:,Model%ntsw) = qsnw(:,:) - Stateout%gq0(:,:,Model%ntrnc) = ncpr(:,:) - Stateout%gq0(:,:,Model%ntsnc) = ncps(:,:) - endif +! if(lprnt) write(0,*) ' aftgt0=',Stateout%gt0(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*) ' aftlsgq0=',stateout%gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1aft=',stateout%gq0(ipr,:,ntiw),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsm=',tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clw2aft=',stateout%gq0(ipr,:,ntcw),' kdt=',kdt + + if (abs(Model%fprcp) == 1) then + do k=1,levs + do i=1,im + Stateout%gq0(i,k,ntrw) = qrn(i,k) + Stateout%gq0(i,k,ntsw) = qsnw(i,k) + Stateout%gq0(i,k,ntrnc) = ncpr(i,k) + Stateout%gq0(i,k,ntsnc) = ncps(i,k) + enddo + enddo + endif +! + + elseif (imp_physics == 11) then ! GFDL MP + ! ------- + do i = 1, im + land (i,1) = frland(i) + area (i,1) = Grid%area(i) + rain0 (i,1) = 0.0 + snow0 (i,1) = 0.0 + ice0 (i,1) = 0.0 + graupel0 (i,1) = 0.0 + enddo + do k = 1, levs + kk = levs-k+1 + do i = 1, im + qn1 (i,1,k) = 0.0 + qv_dt(i,1,k) = 0.0 + ql_dt(i,1,k) = 0.0 + qr_dt(i,1,k) = 0.0 + qi_dt(i,1,k) = 0.0 + qs_dt(i,1,k) = 0.0 + qg_dt(i,1,k) = 0.0 + qa_dt(i,1,k) = 0.0 + pt_dt(i,1,k) = 0.0 + udt (i,1,k) = 0.0 + vdt (i,1,k) = 0.0 +! + qv1 (i,1,k) = Stateout%gq0(i,kk,1) + ql1 (i,1,k) = Stateout%gq0(i,kk,ntcw) + qr1 (i,1,k) = Stateout%gq0(i,kk,ntrw) + qi1 (i,1,k) = Stateout%gq0(i,kk,ntiw) + qs1 (i,1,k) = Stateout%gq0(i,kk,ntsw) + qg1 (i,1,k) = Stateout%gq0(i,kk,ntgl) + qa1 (i,1,k) = Stateout%gq0(i,kk,ntclamt) + pt (i,1,k) = Stateout%gt0(i,kk) + w (i,1,k) = -Statein%vvl(i,kk)*(one+con_fvirt*qv1(i,1,k)) & + * Stateout%gt0(i,kk) / Statein%prsl(i,kk) * (con_rd*onebg) + uin (i,1,k) = Stateout%gu0(i,kk) + vin (i,1,k) = Stateout%gv0(i,kk) + delp (i,1,k) = del(i,kk) + dz (i,1,k) = (Statein%phii(i,kk)-Statein%phii(i,kk+1)) * onebg + enddo + enddo + + + call gfdl_cloud_microphys_driver(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, udt, vdt, dz, delp, & + area, dtp, land, rain0, snow0, & + ice0, graupel0, .false., .true., & + 1, im, 1, 1, 1, levs, 1, levs, & + seconds) + + tem = dtp * con_p001 / con_day + do i = 1, im + rain1(i) = (rain0(i,1)+snow0(i,1)+ice0(i,1)+graupel0(i,1)) * tem + Diag%ice(i) = ice0 (i,1) * tem + Diag%snow(i) = snow0 (i,1) * tem + Diag%graupel(i) = graupel0(i,1) * tem + if (rain1(i) > 0.0) then + Diag%sr(i) = (snow0(i,1) + ice0(i,1) + graupel0(i,1)) & + / (rain0(i,1) + snow0(i,1) + ice0(i,1) + graupel0(i,1)) + else + Diag%sr(i) = 0.0 + endif + enddo + do k = 1, levs + kk = levs-k+1 + do i=1,im + Stateout%gq0(i,k,1 ) = qv1(i,1,kk) + qv_dt(i,1,kk) * dtp + Stateout%gq0(i,k,ntcw) = ql1(i,1,kk) + ql_dt(i,1,kk) * dtp + Stateout%gq0(i,k,ntrw) = qr1(i,1,kk) + qr_dt(i,1,kk) * dtp + Stateout%gq0(i,k,ntiw) = qi1(i,1,kk) + qi_dt(i,1,kk) * dtp + Stateout%gq0(i,k,ntsw) = qs1(i,1,kk) + qs_dt(i,1,kk) * dtp + Stateout%gq0(i,k,ntgl) = qg1(i,1,kk) + qg_dt(i,1,kk) * dtp + Stateout%gq0(i,k,ntclamt) = qa1(i,1,kk) + qa_dt(i,1,kk) * dtp + Stateout%gt0(i,k) = Stateout%gt0(i,k) + pt_dt(i,1,kk) * dtp + Stateout%gu0(i,k) = Stateout%gu0(i,k) + udt (i,1,kk) * dtp + Stateout%gv0(i,k) = Stateout%gv0(i,k) + vdt (i,1,kk) * dtp + enddo + enddo + endif ! end of if(Model%imp_physics) - endif ! end if_ncld + endif ! end if_ncld ! if (lprnt) write(0,*)' rain1 after ls=',rain1(ipr) ! -! if (Model%do_aw) then - if (Model%do_aw.and.Model%imp_physics ==10) then + if (Model%cscnv .and. Model%do_aw) then ! Arakawa-Wu adjustment of large-scale microphysics tendencies: -! reduce by factor of (1-sigma) -! these are microphysics increments. We want to keep (1-sigma) of the increment, -! we will remove sigma*increment from final values +! reduce by factor of (1-sigma) +! these are microphysics increments. We want to keep (1-sigma) of the increment, +! we will remove sigma*increment from final values ! fsigma = 0. ! don't apply any AW correction, in addition comment next line ! fsigma = sigmafrac @@ -2872,26 +3418,47 @@ subroutine GFS_physics_driver & temrain1(:) = 0.0 do k = 1,levs do i = 1,im - tem1 = sigmafrac(i,k) - Stateout%gt0(i,k) = Stateout%gt0(i,k) - tem1 * (Stateout%gt0(i,k)-dtdt(i,k)) - tem2 = tem1 * (Stateout%gq0(i,k,1)-dqdt(i,k,1)) - Stateout%gq0(i,k,1) = Stateout%gq0(i,k,1) - tem2 + tem1 = sigmafrac(i,k) + Stateout%gt0(i,k) = Stateout%gt0(i,k) - tem1 * (Stateout%gt0(i,k)-dtdt(i,k)) + tem2 = tem1 * (Stateout%gq0(i,k,1)-dqdt(i,k,1)) + Stateout%gq0(i,k,1) = Stateout%gq0(i,k,1) - tem2 temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & * tem2 * onebg enddo enddo - do n=Model%ntcw,Model%ntcw+Model%ncld-1 +! add convective clouds + if (Model%do_shoc) then + do k = 1,levs + do i = 1,im + Tbd%phy_f3d(i,k,ntot3d-2) = min(1.0, Tbd%phy_f3d(i,k,ntot3d-2) & + + sigmafrac(i,k)) + enddo + enddo + if (ncld == 5) then + Stateout%gq0(:,:,ntclamt) = Tbd%phy_f3d(:,:,ntot3d-2) + endif + elseif (ncld == 2) then do k = 1,levs do i = 1,im - tem1 = sigmafrac(i,k) * (Stateout%gq0(i,k,n)-dqdt(i,k,n)) - Stateout%gq0(i,k,n) = Stateout%gq0(i,k,n) - tem1 - temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & + Tbd%phy_f3d(i,k,1) = min(1.0, Tbd%phy_f3d(i,k,1) + sigmafrac(i,k)) + enddo + enddo + endif +! if (lprnt) write(0,*)' gt0aftpraw=',Stateout%gt0(ipr,:),' kdt=',kdt,'me=',me + do n=ntcw,ntcw+nncl-1 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) * (Stateout%gq0(i,k,n)-dqdt(i,k,n)) + Stateout%gq0(i,k,n) = Stateout%gq0(i,k,n) - tem1 + temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & * tem1 * onebg enddo enddo enddo ! write(1000+me,*)' rain1=',rain1(4),' temrain1=',temrain1(i)*0.001 - rain1(:) = max(rain1(:) - temrain1(:)*0.001, 0.0_kind_phys) + do i = 1,im + rain1(i) = max(rain1(i) - temrain1(i)*0.001, 0.0_kind_phys) + enddo endif Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) @@ -2928,27 +3495,33 @@ subroutine GFS_physics_driver & endif if (Model%lssav) then - Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) - Diag%totice (:) = Diag%totice (:) + Diag%ice(:) - Diag%totsnw (:) = Diag%totsnw (:) + Diag%snow(:) - Diag%totgrp (:) = Diag%totgrp (:) + Diag%graupel(:) + do i=1,im + Diag%totprcp(i) = Diag%totprcp(i) + Diag%rain(i) + Diag%totice (i) = Diag%totice (i) + Diag%ice(i) + Diag%totsnw (i) = Diag%totsnw (i) + Diag%snow(i) + Diag%totgrp (i) = Diag%totgrp (i) + Diag%graupel(i) ! - if (Model%cal_pre) then - Diag%tdomr(:) = Diag%tdomr(:) + domr(:) * dtf - Diag%tdomzr(:) = Diag%tdomzr(:) + domzr(:) * dtf - Diag%tdomip(:) = Diag%tdomip(:) + domip(:) * dtf - Diag%tdoms(:) = Diag%tdoms(:) + doms(:) * dtf - endif + if (Model%cal_pre) then + Diag%tdomr(i) = Diag%tdomr(i) + domr(i) * dtf + Diag%tdomzr(i) = Diag%tdomzr(i) + domzr(i) * dtf + Diag%tdomip(i) = Diag%tdomip(i) + domip(i) * dtf + Diag%tdoms(i) = Diag%tdoms(i) + doms(i) * dtf + endif + enddo if (Model%ldiag3d) then - Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain - Diag%dq3dt(:,:,4) = Diag%dq3dt(:,:,4) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + do k=1,levs + do i=1,im + Diag%dt3dt(i,k,6) = Diag%dt3dt(i,k,6) + (Stateout%gt0(i,k)-dtdt(i,k)) * frain + Diag%dq3dt(i,k,4) = Diag%dq3dt(i,k,4) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + enddo + enddo endif endif ! --- ... estimate t850 for rain-snow decision - t850(:) = Stateout%gt0(:,1) + t850(1:im) = Stateout%gt0(1:im,1) do k = 1, levs-1 do i = 1, im @@ -2973,12 +3546,12 @@ subroutine GFS_physics_driver & crain = 0.0 csnow = Diag%rainc(i) endif - if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) .gt. (rain0(i,1)+crain)) then + if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) > (rain0(i,1)+crain)) then Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) endif - enddo - else if( .not. Model%cal_pre) then - do i = 1, im + enddo + elseif( .not. Model%cal_pre) then + do i = 1, im Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) if (t850(i) <= 273.16) then @@ -3012,10 +3585,12 @@ subroutine GFS_physics_driver & Sfcprop%ffhh, fm10, fh2) if (Model%lssav) then - Diag%tmpmax (:) = max(Diag%tmpmax (:),Sfcprop%t2m(:)) - Diag%tmpmin (:) = min(Diag%tmpmin (:),Sfcprop%t2m(:)) - Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) - Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) + do i=1,im + Diag%tmpmax (i) = max(Diag%tmpmax (i),Sfcprop%t2m(i)) + Diag%tmpmin (i) = min(Diag%tmpmin (i),Sfcprop%t2m(i)) + Diag%spfhmax(i) = max(Diag%spfhmax(i),Sfcprop%q2m(i)) + Diag%spfhmin(i) = min(Diag%spfhmin(i),Sfcprop%q2m(i)) + enddo !find max wind speed then decompose do i=1, im tem = sqrt(Diag%u10m(i)**2 + Diag%v10m(i)**2 ) @@ -3035,8 +3610,10 @@ subroutine GFS_physics_driver & ! runoff at the surface and is accumulated in unit of meters if (Model%lssav) then tem = dtf * 0.001 - Diag%runoff(:) = Diag%runoff(:) + (drain(:)+runof(:)) * tem - Diag%srunoff(:) = Diag%srunoff(:) + runof(:) * tem + do i=1,im + Diag%runoff(i) = Diag%runoff(i) + (drain(i)+runof(i)) * tem + Diag%srunoff(i) = Diag%srunoff(i) + runof(i) * tem + enddo endif ! --- ... xw: return updated ice thickness & concentration to global array @@ -3053,26 +3630,38 @@ subroutine GFS_physics_driver & enddo ! --- ... return updated smsoil and stsoil to global arrays - Sfcprop%smc(:,:) = smsoil(:,:) - Sfcprop%stc(:,:) = stsoil(:,:) - Sfcprop%slc(:,:) = slsoil(:,:) + do k=1,lsoil + do i=1,im + Sfcprop%smc(i,k) = smsoil(i,k) + Sfcprop%stc(i,k) = stsoil(i,k) + Sfcprop%slc(i,k) = slsoil(i,k) + enddo + enddo ! --- ... calculate column precipitable water "pwat" Diag%pwat(:) = 0.0 - tem = dtf * 0.03456 / 86400.0 do k = 1, levs - work1(:) = 0.0 - if (Model%ncld > 0) then - do ic = Model%ntcw, Model%ntcw+Model%ncld-1 - work1(:) = work1(:) + Stateout%gq0(:,k,ic) + do i=1,im + work1(i) = 0.0 + enddo + if (ncld > 0) then + do ic = ntcw, ntcw+nncl-1 + do i=1,im + work1(i) = work1(i) + Stateout%gq0(i,k,ic) enddo + enddo endif - Diag%pwat(:) = Diag%pwat(:) + del(:,k)*(Stateout%gq0(:,k,1)+work1(:)) + do i=1,im + Diag%pwat(i) = Diag%pwat(i) + del(i,k)*(Stateout%gq0(i,k,1)+work1(i)) + enddo ! if (lprnt .and. i == ipr) write(0,*)' gq0=', ! &gq0(i,k,1),' qgrs=',qgrs(i,k,1),' work2=',work2(i),' k=',k enddo - Diag%pwat(:) = Diag%pwat(:) * onebg + do i=1,im + Diag%pwat(i) = Diag%pwat(i) * onebg + enddo +! tem = dtf * 0.03456 / 86400.0 ! write(1000+me,*)' pwat=',pwat(i),'i=',i,', ! &' rain=',rain(i)*1000.0,' dqsfc1=',dqsfc1(i)*tem,' kdt=',kdt ! &,' e-p=',dqsfc1(i)*tem-rain(i)*1000.0 @@ -3086,31 +3675,38 @@ subroutine GFS_physics_driver & ! if (lprnt) then ! write(7000,*) ' endgu0=',gu0(ipr,:),' kdt=',kdt ! write(7000,*) ' endgv0=',gv0(ipr,:),' kdt=',kdt,' nnp=',nnp -! write(0,*) ' endgt0=',gt0(ipr,:),' kdt=',kdt -! write(0,*) ' endgq0=',gq0(ipr,:,1),' kdt=',kdt,' lat=',lat +! write(0,*) ' endgt0=',Stateout%gt0(ipr,:),' kdt=',kdt +! write(0,*) ' endgq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt ! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat ! endif if (Model%do_sppt) then - !--- radiation heating rate - Tbd%dtdtr(:,:) = Tbd%dtdtr(:,:) + dtdtc(:,:)*dtf +!--- radiation heating rate + Tbd%dtdtr(1:im,:) = Tbd%dtdtr(1:im,:) + dtdtc(1:im,:)*dtf do i = 1, im if (t850(i) > 273.16) then - !--- change in change in rain precip +!--- change in change in rain precip Tbd%drain_cpl(i) = Diag%rain(i) - Tbd%drain_cpl(i) else - !--- change in change in snow precip +!--- change in change in snow precip Tbd%dsnow_cpl(i) = Diag%rain(i) - Tbd%dsnow_cpl(i) endif enddo endif deallocate (clw) - if (Model%do_shoc) then - deallocate (qpl, qpi, ncpl, ncpi) - endif - if (allocated(cnvc)) deallocate(cnvc) - if (allocated(cnvw)) deallocate(cnvw) + if (allocated(cnvc)) deallocate(cnvc) + if (allocated(cnvw)) deallocate(cnvw) + if (allocated(qrn)) deallocate(qrn) + if (allocated(qsnw)) deallocate(qsnw) + if (allocated(ncpl)) deallocate(ncpl) + if (allocated(ncpi)) deallocate(ncpi) + if (allocated(ncpr)) deallocate(ncpr) + if (allocated(ncps)) deallocate(ncps) + + if (allocated(liq0)) deallocate(liq0) + if (allocated(ice00)) deallocate(ice00) + ! deallocate (fscav, fswtr) ! @@ -3123,20 +3719,15 @@ subroutine GFS_physics_driver & ! &' rain=',rain(ipr),' rainc=',rainc(ipr) ! if (lprnt) call mpi_quit(7) ! if (kdt > 2 ) call mpi_quit(70) - deallocate(pbltra) - deallocate(dpbltra) - - if(Model%imp_physics == 5) then - if(Model%ltaerosol) then - deallocate(ice00) - deallocate(liq0) - else - deallocate(ice00) - endif - else if(Model%imp_physics == 7 ) then - deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & - CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) - deallocate (qrn, qsnw, ncpr, ncps) +! if (lprnt) write(0,*)'qt0out=',Stateout%gt0(ipr,:) +! if (lprnt) write(0,*)' clouddriverend=',Tbd%phy_f3d(ipr,:,1)*100,' kdt=',kdt + + deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & + CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) + if (imp_physics == 11) then + deallocate (delp, dz, uin, vin, pt, qv1, ql1, qr1, & + qg1, qa1, qn1, qi1, qs1, pt_dt, qa_dt, udt, vdt, & + w, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt) endif return @@ -3158,19 +3749,25 @@ subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi integer :: i, k ! - sumqv(:) = 0.0 - sumql(:) = 0.0 - sumqi(:) = 0.0 - sumq (:) = 0.0 do i=1,im - sumqv(:) = sumqv(:) + (qv1(:,k) - qv0(:,k)) * delp(:,k) - sumql(:) = sumql(:) + (ql1(:,k) - ql0(:,k)) * delp(:,k) - sumqi(:) = sumqi(:) + (qi1(:,k) - qi0(:,k)) * delp(:,k) + sumqv(i) = 0.0 + sumql(i) = 0.0 + sumqi(i) = 0.0 + sumq (i) = 0.0 + enddo + do k=1,levs + do i=1,im + sumqv(i) = sumqv(i) + (qv1(i,k) - qv0(i,k)) * delp(i,k) + sumql(i) = sumql(i) + (ql1(i,k) - ql0(i,k)) * delp(i,k) + sumqi(i) = sumqi(i) + (qi1(i,k) - qi0(i,k)) * delp(i,k) + enddo + enddo + do i=1,im + sumqv(i) = - sumqv(i) * (1.0/grav) + sumql(i) = - sumql(i) * (1.0/grav) + sumqi(i) = - sumqi(i) * (1.0/grav) + sumq (i) = sumqv(i) + sumql(i) + sumqi(i) enddo - sumqv(:) = - sumqv(:) * (1.0/grav) - sumql(:) = - sumql(:) * (1.0/grav) - sumqi(:) = - sumqi(:) * (1.0/grav) - sumq (:) = sumqv(:) + sumql(:) + sumqi(:) do i=1,im write(1000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 index 5c93edfec..10e0a09ce 100644 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 @@ -664,7 +664,7 @@ end subroutine radinit !> @{ !----------------------------------- subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & - & slag,sdec,cdec,solcon) + & slag,sdec,cdec,solcon) !................................... ! ================= subprogram documentation block ================ ! @@ -1010,7 +1010,7 @@ end subroutine radupdate !> \section gen_grrad General Algorithm !> @{ !----------------------------------- - subroutine GFS_radiation_driver & + subroutine GFS_radiation_driver & (Model, Statein, Stateout, Sfcprop, Coupling, Grid, Tbd, & Cldprop, Radtend, Diag) @@ -1186,12 +1186,13 @@ subroutine GFS_radiation_driver & !--- INTEGER VARIABLES integer :: me, im, lm, nfxr, ntrac integer :: i, j, k, k1, lv, itop, ibtc, nday, LP1, LMK, LMP, kd, & - lla, llb, lya, lyb, kt, kb - integer, dimension(size(Grid%xlon,1)) :: idxday + lla, llb, lya, lyb, kt, kb, n, ntcw, ntiw, ncld, ntrw, & + ntsw, ntgl + integer, dimension(size(Grid%xlon,1)) :: idxday integer, dimension(size(Grid%xlon,1),3) :: mbota, mtopa !--- REAL VARIABLES - real(kind=kind_phys) :: raddt, es, qs, delt, tem0d + real(kind=kind_phys) :: raddt, es, qs, delt, tem0d, tem1, tem2 real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & tsfa, cvt1, cvb1, tem1d, tsfg, tskn @@ -1200,33 +1201,43 @@ subroutine GFS_radiation_driver & real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1) :: aerodp real(kind=kind_phys), dimension(size(Grid%xlon,1),NF_ALBD) :: sfcalb - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: & + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: & htswc, htlwc, gcice, grain, grime, htsw0, htlw0, plyr, tlyr, & - qlyr, olyr, rhly, tvly,qstl, vvel, clw, ciw, prslk1, tem2da, & - tem2db, cldcov, deltaq, cnvc, cnvw + qlyr, olyr, rhly, tvly,qstl, vvel, prslk1, tem2da, & + tem2db, cldcov, deltaq, cnvc, cnvw, effrl, effri, effrr, effrs - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP) :: plvl, tlvl + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp+1) :: plvl, tlvl - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,2:Model%ntrac) :: tracer1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_CLDS) :: clouds - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_VGAS) :: gasvmr + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp,2:Model%ntrac) :: tracer1 + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp,NF_CLDS) :: clouds + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp,NF_VGAS) :: gasvmr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW,NF_AESW)::faersw - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW,NF_AELW)::faerlw + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp,NBDSW,NF_AESW) ::faersw + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp,NBDLW,NF_AELW) ::faerlw + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp,Model%ncnd) :: ccnd !--- TYPED VARIABLES type (cmpfsw_type), dimension(size(Grid%xlon,1)) :: scmpsw + +! logical effr_in +! data effr_in/.false./ ! !===> ... begin here ! - !--- set commonly used integers - me = Model%me - LM = Model%levr - IM = size(Grid%xlon,1) - NFXR = Model%nfxr +!--- set commonly used integers + me = Model%me + LM = Model%levr + IM = size(Grid%xlon,1) + NFXR = Model%nfxr NTRAC = Model%ntrac ! tracers in grrad strip off sphum - start tracer1(2:NTRAC) + ntcw = Model%ntcw + ntiw = Model%ntiw + ncld = Model%ncld + ntrw = Model%ntrw + ntsw = Model%ntsw + ntgl = Model%ntgl - LP1 = LM + 1 ! num of in/out levels + LP1 = LM + 1 ! num of in/out levels ! --- ... set local /level/layer indexes corresponding to in/out variables @@ -1234,31 +1245,31 @@ subroutine GFS_radiation_driver & LMP = LMK + 1 ! num of local levels if ( lextop ) then - if ( ivflip == 1 ) then ! vertical from sfc upward - kd = 0 ! index diff between in/out and local - kt = 1 ! index diff between lyr and upper bound - kb = 0 ! index diff between lyr and lower bound - lla = LMK ! local index at the 2nd level from top - llb = LMP ! local index at toa level - lya = LM ! local index for the 2nd layer from top - lyb = LP1 ! local index for the top layer - else ! vertical from toa downward - kd = 1 ! index diff between in/out and local - kt = 0 ! index diff between lyr and upper bound - kb = 1 ! index diff between lyr and lower bound - lla = 2 ! local index at the 2nd level from top - llb = 1 ! local index at toa level - lya = 2 ! local index for the 2nd layer from top - lyb = 1 ! local index for the top layer + if ( ivflip == 1 ) then ! vertical from sfc upward + kd = 0 ! index diff between in/out and local + kt = 1 ! index diff between lyr and upper bound + kb = 0 ! index diff between lyr and lower bound + lla = LMK ! local index at the 2nd level from top + llb = LMP ! local index at toa level + lya = LM ! local index for the 2nd layer from top + lyb = LP1 ! local index for the top layer + else ! vertical from toa downward + kd = 1 ! index diff between in/out and local + kt = 0 ! index diff between lyr and upper bound + kb = 1 ! index diff between lyr and lower bound + lla = 2 ! local index at the 2nd level from top + llb = 1 ! local index at toa level + lya = 2 ! local index for the 2nd layer from top + lyb = 1 ! local index for the top layer endif ! end if_ivflip_block else kd = 0 if ( ivflip == 1 ) then ! vertical from sfc upward - kt = 1 ! index diff between lyr and upper bound - kb = 0 ! index diff between lyr and lower bound + kt = 1 ! index diff between lyr and upper bound + kb = 0 ! index diff between lyr and lower bound else ! vertical from toa downward - kt = 0 ! index diff between lyr and upper bound - kb = 1 ! index diff between lyr and lower bound + kt = 0 ! index diff between lyr and upper bound + kb = 1 ! index diff between lyr and lower bound endif ! end if_ivflip_block endif ! end if_lextop_block @@ -1304,13 +1315,19 @@ subroutine GFS_radiation_driver & do j = 2, NTRAC do k = 1, LM k1 = k + kd - tracer1(:,k1,j) = max(0.0,Statein%qgrs(:,k,j)) + tracer1(:,k1,j) = max(0.0, Statein%qgrs(:,k,j)) enddo enddo do i = 1, IM plvl(i,LP1+kd) = 0.01 * Statein%prsi(i,LP1) ! pa to mb (hpa) enddo + if (Model%levr < Model%levs) then + do i = 1, IM + plvl(i,LP1+kd) = 0.01 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) + plvl(i,LM+kd) = 0.5 * (plvl(i,LP1+kd) + plvl(i,LM+kd)) + enddo + endif if ( lextop ) then ! values for extra top layer do i = 1, IM @@ -1331,7 +1348,11 @@ subroutine GFS_radiation_driver & !! call getozn()). if (Model%ntoz > 0) then ! interactive ozone generation - olyr(:,:) = max( QMIN, tracer1(:,1:LMK,Model%ntoz) ) + do k=1,lmk + do i=1,im + olyr(i,k) = max( QMIN, tracer1(i,k,Model%ntoz) ) + enddo + enddo else ! climatological ozone call getozn (prslk1, Grid%xlat, IM, LMK, & ! --- inputs olyr) ! --- outputs @@ -1452,7 +1473,7 @@ subroutine GFS_radiation_driver & !check print *,' in grrad : calling setaer ' - call setaer (plvl, plyr, prslk1, tvly, rhly, Sfcprop%slmsk, & ! --- inputs + call setaer (plvl, plyr, prslk1, tvly, rhly, Sfcprop%slmsk, & ! --- inputs tracer1, Grid%xlon, Grid%xlat, IM, LMK, LMP, & Model%lsswr,Model%lslwr, & faersw,faerlw,aerodp) ! --- outputs @@ -1471,172 +1492,249 @@ subroutine GFS_radiation_driver & ! --- ... obtain cloud information for radiation calculations - if (Model%ntcw > 0) then ! prognostic cloud scheme - if (Model%uni_cld .and. Model%ncld >= 2) then - clw(:,:) = tracer1(:,1:LMK,Model%ntcw) ! cloud water amount - ciw(:,:) = 0.0 - do j = 2, Model%ncld - ciw(:,:) = ciw(:,:) + tracer1(:,1:LMK,Model%ntcw+j-1) ! cloud ice amount - enddo + if (ntcw > 0) then ! prognostic cloud schemes - do k = 1, LMK - do i = 1, IM - if ( clw(i,k) < EPSQ ) clw(i,k) = 0.0 - if ( ciw(i,k) < EPSQ ) ciw(i,k) = 0.0 + if (Model%ncnd == 1) then ! Zhao_Carr_Sundqvist + do k=1,LMK + do i=1,IM + ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water/ice enddo enddo - else - clw(:,:) = 0.0 - if(Model%imp_physics == 11) then - if(.not.Model%lgfdlmprad) then + elseif (Model%ncnd == 2) then ! MG + do k=1,LMK + do i=1,IM + ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water + ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water + enddo + enddo + elseif (Model%ncnd == 4) then ! MG2 + do k=1,LMK + do i=1,IM + ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water + ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water + ccnd(i,k,3) = tracer1(i,k,ntrw) ! rain water + ccnd(i,k,4) = tracer1(i,k,ntsw) ! snow water + enddo + enddo + elseif (Model%ncnd == 5) then ! GFDL MP, Thompson, MG3 + do k=1,LMK + do i=1,IM + ccnd(i,k,1) = tracer1(i,k,ntcw) ! liquid water + ccnd(i,k,2) = tracer1(i,k,ntiw) ! ice water + ccnd(i,k,3) = tracer1(i,k,ntrw) ! rain water + ccnd(i,k,4) = tracer1(i,k,ntsw) + tracer1(i,k,ntgl) ! snow + grapuel + enddo + enddo + endif + do n=1,Model%ncnd + do k=1,LMK + do i=1,IM + if (ccnd(i,k,n) < epsq) ccnd(i,k,n) = 0.0 + enddo + enddo + enddo + if (Model%imp_physics == 11 ) then + if (.not. Model%lgfdlmprad) then + ! rsun the summation methods and order make the difference in calculation -! clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw) & -! + tracer1(:,1:LMK,Model%ntiw) & -! + tracer1(:,1:LMK,Model%ntrw) & -! + tracer1(:,1:LMK,Model%ntsw) & -! + tracer1(:,1:LMK,Model%ntgl) - clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw) - clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntrw) - clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntiw) - clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntsw) - clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntgl) - -! do j = 1, 5 -! clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw+j-1) ! cloud condensate amount -! enddo - - endif - else - do j = 1, Model%ncld - clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw+j-1) ! cloud condensate amount +! clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw) & +! + tracer1(:,1:LMK,Model%ntiw) & +! + tracer1(:,1:LMK,Model%ntrw) & +! + tracer1(:,1:LMK,Model%ntsw) & +! + tracer1(:,1:LMK,Model%ntgl) + ccnd(:,:,1) = tracer1(:,1:LMK,ntcw) + ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntrw) + 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,Model%ncld + ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntcw+j-1) ! cloud condensate amount enddo endif - - do k = 1, LMK - do i = 1, IM - if ( clw(i,k) < EPSQ ) clw(i,k) = 0.0 + do k=1,LMK + do i=1,IM + if (ccnd(i,k,1) < EPSQ ) ccnd(i,k,1) = 0.0 enddo enddo + endif +! + if (Model%shoc_cld) then ! all but MG microphys + cldcov(1:IM,1+kd:LM+kd) = Tbd%phy_f3d(1:IM,1:LM,Model%ntot3d-2) + if (ncld == 2 .and. Model%effr_in) then + do k=1,lm + k1 = k + kd + do i=1,im + effrl(i,k1) = Tbd%phy_f3d(i,k,2) + effri(i,k1) = Tbd%phy_f3d(i,k,3) + effrr(i,k1) = Tbd%phy_f3d(i,k,4) + effrs(i,k1) = Tbd%phy_f3d(i,k,5) + enddo + enddo + endif + elseif (Model%imp_physics == 10) then ! MG microphys + cldcov(1:IM,1+kd:LM+kd) = Tbd%phy_f3d(1:IM,1:LM,1) + if (Model%effr_in) then + do k=1,lm + k1 = k + kd + do i=1,im + effrl(i,k1) = Tbd%phy_f3d(i,k,2) + effri(i,k1) = Tbd%phy_f3d(i,k,3) + effrr(i,k1) = Tbd%phy_f3d(i,k,4) + effrs(i,k1) = Tbd%phy_f3d(i,k,5) + enddo + enddo + endif + elseif (Model%imp_physics == 11) then ! GFDL MP + cldcov(1:IM,1+kd:LM+kd) = tracer1(1:IM,1:LM,Model%ntclamt) + else ! neither of the other two cases + cldcov = 0.0 endif + ! ! --- add suspended convective cloud water to grid-scale cloud water ! only for cloud fraction & radiation computation ! it is to enhance cloudiness due to suspended convec cloud water -! for zhao/moorthi's (Model%imp_physics=1) & -! ferrier's (Model%imp_physics=2) microphysics schemes -! -!->>>> RSUN: PROBLEM HERE <<<<< - if (Model%shoc_cld) then ! all but MG microphys - cldcov(:,1:LM) = Tbd%phy_f3d(:,1:LM,Model%ntot3d-2) - elseif (Model%ncld == 2 .and. Model%imp_physics == 10) then ! MG microphys (icmphys = 1) - cldcov(:,1:LM) = Tbd%phy_f3d(:,1:LM,1) - else ! neither of the other two cases - cldcov = 0 - endif +! for zhao/moorthi's (imp_phys=99) & +! ferrier's (imp_phys=5) microphysics schemes - if ((Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then ! same as Model%imp_physics == 99 - deltaq(:,1:LM) = Tbd%phy_f3d(:,1:LM,5) - cnvw (:,1:LM) = Tbd%phy_f3d(:,1:LM,6) - cnvc (:,1:LM) = Tbd%phy_f3d(:,1:LM,7) - elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then ! same as Model%imp_physics == 98 - deltaq(:,1:LM) = 0. - cnvw (:,1:LM) = Tbd%phy_f3d(:,1:LM,Model%num_p3d+1) - cnvc (:,1:LM) = 0. - else ! all the rest - deltaq = 0.0 - cnvw = 0.0 - cnvc = 0.0 + if ((Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then ! same as Model%imp_physics = 99 + do k=1,lm + k1 = k + kd + do i=1,im + deltaq(i,k1) = Tbd%phy_f3d(i,k,5) + cnvw (i,k1) = Tbd%phy_f3d(i,k,6) + cnvc (i,k1) = Tbd%phy_f3d(i,k,7) + enddo + enddo + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then ! same as MOdel%imp_physics=98 + do k=1,lm + k1 = k + kd + do i=1,im + deltaq(i,k1) = 0.0 + cnvw (i,k1) = Tbd%phy_f3d(i,k,Model%num_p3d+1) + cnvc (i,k1) = 0.0 + enddo + enddo + else ! all the rest + do k=1,lmk + do i=1,im + deltaq(i,k) = 0.0 + cnvw (i,k) = 0.0 + cnvc (i,k) = 0.0 + enddo + enddo endif if (lextop) then - cldcov(:,lyb) = cldcov(:,lya) - deltaq(:,lyb) = deltaq(:,lya) - cnvw (:,lyb) = cnvw (:,lya) - cnvc (:,lyb) = cnvc (:,lya) + do i=1,im + cldcov(i,lyb) = cldcov(i,lya) + deltaq(i,lyb) = deltaq(i,lya) + cnvw (i,lyb) = cnvw (i,lya) + cnvc (i,lyb) = cnvc (i,lya) + enddo + if (Model%effr_in) then + do i=1,im + effrl(i,lyb) = effrl(i,lya) + effri(i,lyb) = effri(i,lya) + effrr(i,lyb) = effrr(i,lya) + effrs(i,lyb) = effrs(i,lya) + enddo + endif endif if (Model%imp_physics == 99) then - clw(:,1:LMK) = clw(:,1:LMK) + cnvw(:,1:LMK) + ccnd(1:IM,1:LMK,1) = ccnd(1:IM,1:LMK,1) + cnvw(1:IM,1:LMK) endif if (Model%imp_physics == 99 .or. Model%imp_physics == 10) then ! zhao/moorthi's prognostic cloud scheme ! or unified cloud and/or with MG microphysics - if (Model%uni_cld .and. Model%ncld >= 2) then - call progclduni (plyr, plvl, tlyr, tvly, clw, ciw, & ! --- inputs - Grid%xlat, Grid%xlon, Sfcprop%slmsk, & - IM, LMK, LMP, cldcov(:,1:LMK), & - clouds, cldsa, mtopa, mbota) ! --- outputs + if (Model%uni_cld .and. ncld >= 2) then + call progclduni (plyr, plvl, tlyr, tvly, ccnd, Model%ncnd, & ! --- inputs + Grid%xlat, Grid%xlon, Sfcprop%slmsk, & + IM, LMK, LMP, cldcov, & + effrl, effri, effrr, effrs, Model%effr_in, & + clouds, cldsa, mtopa, mbota) ! --- outputs else - call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, & ! --- inputs - rhly, clw, Grid%xlat,Grid%xlon, & - Sfcprop%slmsk, IM, LMK, LMP, & - Model%uni_cld, Model%lmfshal, & - Model%lmfdeep2, cldcov(:,1:LMK), & - clouds, cldsa, mtopa, mbota) ! --- outputs + call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs + ccnd(1:IM,1:LMK,1), Grid%xlat,Grid%xlon, & + Sfcprop%slmsk, IM, LMK, LMP, & + Model%uni_cld, Model%lmfshal, & + Model%lmfdeep2, cldcov, & + effrl, effri, effrr, effrs, Model%effr_in, & + clouds, cldsa, mtopa, mbota) ! --- outputs endif elseif(Model%imp_physics == 98) then ! zhao/moorthi's prognostic cloud+pdfcld - call progcld3 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly,& ! --- inputs - clw, cnvw, cnvc, Grid%xlat, Grid%xlon, & - Sfcprop%slmsk,im, lmk, lmp, deltaq, & - Model%sup, Model%kdt, me, & - clouds, cldsa, mtopa, mbota) ! --- outputs + call progcld3 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs + ccnd(1:IM,1:LMK,1), & + cnvw, cnvc, Grid%xlat, Grid%xlon, & + Sfcprop%slmsk,im, lmk, lmp, deltaq, & + Model%sup, Model%kdt, me, & + clouds, cldsa, mtopa, mbota) ! --- outputs elseif (Model%imp_physics == 11) then ! GFDL cloud scheme - if(.not.Model%lgfdlmprad) then - call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly,& ! --- inputs - clw, Grid%xlat, Grid%xlon, Sfcprop%slmsk,& - tracer1(:,1:lmk,Model%ntclamt), im, lmk, & - lmp, & - clouds, cldsa, mtopa, mbota) ! --- outputs - else - call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - tracer1, Grid%xlat, Grid%xlon, Sfcprop%slmsk, & - ntrac-1, Model%ntcw-1,Model%ntiw-1,Model%ntrw-1, & - Model%ntsw-1,Model%ntgl-1,Model%ntclamt-1, & - im, lmk, lmp, & - clouds, cldsa, mtopa, mbota) ! --- outputs - endif + if (.not.Model%lgfdlmprad) then + call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs + ccnd(1:IM,1:LMK,1), & + Grid%xlat, Grid%xlon, Sfcprop%slmsk, & + cldcov, im, lmk, lmp, & + clouds, cldsa, mtopa, mbota) ! --- outputs + else + + call progclduni (plyr, plvl, tlyr, tvly, ccnd, Model%ncnd, & ! --- inputs + Grid%xlat, Grid%xlon, Sfcprop%slmsk, & + IM, LMK, LMP, cldcov, & + effrl, effri, effrr, effrs, Model%effr_in, & + clouds, cldsa, mtopa, mbota) ! --- outputs +! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs +! tracer1, Grid%xlat, Grid%xlon, Sfcprop%slmsk, & +! ntrac-1, Model%ntcw-1,Model%ntiw-1,Model%ntrw-1,& +! Model%ntsw-1,Model%ntgl-1,Model%ntclamt-1, & +! im, lmk, lmp, & +! clouds, cldsa, mtopa, mbota) ! --- outputs + endif elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6) then ! Thompson / WSM6 cloud micrphysics scheme - if(Model%kdt == 1) then + if (Model%kdt == 1) then Tbd%phy_f3d(:,:,1) = 10. Tbd%phy_f3d(:,:,2) = 50. Tbd%phy_f3d(:,:,3) = 250. endif - call progcld5 ( plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs Grid%xlat,Grid%xlon,Sfcprop%slmsk, & - ntrac-1, Model%ntcw-1,Model%ntiw-1,Model%ntrw-1, & - Model%ntsw-1,Model%ntgl-1, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & im, lmk, lmp, Model%uni_cld, & Model%lmfshal,Model%lmfdeep2, & cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & - clouds,cldsa,mtopa,mbota & ! --- outputs - ) - + clouds,cldsa,mtopa,mbota) ! --- outputs endif ! end if_imp_physics else ! diagnostic cloud scheme - cvt1(:) = 0.01 * Cldprop%cvt(:) - cvb1(:) = 0.01 * Cldprop%cvb(:) + do i=1,im + cvt1(i) = 0.01 * Cldprop%cvt(i) + cvb1(i) = 0.01 * Cldprop%cvb(i) + enddo do k = 1, LM k1 = k + kd - vvel(:,k1) = 0.01 * Statein%vvl(:,k) + vvel(1:im,k1) = 0.01 * Statein%vvl(1:im,k) enddo if (lextop) then - vvel(:,lyb) = vvel(:,lya) + vvel(1:im,lyb) = vvel(1:im,lya) endif ! --- compute diagnostic cloud related quantities @@ -1693,7 +1791,7 @@ subroutine GFS_radiation_driver & k1 = k + kd Radtend%htrsw(:,k) = htswc(:,k1) enddo - ! --- repopulate the points above levr +! --- repopulate the points above levr if (Model%levr < Model%levs) then do k = LM,Model%levs Radtend%htrsw (:,k) = Radtend%htrsw (:,LM) @@ -1703,12 +1801,12 @@ subroutine GFS_radiation_driver & if (Model%swhtr) then do k = 1, lm k1 = k + kd - Radtend%swhc(:,k) = htsw0(:,k1) + Radtend%swhc(1:im,k) = htsw0(1:im,k1) enddo - ! --- repopulate the points above levr +! --- repopulate the points above levr if (Model%levr < Model%levs) then do k = LM,Model%levs - Radtend%swhc(:,k) = Radtend%swhc(:,LM) + Radtend%swhc(1:im,k) = Radtend%swhc(1:im,LM) enddo endif endif @@ -1717,15 +1815,17 @@ subroutine GFS_radiation_driver & !> - Save two spectral bands' surface downward and upward fluxes for !! output. - Coupling%nirbmdi(:) = scmpsw(:)%nirbm - Coupling%nirdfdi(:) = scmpsw(:)%nirdf - Coupling%visbmdi(:) = scmpsw(:)%visbm - Coupling%visdfdi(:) = scmpsw(:)%visdf + do i=1,im + Coupling%nirbmdi(i) = scmpsw(i)%nirbm + Coupling%nirdfdi(i) = scmpsw(i)%nirdf + Coupling%visbmdi(i) = scmpsw(i)%visbm + Coupling%visdfdi(i) = scmpsw(i)%visdf - Coupling%nirbmui(:) = scmpsw(:)%nirbm * sfcalb(:,1) - Coupling%nirdfui(:) = scmpsw(:)%nirdf * sfcalb(:,2) - Coupling%visbmui(:) = scmpsw(:)%visbm * sfcalb(:,3) - Coupling%visdfui(:) = scmpsw(:)%visdf * sfcalb(:,4) + Coupling%nirbmui(i) = scmpsw(i)%nirbm * sfcalb(i,1) + Coupling%nirdfui(i) = scmpsw(i)%nirdf * sfcalb(i,2) + Coupling%visbmui(i) = scmpsw(i)%visbm * sfcalb(i,3) + Coupling%visdfui(i) = scmpsw(i)%visdf * sfcalb(i,4) + enddo else ! if_nday_block @@ -1735,15 +1835,17 @@ subroutine GFS_radiation_driver & Diag%topfsw = topfsw_type( 0.0, 0.0, 0.0 ) scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) - Coupling%nirbmdi(:) = 0.0 - Coupling%nirdfdi(:) = 0.0 - Coupling%visbmdi(:) = 0.0 - Coupling%visdfdi(:) = 0.0 + do i=1,im + Coupling%nirbmdi(i) = 0.0 + Coupling%nirdfdi(i) = 0.0 + Coupling%visbmdi(i) = 0.0 + Coupling%visdfdi(i) = 0.0 - Coupling%nirbmui(:) = 0.0 - Coupling%nirdfui(:) = 0.0 - Coupling%visbmui(:) = 0.0 - Coupling%visdfui(:) = 0.0 + Coupling%nirbmui(i) = 0.0 + Coupling%nirdfui(i) = 0.0 + Coupling%visbmui(i) = 0.0 + Coupling%visdfui(i) = 0.0 + enddo if (Model%swhtr) then Radtend%swhc(:,:) = 0 @@ -1752,8 +1854,10 @@ subroutine GFS_radiation_driver & endif ! end_if_nday ! --- radiation fluxes for other physics processes - Coupling%sfcnsw(:) = Radtend%sfcfsw(:)%dnfxc - Radtend%sfcfsw(:)%upfxc - Coupling%sfcdsw(:) = Radtend%sfcfsw(:)%dnfxc + do i=1,im + Coupling%sfcnsw(i) = Radtend%sfcfsw(i)%dnfxc - Radtend%sfcfsw(i)%upfxc + Coupling%sfcdsw(i) = Radtend%sfcfsw(i)%dnfxc + enddo endif ! end_if_lsswr @@ -1791,24 +1895,24 @@ subroutine GFS_radiation_driver & do k = 1, LM k1 = k + kd - Radtend%htrlw(:,k) = htlwc(:,k1) + Radtend%htrlw(1:im,k) = htlwc(1:im,k1) enddo - ! --- repopulate the points above levr +! --- repopulate the points above levr if (Model%levr < Model%levs) then do k = LM,Model%levs - Radtend%htrlw (:,k) = Radtend%htrlw (:,LM) + Radtend%htrlw (1:im,k) = Radtend%htrlw (1:im,LM) enddo endif if (Model%lwhtr) then do k = 1, lm k1 = k + kd - Radtend%lwhc(:,k) = htlw0(:,k1) + Radtend%lwhc(1:im,k) = htlw0(1:im,k1) enddo - ! --- repopulate the points above levr +! --- repopulate the points above levr if (Model%levr < Model%levs) then do k = LM,Model%levs - Radtend%lwhc(:,k) = Radtend%lwhc(:,LM) + Radtend%lwhc(1:im,k) = Radtend%lwhc(1:im,LM) enddo endif endif @@ -1828,24 +1932,28 @@ subroutine GFS_radiation_driver & if (Model%lssav) then if (Model%lsswr) then - Diag%fluxr(:,34) = Diag%fluxr(:,34) + Model%fhswr*aerodp(:,1) ! total aod at 550nm - Diag%fluxr(:,35) = Diag%fluxr(:,35) + Model%fhswr*aerodp(:,2) ! DU aod at 550nm - Diag%fluxr(:,36) = Diag%fluxr(:,36) + Model%fhswr*aerodp(:,3) ! BC aod at 550nm - Diag%fluxr(:,37) = Diag%fluxr(:,37) + Model%fhswr*aerodp(:,4) ! OC aod at 550nm - Diag%fluxr(:,38) = Diag%fluxr(:,38) + Model%fhswr*aerodp(:,5) ! SU aod at 550nm - Diag%fluxr(:,39) = Diag%fluxr(:,39) + Model%fhswr*aerodp(:,6) ! SS aod at 550nm + do i=1,im + Diag%fluxr(i,34) = Diag%fluxr(i,34) + Model%fhswr*aerodp(i,1) ! total aod at 550nm + Diag%fluxr(i,35) = Diag%fluxr(i,35) + Model%fhswr*aerodp(i,2) ! DU aod at 550nm + Diag%fluxr(i,36) = Diag%fluxr(i,36) + Model%fhswr*aerodp(i,3) ! BC aod at 550nm + Diag%fluxr(i,37) = Diag%fluxr(i,37) + Model%fhswr*aerodp(i,4) ! OC aod at 550nm + Diag%fluxr(i,38) = Diag%fluxr(i,38) + Model%fhswr*aerodp(i,5) ! SU aod at 550nm + Diag%fluxr(i,39) = Diag%fluxr(i,39) + Model%fhswr*aerodp(i,6) ! SS aod at 550nm + enddo endif ! --- save lw toa and sfc fluxes if (Model%lslwr) then ! --- lw total-sky fluxes - Diag%fluxr(:,1 ) = Diag%fluxr(:,1 ) + Model%fhlwr * Diag%topflw(:)%upfxc ! total sky top lw up - Diag%fluxr(:,19) = Diag%fluxr(:,19) + Model%fhlwr * Radtend%sfcflw(:)%dnfxc ! total sky sfc lw dn - Diag%fluxr(:,20) = Diag%fluxr(:,20) + Model%fhlwr * Radtend%sfcflw(:)%upfxc ! total sky sfc lw up + do i=1,im + Diag%fluxr(i,1 ) = Diag%fluxr(i,1 ) + Model%fhlwr * Diag%topflw(i)%upfxc ! total sky top lw up + Diag%fluxr(i,19) = Diag%fluxr(i,19) + Model%fhlwr * Radtend%sfcflw(i)%dnfxc ! total sky sfc lw dn + Diag%fluxr(i,20) = Diag%fluxr(i,20) + Model%fhlwr * Radtend%sfcflw(i)%upfxc ! total sky sfc lw up ! --- lw clear-sky fluxes - Diag%fluxr(:,28) = Diag%fluxr(:,28) + Model%fhlwr * Diag%topflw(:)%upfx0 ! clear sky top lw up - Diag%fluxr(:,30) = Diag%fluxr(:,30) + Model%fhlwr * Radtend%sfcflw(:)%dnfx0 ! clear sky sfc lw dn - Diag%fluxr(:,33) = Diag%fluxr(:,33) + Model%fhlwr * Radtend%sfcflw(:)%upfx0 ! clear sky sfc lw up + Diag%fluxr(i,28) = Diag%fluxr(i,28) + Model%fhlwr * Diag%topflw(i)%upfx0 ! clear sky top lw up + Diag%fluxr(i,30) = Diag%fluxr(i,30) + Model%fhlwr * Radtend%sfcflw(i)%dnfx0 ! clear sky sfc lw dn + Diag%fluxr(i,33) = Diag%fluxr(i,33) + Model%fhlwr * Radtend%sfcflw(i)%upfx0 ! clear sky sfc lw up + enddo endif ! --- save sw toa and sfc fluxes with proper diurnal sw wgt. coszen=mean cosz over daylight @@ -1874,7 +1982,7 @@ subroutine GFS_radiation_driver & Diag%fluxr(i,27) = Diag%fluxr(i,27) + scmpsw(i)%nirdf * tem0d ! nir diff sw dn ! --- sw clear-sky fluxes ! ------------------- - Diag%fluxr(i,29) = Diag%fluxr(i,29) + Diag%topfsw(i)%upfx0 * tem0d ! clear sky top sw up + Diag%fluxr(i,29) = Diag%fluxr(i,29) + Diag%topfsw(i)%upfx0 * tem0d ! clear sky top sw up Diag%fluxr(i,31) = Diag%fluxr(i,31) + Radtend%sfcfsw(i)%upfx0 * tem0d ! clear sky sfc sw up Diag%fluxr(i,32) = Diag%fluxr(i,32) + Radtend%sfcfsw(i)%dnfx0 * tem0d ! clear sky sfc sw dn endif @@ -1884,8 +1992,10 @@ subroutine GFS_radiation_driver & ! --- save total and boundary layer clouds if (Model%lsswr .or. Model%lslwr) then - Diag%fluxr(:,17) = Diag%fluxr(:,17) + raddt * cldsa(:,4) - Diag%fluxr(:,18) = Diag%fluxr(:,18) + raddt * cldsa(:,5) + do i=1,im + Diag%fluxr(i,17) = Diag%fluxr(i,17) + raddt * cldsa(i,4) + Diag%fluxr(i,18) = Diag%fluxr(i,18) + raddt * cldsa(i,5) + enddo ! --- save cld frac,toplyr,botlyr and top temp, note that the order ! of h,m,l cloud is reversed for the fluxr output. @@ -1900,14 +2010,25 @@ subroutine GFS_radiation_driver & Diag%fluxr(i,11-j) = Diag%fluxr(i,11-j) + tem0d * Statein%prsi(i,itop+kt) Diag%fluxr(i,14-j) = Diag%fluxr(i,14-j) + tem0d * Statein%prsi(i,ibtc+kb) Diag%fluxr(i,17-j) = Diag%fluxr(i,17-j) + tem0d * Statein%tgrs(i,itop) + +! Anning adds optical depth and emissivity output + tem1 = 0. + tem2 = 0. + do k=ibtc+kb,itop+kt + tem1 = tem1 + clouds(i,k,10) + tem2 = tem2 + clouds(i,k,11) + end do + Diag%fluxr(i,43-j) = Diag%fluxr(i,43-j) + tem0d * tem1 + Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) enddo enddo endif - if (.not. Model%uni_cld) then +! if (.not. Model%uni_cld) then + if (Model%lgocart .or. Model%ldiag3d) then do k = 1, LM k1 = k + kd - Coupling%cldcovi(:,k) = clouds(:,k1,1) + Coupling%cldcovi(1:im,k) = clouds(1:im,k1,1) enddo endif endif ! end_if_lssav diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index b9916aa33..143b76e84 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -9,7 +9,7 @@ module GFS_typedefs implicit none !--- version of physics - character(len=64) :: version = 'v2017 OPERATIONAL GFS PHYSICS' + character(len=64) :: phys_version = 'v2018 FV3GFS BETA VERSION PHYSICS' !--- parameter constants used for default initializations real(kind=kind_phys), parameter :: zero = 0.0_kind_phys @@ -57,7 +57,7 @@ module GFS_typedefs integer :: cnx !< number of points in i-dir for this cubed-sphere face !< equal to gnx for lat-lon grids integer :: cny !< number of points in j-dir for this cubed-sphere face - !< equal to gny for lat-lon grids + !< equal to gny*2 for lat-lon grids integer :: gnx !< number of global points in x-dir (i) along the equator integer :: gny !< number of global points in y-dir (j) along any meridian integer :: nlunit !< fortran unit number for file opens @@ -66,13 +66,13 @@ module GFS_typedefs integer :: cdat(8) !< model current date in GFS format (same as jdat) real(kind=kind_phys) :: dt_dycore !< dynamics time step in seconds real(kind=kind_phys) :: dt_phys !< physics time step in seconds - !--- blocking data +!--- blocking data integer, pointer :: blksz(:) !< for explicit data blocking !< default blksz(1)=[nx*ny] - !--- ak/bk for pressure level calculations +!--- ak/bk for pressure level calculations real(kind=kind_phys), pointer :: ak(:) !< from surface (k=1) to TOA (k=levs) real(kind=kind_phys), pointer :: bk(:) !< from surface (k=1) to TOA (k=levs) - !--- grid metrics +!--- grid metrics real(kind=kind_phys), pointer :: xlon(:,:) !< column longitude for MPI rank real(kind=kind_phys), pointer :: xlat(:,:) !< column latitude for MPI rank real(kind=kind_phys), pointer :: area(:,:) !< column area for length scale calculations @@ -91,24 +91,24 @@ module GFS_typedefs !---------------------------------------------------------------- type GFS_statein_type - !--- level geopotential and pressures +!--- level geopotential and pressures real (kind=kind_phys), pointer :: phii (:,:) => null() !< interface geopotential height real (kind=kind_phys), pointer :: prsi (:,:) => null() !< model level pressure in Pa real (kind=kind_phys), pointer :: prsik (:,:) => null() !< Exner function at interface - !--- layer geopotential and pressures +!--- layer geopotential and pressures real (kind=kind_phys), pointer :: phil (:,:) => null() !< layer geopotential height real (kind=kind_phys), pointer :: prsl (:,:) => null() !< model layer mean pressure Pa real (kind=kind_phys), pointer :: prslk (:,:) => null() !< exner function = (p/p0)**rocp - !--- prognostic variables +!--- prognostic variables real (kind=kind_phys), pointer :: pgr (:) => null() !< surface pressure (Pa) real real (kind=kind_phys), pointer :: ugrs (:,:) => null() !< u component of layer wind real (kind=kind_phys), pointer :: vgrs (:,:) => null() !< v component of layer wind real (kind=kind_phys), pointer :: vvl (:,:) => null() !< layer mean vertical velocity in pa/sec real (kind=kind_phys), pointer :: tgrs (:,:) => null() !< model layer mean temperature in k real (kind=kind_phys), pointer :: qgrs (:,:,:) => null() !< layer mean tracer concentration - ! dissipation estimate +! dissipation estimate real (kind=kind_phys), pointer :: diss_est(:,:) => null() !< model layer mean temperature in k contains @@ -139,7 +139,7 @@ module GFS_typedefs !--------------------------------------------------------------------------------------- type GFS_sfcprop_type - !--- In (radiation and physics) +!--- In (radiation and physics) real (kind=kind_phys), pointer :: slmsk (:) => null() !< sea/land mask array (sea:0,land:1,sea-ice:2) real (kind=kind_phys), pointer :: tsfc (:) => null() !< surface temperature in k !< [tsea in gbphys.f] @@ -150,7 +150,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: hprim (:) => null() !< topographic standard deviation in m ! real (kind=kind_phys), pointer :: hprime (:,:) => null() !< orographic metrics - !--- In (radiation only) +!--- In (radiation only) real (kind=kind_phys), pointer :: sncovr (:) => null() !< snow cover in fraction real (kind=kind_phys), pointer :: snoalb (:) => null() !< maximum snow albedo in fraction real (kind=kind_phys), pointer :: alvsf (:) => null() !< mean vis albedo with strong cosz dependency @@ -160,7 +160,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: facsf (:) => null() !< fractional coverage with strong cosz dependency real (kind=kind_phys), pointer :: facwf (:) => null() !< fractional coverage with weak cosz dependency - !--- In (physics only) +!--- In (physics only) real (kind=kind_phys), pointer :: slope (:) => null() !< sfc slope type for lsm real (kind=kind_phys), pointer :: shdmin (:) => null() !< min fractional coverage of green veg real (kind=kind_phys), pointer :: shdmax (:) => null() !< max fractnl cover of green veg (not used) @@ -172,7 +172,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: oro (:) => null() !< orography real (kind=kind_phys), pointer :: oro_uf (:) => null() !< unfiltered orography - !-- In/Out +!-- In/Out real (kind=kind_phys), pointer :: hice (:) => null() !< sea ice thickness real (kind=kind_phys), pointer :: weasd (:) => null() !< water equiv of accumulated snow depth (kg/m**2) !< over land and sea ice @@ -186,11 +186,11 @@ module GFS_typedefs real (kind=kind_phys), pointer :: smc (:,:) => null() !< total soil moisture real (kind=kind_phys), pointer :: stc (:,:) => null() !< soil temperature - !--- Out +!--- Out real (kind=kind_phys), pointer :: t2m (:) => null() !< 2 meter temperature real (kind=kind_phys), pointer :: q2m (:) => null() !< 2 meter humidity - !--- NSSTM variables (only allocated when [Model%nstf_name(1) > 0]) +!--- NSSTM variables (only allocated when [Model%nstf_name(1) > 0]) real (kind=kind_phys), pointer :: tref (:) => null() !< nst_fld%Tref - Reference Temperature real (kind=kind_phys), pointer :: z_c (:) => null() !< nst_fld%z_c - Sub layer cooling thickness real (kind=kind_phys), pointer :: c_0 (:) => null() !< nst_fld%c_0 - coefficient1 to calculate d(Tz)/d(Ts) @@ -221,7 +221,7 @@ module GFS_typedefs !--------------------------------------------------------------------- type GFS_coupling_type - !--- Out (radiation only) +!--- Out (radiation only) real (kind=kind_phys), pointer :: nirbmdi(:) => null() !< sfc nir beam sw downward flux (w/m2) real (kind=kind_phys), pointer :: nirdfdi(:) => null() !< sfc nir diff sw downward flux (w/m2) real (kind=kind_phys), pointer :: visbmdi(:) => null() !< sfc uv+vis beam sw downward flux (w/m2) @@ -239,16 +239,16 @@ module GFS_typedefs real (kind=kind_phys), pointer :: sfcdlw(:) => null() !< total sky sfc downward lw flux ( w/m**2 ) !< GFS_radtend_type%sfclsw%dnfxc - !--- incoming quantities +!--- incoming quantities real (kind=kind_phys), pointer :: dusfcin_cpl(:) => null() !< aoi_fld%dusfcin(item,lan) real (kind=kind_phys), pointer :: dvsfcin_cpl(:) => null() !< aoi_fld%dvsfcin(item,lan) real (kind=kind_phys), pointer :: dtsfcin_cpl(:) => null() !< aoi_fld%dtsfcin(item,lan) real (kind=kind_phys), pointer :: dqsfcin_cpl(:) => null() !< aoi_fld%dqsfcin(item,lan) real (kind=kind_phys), pointer :: ulwsfcin_cpl(:)=> null() !< aoi_fld%ulwsfcin(item,lan) - !--- only variable needed for cplwav=.TRUE. +!--- only variable needed for cplwav=.TRUE. real (kind=kind_phys), pointer :: slimskin_cpl(:)=> null() !< aoi_fld%slimskin(item,lan) - !--- outgoing accumulated quantities +!--- outgoing accumulated quantities real (kind=kind_phys), pointer :: rain_cpl (:) => null() !< total rain precipitation real (kind=kind_phys), pointer :: snow_cpl (:) => null() !< total snow precipitation real (kind=kind_phys), pointer :: dusfc_cpl (:) => null() !< sfc u momentum flux @@ -268,7 +268,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: nvisbm_cpl(:) => null() !< net uv+vis beam downward sw rad flux (w/m**2) real (kind=kind_phys), pointer :: nvisdf_cpl(:) => null() !< net uv+vis diff downward sw rad flux (w/m**2) - !--- outgoing instantaneous quantities +!--- outgoing instantaneous quantities real (kind=kind_phys), pointer :: dusfci_cpl (:) => null() !< instantaneous sfc u momentum flux real (kind=kind_phys), pointer :: dvsfci_cpl (:) => null() !< instantaneous sfc v momentum flux real (kind=kind_phys), pointer :: dtsfci_cpl (:) => null() !< instantaneous sfc sensible heat flux @@ -296,13 +296,13 @@ module GFS_typedefs real (kind=kind_phys), pointer :: oro_cpl (:) => null() !< orography ( oro from GFS_sfcprop_type) real (kind=kind_phys), pointer :: slmsk_cpl (:) => null() !< Land/Sea/Ice mask (slmsk from GFS_sfcprop_type) - !--- stochastic physics +!--- stochastic physics real (kind=kind_phys), pointer :: shum_wts (:,:) => null() ! real (kind=kind_phys), pointer :: sppt_wts (:,:) => null() ! real (kind=kind_phys), pointer :: skebu_wts (:,:) => null() ! real (kind=kind_phys), pointer :: skebv_wts (:,:) => null() ! - !--- instantaneous quantities for GoCart and will be accumulated for 3D diagnostics +!--- instantaneous quantities for GoCart and will be accumulated for 3D diagnostics real (kind=kind_phys), pointer :: dqdti (:,:) => null() !< instantaneous total moisture tendency (kg/kg/s) real (kind=kind_phys), pointer :: cnvqci (:,:) => null() !< instantaneous total convective conensate (kg/kg) real (kind=kind_phys), pointer :: upd_mfi (:,:) => null() !< instantaneous convective updraft mass flux @@ -340,7 +340,7 @@ module GFS_typedefs integer :: sfcpress_id !< valid for GFS only for get_prs/phi logical :: gen_coord_hybrid!< for Henry's gen coord - !--- set some grid extent parameters +!--- set some grid extent parameters integer :: isc !< starting i-index for this MPI-domain integer :: jsc !< starting j-index for this MPI-domain integer :: nx !< number of points in the i-dir for this MPI-domain @@ -351,14 +351,14 @@ module GFS_typedefs integer :: lonr !< number of global points in x-dir (i) along the equator integer :: latr !< number of global points in y-dir (j) along any meridian - !--- coupling parameters +!--- coupling parameters logical :: cplflx !< default no cplflx collection logical :: cplwav !< default no cplwav collection - !--- integrated dynamics through earth's atmosphere +!--- integrated dynamics through earth's atmosphere logical :: lsidea - !--- calendars and time parameters and activation triggers +!--- calendars and time parameters and activation triggers real(kind=kind_phys) :: dtp !< physics timestep in seconds real(kind=kind_phys) :: dtf !< dynamics timestep in seconds integer :: nscyc !< trigger for surface data cycling @@ -367,7 +367,7 @@ module GFS_typedefs !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) integer :: idate(4) !< initial date with different size and ordering !< (hr, mon, day, yr) - !--- radiation control parameters +!--- radiation control parameters real(kind=kind_phys) :: fhswr !< frequency for shortwave radiation (secs) real(kind=kind_phys) :: fhlwr !< frequency for longwave radiation (secs) integer :: nsswr !< integer trigger for shortwave radiation @@ -410,7 +410,7 @@ module GFS_typedefs logical :: lwhtr !< flag to output lw heating rate (Radtend%lwhc) logical :: swhtr !< flag to output sw heating rate (Radtend%swhc) - !--- microphysical switch +!--- microphysical switch integer :: ncld !< cnoice of cloud scheme !--- new microphysical switch integer :: imp_physics !< cnoice of cloud scheme @@ -425,6 +425,13 @@ module GFS_typedefs real(kind=kind_phys) :: mg_dcs !< Morrison-Gettleman microphysics parameters real(kind=kind_phys) :: mg_qcvar real(kind=kind_phys) :: mg_ts_auto_ice !< ice auto conversion time scale + logical :: effr_in !< eg to turn on ffective radii for MG + logical :: microp_uniform + logical :: do_cldice + logical :: hetfrz_classnuc + + real(kind=kind_phys) :: shoc_pcrit !< critical pressure in Pa for tke dissipation in shoc + integer :: ncnd !< number of cloud condensate types !--- Thompson's microphysical paramters logical :: ltaerosol !< flag for aerosol version, currently not working yet @@ -444,7 +451,7 @@ module GFS_typedefs logical :: mom4ice !< flag controls mom4 sea ice logical :: use_ufo !< flag for gcycle surface option - !--- tuning parameters for physical parameterizations +!--- tuning parameters for physical parameterizations logical :: ras !< flag for ras convection scheme logical :: flipv !< flag for vertical direction flip (ras) !< .true. implies surface at k=1 @@ -456,6 +463,8 @@ module GFS_typedefs logical :: cscnv !< flag for Chikira-Sugiyama convection logical :: cal_pre !< flag controls precip type algorithm logical :: do_aw !< AW scale-aware option in cs convection + logical :: do_awdd !< AW scale-aware option in cs convection + logical :: flx_form !< AW scale-aware option in cs convection logical :: do_shoc !< flag for SHOC logical :: shocaftcnv !< flag for SHOC logical :: shoc_cld !< flag for clouds @@ -469,6 +478,7 @@ module GFS_typedefs logical :: cnvcld logical :: random_clds !< flag controls whether clouds are random logical :: shal_cnv !< flag for calling shallow convection + logical :: do_deep !< whether to do deep convection integer :: imfshalcnv !< flag for mass-flux shallow convection scheme !< 1: July 2010 version of mass-flux shallow conv scheme !< current operational version as of 2016 @@ -480,7 +490,6 @@ module GFS_typedefs !< current operational version as of 2016 !< 2: scale- & aerosol-aware mass-flux deep conv scheme (2017) !< 0: old SAS Convection scheme before July 2010 - logical :: do_deep !< whether to do deep convection integer :: nmtvr !< number of topographic variables such as variance etc !< used in the GWD parameterization integer :: jcap !< number of spectral wave trancation used only by sascnv shalcnv @@ -501,11 +510,11 @@ module GFS_typedefs real(kind=kind_phys) :: rbcr !< Critical Richardson Number in the PBL scheme - !--- Rayleigh friction +!--- Rayleigh friction real(kind=kind_phys) :: prslrd0 !< pressure level from which Rayleigh Damping is applied real(kind=kind_phys) :: ral_ts !< time scale for Rayleigh damping in days - !--- mass flux deep convection +!--- mass flux deep convection real(kind=kind_phys) :: clam_deep !< c_e for deep convection (Han and Pan, 2011, eq(6)) real(kind=kind_phys) :: c0s_deep !< convective rain conversion parameter real(kind=kind_phys) :: c1_deep !< conversion parameter of detrainment from liquid water into grid-scale cloud water @@ -523,7 +532,7 @@ module GFS_typedefs !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land - !--- mass flux shallow convection +!--- mass flux shallow convection real(kind=kind_phys) :: clam_shal !< c_e for shallow convection (Han and Pan, 2011, eq(6)) real(kind=kind_phys) :: c0s_shal !< convective rain conversion parameter real(kind=kind_phys) :: c1_shal !< conversion parameter of detrainment from liquid water into grid-scale cloud water @@ -537,7 +546,7 @@ module GFS_typedefs !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land - !--- near surface temperature model +!--- near surface temperature model logical :: nst_anl !< flag for NSSTM analysis in gcycle/sfcsub integer :: lsea real(kind=kind_phys) :: xkzm_m !< [in] bkgd_vdif_m background vertical diffusion for momentum @@ -553,19 +562,19 @@ module GFS_typedefs real(kind=kind_phys) :: xkzminv !< diffusivity in inversion layers real(kind=kind_phys) :: moninq_fac !< turbulence diffusion coefficient factor - !--- stochastic physics control parameters +!--- stochastic physics control parameters logical :: do_sppt logical :: use_zmtnblck logical :: do_shum logical :: do_skeb integer :: skeb_npass - !--- tracer handling +!--- tracer handling character(len=32), pointer :: tracer_names(:) !< array of initialized tracers from dynamic core integer :: ntrac !< number of tracers integer :: ntoz !< tracer index for ozone mixing ratio integer :: ntcw !< tracer index for cloud condensate (or liquid water) - integer :: ntiw !< tracer index for ice water + integer :: ntiw !< tracer index for ice water integer :: ntrw !< tracer index for rain water integer :: ntsw !< tracer index for snow water integer :: ntgl !< tracer index for graupel @@ -591,11 +600,11 @@ module GFS_typedefs integer :: npdf3d !< number of 3d arrays associated with pdf based clouds/microphysics integer :: nctp !< number of cloud types in Chikira-Sugiyama scheme - !--- debug flag +!--- debug flag logical :: debug logical :: pre_rad !< flag for testing purpose - !--- variables modified at each time step +!--- variables modified at each time step integer :: ipt !< index for diagnostic printout point logical :: lprnt !< control flag for diagnostic print out logical :: lsswr !< logical flags for sw radiation calls @@ -613,7 +622,7 @@ module GFS_typedefs integer :: kdt !< current forecast iteration integer :: jdat(1:8) !< current forecast date and time !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) - !--- IAU +!--- IAU real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours character(len=240) :: iau_inc_files(7)! list of increment files real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files @@ -641,12 +650,12 @@ module GFS_typedefs real (kind=kind_phys), pointer :: area (:) => null() !< area of the grid cell real (kind=kind_phys), pointer :: dx (:) => null() !< relative dx for the grid cell - !--- grid-related interpolation data for prognostic ozone +!--- grid-related interpolation data for prognostic ozone real (kind=kind_phys), pointer :: ddy_o3 (:) => null() !< interpolation weight for ozone integer, pointer :: jindx1_o3 (:) => null() !< interpolation low index for ozone integer, pointer :: jindx2_o3 (:) => null() !< interpolation high index for ozone - !--- grid-related interpolation data for stratosphere water +!--- grid-related interpolation data for stratosphere water real (kind=kind_phys), pointer :: ddy_h (:) => null() !< interpolation weight for h2o integer, pointer :: jindx1_h (:) => null() !< interpolation low index for h2o integer, pointer :: jindx2_h (:) => null() !< interpolation high index for h2o @@ -661,32 +670,32 @@ module GFS_typedefs !----------------------------------------------- type GFS_tbd_type - !--- radiation random seeds +!--- radiation random seeds integer, pointer :: icsdsw (:) => null() !< (rad. only) auxiliary cloud control arrays passed to main integer, pointer :: icsdlw (:) => null() !< (rad. only) radiations. if isubcsw/isubclw (input to init) !< (rad. only) are set to 2, the arrays contains provided !< (rad. only) random seeds for sub-column clouds generators - !--- In +!--- In real (kind=kind_phys), pointer :: ozpl (:,:,:) => null() !< ozone forcing data real (kind=kind_phys), pointer :: h2opl (:,:,:) => null() !< water forcing data !--- active when ((.not. newsas .or. cal_pre) .and. random_clds) real (kind=kind_phys), pointer :: rann (:,:) => null() !< random number array (0-1) - !--- In/Out +!--- In/Out real (kind=kind_phys), pointer :: acv (:) => null() !< array containing accumulated convective clouds real (kind=kind_phys), pointer :: acvb (:) => null() !< arrays used by cnvc90 bottom real (kind=kind_phys), pointer :: acvt (:) => null() !< arrays used by cnvc90 top (cnvc90.f) - !--- Stochastic physics properties calculated in physics_driver - real (kind=kind_phys), pointer :: dtdtr (:,:) => null() !< temperature change due to radiative heating per time step (K) - real (kind=kind_phys), pointer :: dtotprcp (:) => null() !< change in totprcp (diag_type) - real (kind=kind_phys), pointer :: dcnvprcp (:) => null() !< change in cnvprcp (diag_type) - real (kind=kind_phys), pointer :: drain_cpl (:) => null() !< change in rain_cpl (coupling_type) - real (kind=kind_phys), pointer :: dsnow_cpl (:) => null() !< change in show_cpl (coupling_type) +!--- Stochastic physics properties calculated in physics_driver + real (kind=kind_phys), pointer :: dtdtr (:,:) => null() !< temperature change due to radiative heating per time step (K) + real (kind=kind_phys), pointer :: dtotprcp (:) => null() !< change in totprcp (diag_type) + real (kind=kind_phys), pointer :: dcnvprcp (:) => null() !< change in cnvprcp (diag_type) + real (kind=kind_phys), pointer :: drain_cpl (:) => null() !< change in rain_cpl (coupling_type) + real (kind=kind_phys), pointer :: dsnow_cpl (:) => null() !< change in show_cpl (coupling_type) - !--- phy_f*d variables needed for seamless restarts and moving data between grrad and gbphys +!--- phy_f*d variables needed for seamless restarts and moving data between grrad and gbphys real (kind=kind_phys), pointer :: phy_fctd (:,:) => null() !< For CS convection real (kind=kind_phys), pointer :: phy_f2d (:,:) => null() !< 2d arrays saved for restart real (kind=kind_phys), pointer :: phy_f3d (:,:,:) => null() !< 3d arrays saved for restart @@ -702,8 +711,8 @@ module GFS_typedefs !------------------------------------------------------------------ type GFS_cldprop_type - !--- In (radiation) - !--- In/Out (physics) +!--- In (radiation) +!--- In/Out (physics) real (kind=kind_phys), pointer :: cv (:) => null() !< fraction of convective cloud ; phys real (kind=kind_phys), pointer :: cvt (:) => null() !< convective cloud top pressure in pa ; phys real (kind=kind_phys), pointer :: cvb (:) => null() !< convective cloud bottom pressure in pa ; phys, cnvc90 @@ -735,7 +744,7 @@ module GFS_typedefs !!\n %dnfxc - total sky downward lw flux at sfc (w/m**2) !!\n %dnfx0 - clear sky downward lw flux at sfc (w/m**2) - !--- Out (radiation only) +!--- Out (radiation only) real (kind=kind_phys), pointer :: htrsw (:,:) => null() !< swh total sky sw heating rate in k/sec real (kind=kind_phys), pointer :: htrlw (:,:) => null() !< hlw total sky lw heating rate in k/sec real (kind=kind_phys), pointer :: sfalb (:) => null() !< mean surface diffused sw albedo @@ -744,10 +753,10 @@ module GFS_typedefs real (kind=kind_phys), pointer :: tsflw (:) => null() !< surface air temp during lw calculation in k real (kind=kind_phys), pointer :: semis (:) => null() !< surface lw emissivity in fraction - !--- In/Out (???) (radiaition only) +!--- In/Out (???) (radiaition only) real (kind=kind_phys), pointer :: coszdg(:) => null() !< daytime mean cosz over rad call period - !--- In/Out (???) (physics only) +!--- In/Out (???) (physics only) real (kind=kind_phys), pointer :: swhc (:,:) => null() !< clear sky sw heating rates ( k/s ) real (kind=kind_phys), pointer :: lwhc (:,:) => null() !< clear sky lw heating rates ( k/s ) real (kind=kind_phys), pointer :: lwhd (:,:,:) => null() !< idea sky lw heating rates ( k/s ) @@ -762,110 +771,110 @@ module GFS_typedefs !---------------------------------------------------------------- type GFS_diag_type - !! Input/Output only in radiation - real (kind=kind_phys), pointer :: fluxr (:,:) => null() !< to save time accumulated 2-d fields defined as:! - !< hardcoded field indices, opt. includes aerosols! - type (topfsw_type), pointer :: topfsw(:) => null() !< sw radiation fluxes at toa, components: +!! Input/Output only in radiation + real (kind=kind_phys), pointer :: fluxr (:,:) => null() !< to save time accumulated 2-d fields defined as:! + !< hardcoded field indices, opt. includes aerosols! + type (topfsw_type), pointer :: topfsw(:) => null() !< sw radiation fluxes at toa, components: ! %upfxc - total sky upward sw flux at toa (w/m**2) ! %dnfxc - total sky downward sw flux at toa (w/m**2) ! %upfx0 - clear sky upward sw flux at toa (w/m**2) - type (topflw_type), pointer :: topflw(:) => null() !< lw radiation fluxes at top, component: - ! %upfxc - total sky upward lw flux at toa (w/m**2) - ! %upfx0 - clear sky upward lw flux at toa (w/m**2) - - ! Input/output - used by physics - real (kind=kind_phys), pointer :: srunoff(:) => null() !< surface water runoff (from lsm) - real (kind=kind_phys), pointer :: evbsa (:) => null() !< noah lsm diagnostics - real (kind=kind_phys), pointer :: evcwa (:) => null() !< noah lsm diagnostics - real (kind=kind_phys), pointer :: snohfa (:) => null() !< noah lsm diagnostics - real (kind=kind_phys), pointer :: transa (:) => null() !< noah lsm diagnostics - real (kind=kind_phys), pointer :: sbsnoa (:) => null() !< noah lsm diagnostics - real (kind=kind_phys), pointer :: snowca (:) => null() !< noah lsm diagnostics - real (kind=kind_phys), pointer :: soilm (:) => null() !< soil moisture - real (kind=kind_phys), pointer :: tmpmin (:) => null() !< min temperature at 2m height (k) - real (kind=kind_phys), pointer :: tmpmax (:) => null() !< max temperature at 2m height (k) - real (kind=kind_phys), pointer :: dusfc (:) => null() !< u component of surface stress - real (kind=kind_phys), pointer :: dvsfc (:) => null() !< v component of surface stress - real (kind=kind_phys), pointer :: dtsfc (:) => null() !< sensible heat flux (w/m2) - real (kind=kind_phys), pointer :: dqsfc (:) => null() !< latent heat flux (w/m2) - real (kind=kind_phys), pointer :: totprcp(:) => null() !< accumulated total precipitation (kg/m2) - real (kind=kind_phys), pointer :: gflux (:) => null() !< groud conductive heat flux - real (kind=kind_phys), pointer :: dlwsfc (:) => null() !< time accumulated sfc dn lw flux ( w/m**2 ) - real (kind=kind_phys), pointer :: ulwsfc (:) => null() !< time accumulated sfc up lw flux ( w/m**2 ) - real (kind=kind_phys), pointer :: suntim (:) => null() !< sunshine duration time (s) - real (kind=kind_phys), pointer :: runoff (:) => null() !< total water runoff - real (kind=kind_phys), pointer :: ep (:) => null() !< potential evaporation - real (kind=kind_phys), pointer :: cldwrk (:) => null() !< cloud workfunction (valid only with sas) - real (kind=kind_phys), pointer :: dugwd (:) => null() !< vertically integrated u change by OGWD - real (kind=kind_phys), pointer :: dvgwd (:) => null() !< vertically integrated v change by OGWD - real (kind=kind_phys), pointer :: psmean (:) => null() !< surface pressure (kPa) - real (kind=kind_phys), pointer :: cnvprcp(:) => null() !< accumulated convective precipitation (kg/m2) - real (kind=kind_phys), pointer :: spfhmin(:) => null() !< minimum specific humidity - real (kind=kind_phys), pointer :: spfhmax(:) => null() !< maximum specific humidity - real (kind=kind_phys), pointer :: u10mmax(:) => null() !< maximum u-wind - real (kind=kind_phys), pointer :: v10mmax(:) => null() !< maximum v-wind - real (kind=kind_phys), pointer :: wind10mmax(:) => null() !< maximum wind speed - real (kind=kind_phys), pointer :: rain (:) => null() !< total rain at this time step - real (kind=kind_phys), pointer :: rainc (:) => null() !< convective rain at this time step - real (kind=kind_phys), pointer :: ice (:) => null() !< ice fall at this time step - real (kind=kind_phys), pointer :: snow (:) => null() !< snow fall at this time step - real (kind=kind_phys), pointer :: graupel(:) => null() !< graupel fall at this time step - real (kind=kind_phys), pointer :: totice (:) => null() !< accumulated ice precipitation (kg/m2) - real (kind=kind_phys), pointer :: totsnw (:) => null() !< accumulated snow precipitation (kg/m2) - real (kind=kind_phys), pointer :: totgrp (:) => null() !< accumulated graupel precipitation (kg/m2) - - ! Output - only in physics - real (kind=kind_phys), pointer :: u10m (:) => null() !< 10 meater u/v wind speed - real (kind=kind_phys), pointer :: v10m (:) => null() !< 10 meater u/v wind speed - real (kind=kind_phys), pointer :: dpt2m (:) => null() !< 2 meter dew point temperature - real (kind=kind_phys), pointer :: zlvl (:) => null() !< layer 1 height (m) - real (kind=kind_phys), pointer :: psurf (:) => null() !< surface pressure (Pa) - real (kind=kind_phys), pointer :: hpbl (:) => null() !< pbl height (m) - real (kind=kind_phys), pointer :: pwat (:) => null() !< precipitable water - real (kind=kind_phys), pointer :: t1 (:) => null() !< layer 1 temperature (K) - real (kind=kind_phys), pointer :: q1 (:) => null() !< layer 1 specific humidity (kg/kg) - real (kind=kind_phys), pointer :: u1 (:) => null() !< layer 1 zonal wind (m/s) - real (kind=kind_phys), pointer :: v1 (:) => null() !< layer 1 merdional wind (m/s) - real (kind=kind_phys), pointer :: chh (:) => null() !< thermal exchange coefficient - real (kind=kind_phys), pointer :: cmm (:) => null() !< momentum exchange coefficient - real (kind=kind_phys), pointer :: dlwsfci(:) => null() !< instantaneous sfc dnwd lw flux ( w/m**2 ) - real (kind=kind_phys), pointer :: ulwsfci(:) => null() !< instantaneous sfc upwd lw flux ( w/m**2 ) - real (kind=kind_phys), pointer :: dswsfci(:) => null() !< instantaneous sfc dnwd sw flux ( w/m**2 ) - real (kind=kind_phys), pointer :: uswsfci(:) => null() !< instantaneous sfc upwd sw flux ( w/m**2 ) - real (kind=kind_phys), pointer :: dusfci (:) => null() !< instantaneous u component of surface stress - real (kind=kind_phys), pointer :: dvsfci (:) => null() !< instantaneous v component of surface stress - real (kind=kind_phys), pointer :: dtsfci (:) => null() !< instantaneous sfc sensible heat flux - real (kind=kind_phys), pointer :: dqsfci (:) => null() !< instantaneous sfc latent heat flux - real (kind=kind_phys), pointer :: gfluxi (:) => null() !< instantaneous sfc ground heat flux - real (kind=kind_phys), pointer :: epi (:) => null() !< instantaneous sfc potential evaporation - real (kind=kind_phys), pointer :: smcwlt2(:) => null() !< wilting point (volumetric) - real (kind=kind_phys), pointer :: smcref2(:) => null() !< soil moisture threshold (volumetric) - real (kind=kind_phys), pointer :: wet1 (:) => null() !< normalized soil wetness - real (kind=kind_phys), pointer :: sr (:) => null() !< snow ratio : ratio of snow to total precipitation - real (kind=kind_phys), pointer :: tdomr (:) => null() !< accumulated rain type - real (kind=kind_phys), pointer :: tdomzr (:) => null() !< accumulated freezing rain type - real (kind=kind_phys), pointer :: tdomip (:) => null() !< accumulated sleet type - real (kind=kind_phys), pointer :: tdoms (:) => null() !< accumulated snow type - - real (kind=kind_phys), pointer :: skebu_wts(:,:) => null() !< 10 meater u/v wind speed - real (kind=kind_phys), pointer :: skebv_wts(:,:) => null() !< 10 meater u/v wind speed - real (kind=kind_phys), pointer :: sppt_wts(:,:) => null() !< 10 meater u/v wind speed - real (kind=kind_phys), pointer :: shum_wts(:,:) => null() !< 10 meater u/v wind speed - real (kind=kind_phys), pointer :: zmtnblck(:) => null() ! null() !< u momentum change due to physics - real (kind=kind_phys), pointer :: dv3dt (:,:,:) => null() !< v momentum change due to physics - real (kind=kind_phys), pointer :: dt3dt (:,:,:) => null() !< temperature change due to physics - real (kind=kind_phys), pointer :: dq3dt (:,:,:) => null() !< moisture change due to physics + type (topflw_type), pointer :: topflw(:) => null() !< lw radiation fluxes at top, component: + ! %upfxc - total sky upward lw flux at toa (w/m**2) + ! %upfx0 - clear sky upward lw flux at toa (w/m**2) + +! Input/output - used by physics + real (kind=kind_phys), pointer :: srunoff(:) => null() !< surface water runoff (from lsm) + real (kind=kind_phys), pointer :: evbsa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: evcwa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: snohfa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: transa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: sbsnoa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: snowca (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: soilm (:) => null() !< soil moisture + real (kind=kind_phys), pointer :: tmpmin (:) => null() !< min temperature at 2m height (k) + real (kind=kind_phys), pointer :: tmpmax (:) => null() !< max temperature at 2m height (k) + real (kind=kind_phys), pointer :: dusfc (:) => null() !< u component of surface stress + real (kind=kind_phys), pointer :: dvsfc (:) => null() !< v component of surface stress + real (kind=kind_phys), pointer :: dtsfc (:) => null() !< sensible heat flux (w/m2) + real (kind=kind_phys), pointer :: dqsfc (:) => null() !< latent heat flux (w/m2) + real (kind=kind_phys), pointer :: totprcp(:) => null() !< accumulated total precipitation (kg/m2) + real (kind=kind_phys), pointer :: gflux (:) => null() !< groud conductive heat flux + real (kind=kind_phys), pointer :: dlwsfc (:) => null() !< time accumulated sfc dn lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: ulwsfc (:) => null() !< time accumulated sfc up lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: suntim (:) => null() !< sunshine duration time (s) + real (kind=kind_phys), pointer :: runoff (:) => null() !< total water runoff + real (kind=kind_phys), pointer :: ep (:) => null() !< potential evaporation + real (kind=kind_phys), pointer :: cldwrk (:) => null() !< cloud workfunction (valid only with sas) + real (kind=kind_phys), pointer :: dugwd (:) => null() !< vertically integrated u change by OGWD + real (kind=kind_phys), pointer :: dvgwd (:) => null() !< vertically integrated v change by OGWD + real (kind=kind_phys), pointer :: psmean (:) => null() !< surface pressure (kPa) + real (kind=kind_phys), pointer :: cnvprcp(:) => null() !< accumulated convective precipitation (kg/m2) + real (kind=kind_phys), pointer :: spfhmin(:) => null() !< minimum specific humidity + real (kind=kind_phys), pointer :: spfhmax(:) => null() !< maximum specific humidity + real (kind=kind_phys), pointer :: u10mmax(:) => null() !< maximum u-wind + real (kind=kind_phys), pointer :: v10mmax(:) => null() !< maximum v-wind + real (kind=kind_phys), pointer :: wind10mmax(:) => null() !< maximum wind speed + real (kind=kind_phys), pointer :: rain (:) => null() !< total rain at this time step + real (kind=kind_phys), pointer :: rainc (:) => null() !< convective rain at this time step + real (kind=kind_phys), pointer :: ice (:) => null() !< ice fall at this time step + real (kind=kind_phys), pointer :: snow (:) => null() !< snow fall at this time step + real (kind=kind_phys), pointer :: graupel(:) => null() !< graupel fall at this time step + real (kind=kind_phys), pointer :: totice (:) => null() !< accumulated ice precipitation (kg/m2) + real (kind=kind_phys), pointer :: totsnw (:) => null() !< accumulated snow precipitation (kg/m2) + real (kind=kind_phys), pointer :: totgrp (:) => null() !< accumulated graupel precipitation (kg/m2) + +! Output - only in physics + real (kind=kind_phys), pointer :: u10m (:) => null() !< 10 meater u/v wind speed + real (kind=kind_phys), pointer :: v10m (:) => null() !< 10 meater u/v wind speed + real (kind=kind_phys), pointer :: dpt2m (:) => null() !< 2 meter dew point temperature + real (kind=kind_phys), pointer :: zlvl (:) => null() !< layer 1 height (m) + real (kind=kind_phys), pointer :: psurf (:) => null() !< surface pressure (Pa) + real (kind=kind_phys), pointer :: hpbl (:) => null() !< pbl height (m) + real (kind=kind_phys), pointer :: pwat (:) => null() !< precipitable water + real (kind=kind_phys), pointer :: t1 (:) => null() !< layer 1 temperature (K) + real (kind=kind_phys), pointer :: q1 (:) => null() !< layer 1 specific humidity (kg/kg) + real (kind=kind_phys), pointer :: u1 (:) => null() !< layer 1 zonal wind (m/s) + real (kind=kind_phys), pointer :: v1 (:) => null() !< layer 1 merdional wind (m/s) + real (kind=kind_phys), pointer :: chh (:) => null() !< thermal exchange coefficient + real (kind=kind_phys), pointer :: cmm (:) => null() !< momentum exchange coefficient + real (kind=kind_phys), pointer :: dlwsfci(:) => null() !< instantaneous sfc dnwd lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: ulwsfci(:) => null() !< instantaneous sfc upwd lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: dswsfci(:) => null() !< instantaneous sfc dnwd sw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: uswsfci(:) => null() !< instantaneous sfc upwd sw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: dusfci (:) => null() !< instantaneous u component of surface stress + real (kind=kind_phys), pointer :: dvsfci (:) => null() !< instantaneous v component of surface stress + real (kind=kind_phys), pointer :: dtsfci (:) => null() !< instantaneous sfc sensible heat flux + real (kind=kind_phys), pointer :: dqsfci (:) => null() !< instantaneous sfc latent heat flux + real (kind=kind_phys), pointer :: gfluxi (:) => null() !< instantaneous sfc ground heat flux + real (kind=kind_phys), pointer :: epi (:) => null() !< instantaneous sfc potential evaporation + real (kind=kind_phys), pointer :: smcwlt2(:) => null() !< wilting point (volumetric) + real (kind=kind_phys), pointer :: smcref2(:) => null() !< soil moisture threshold (volumetric) + real (kind=kind_phys), pointer :: wet1 (:) => null() !< normalized soil wetness + real (kind=kind_phys), pointer :: sr (:) => null() !< snow ratio : ratio of snow to total precipitation + real (kind=kind_phys), pointer :: tdomr (:) => null() !< accumulated rain type + real (kind=kind_phys), pointer :: tdomzr (:) => null() !< accumulated freezing rain type + real (kind=kind_phys), pointer :: tdomip (:) => null() !< accumulated sleet type + real (kind=kind_phys), pointer :: tdoms (:) => null() !< accumulated snow type + + real (kind=kind_phys), pointer :: skebu_wts(:,:) => null() !< 10 meater u/v wind speed + real (kind=kind_phys), pointer :: skebv_wts(:,:) => null() !< 10 meater u/v wind speed + real (kind=kind_phys), pointer :: sppt_wts(:,:) => null() !< 10 meater u/v wind speed + real (kind=kind_phys), pointer :: shum_wts(:,:) => null() !< 10 meater u/v wind speed +!--- accumulated quantities for 3D diagnostics + real (kind=kind_phys), pointer :: zmtnblck(:) => null() ! null() !< u momentum change due to physics + real (kind=kind_phys), pointer :: dv3dt (:,:,:) => null() !< v momentum change due to physics + real (kind=kind_phys), pointer :: dt3dt (:,:,:) => null() !< temperature change due to physics + real (kind=kind_phys), pointer :: dq3dt (:,:,:) => null() !< moisture change due to physics - !--- accumulated quantities for 3D diagnostics +!--- accumulated quantities for 3D diagnostics real (kind=kind_phys), pointer :: upd_mf (:,:) => null() !< instantaneous convective updraft mass flux real (kind=kind_phys), pointer :: dwn_mf (:,:) => null() !< instantaneous convective downdraft mass flux real (kind=kind_phys), pointer :: det_mf (:,:) => null() !< instantaneous convective detrainment mass flux real (kind=kind_phys), pointer :: cldcov (:,:) => null() !< instantaneous 3D cloud fraction !--- MP quantities for 3D diagnositics - real (kind=kind_phys), pointer :: refl_10cm (:,:) => null() !< instantaneous refl_10cm + real (kind=kind_phys), pointer :: refl_10cm(:,:) => null() !< instantaneous refl_10cm contains procedure create => diag_create @@ -990,7 +999,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%hprim = clear_val Sfcprop%hprime = clear_val - !--- In (radiation only) +!--- In (radiation only) allocate (Sfcprop%sncovr (IM)) allocate (Sfcprop%snoalb (IM)) allocate (Sfcprop%alvsf (IM)) @@ -1009,8 +1018,8 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%facsf = clear_val Sfcprop%facwf = clear_val - !--- physics surface props - !--- In +!--- physics surface props +!--- In allocate (Sfcprop%slope (IM)) allocate (Sfcprop%shdmin (IM)) allocate (Sfcprop%shdmax (IM)) @@ -1035,7 +1044,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%oro = clear_val Sfcprop%oro_uf = clear_val - !--- In/Out +!--- In/Out allocate (Sfcprop%hice (IM)) allocate (Sfcprop%weasd (IM)) allocate (Sfcprop%sncovr (IM)) @@ -1062,7 +1071,7 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%smc = clear_val Sfcprop%stc = clear_val - !--- Out +!--- Out allocate (Sfcprop%t2m (IM)) allocate (Sfcprop%q2m (IM)) @@ -1319,17 +1328,16 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & dt_phys, idat, jdat, tracer_names, & input_nml_file) - !--- modules - use physcons, only: max_lon, max_lat, min_lon, min_lat, & - dxmax, dxmin, dxinv, con_rerth, con_pi +!--- modules + use physcons, only: dxmax, dxmin, dxinv, con_rerth, con_pi, rhc_max use mersenne_twister, only: random_setseed, random_number use module_ras, only: nrcmax use parse_tracers, only: get_tracer_index - use wam_f107_kp_mod, only: f107_kp_size, f107_kp_interval, & + use wam_f107_kp_mod, only: f107_kp_size, f107_kp_interval, & f107_kp_skip_size, f107_kp_data_size implicit none - !--- interface variables +!--- interface variables class(GFS_control_type) :: Model integer, intent(in) :: nlunit character(len=64), intent(in) :: fn_nml @@ -1361,7 +1369,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_evod) :: wrk(1) real(kind=kind_phys), parameter :: con_hr = 3600. - !--- BEGIN NAMELIST VARIABLES +!--- BEGIN NAMELIST VARIABLES real(kind=kind_phys) :: fhzero = 0.0 !< seconds between clearing of diagnostic buckets logical :: lprecip_accu = .true. !< flag for precip accumulation without bucket (fhzero) logical :: ldiag3d = .false. !< flag for 3d diagnostic fields @@ -1376,14 +1384,14 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: cplflx = .false. !< default no cplflx collection logical :: cplwav = .false. !< default no cplwav collection - !--- integrated dynamics through earth's atmosphere +!--- integrated dynamics through earth's atmosphere logical :: lsidea = .false. - !--- radiation parameters +!--- radiation parameters real(kind=kind_phys) :: fhswr = 3600. !< frequency for shortwave radiation (secs) real(kind=kind_phys) :: fhlwr = 3600. !< frequency for longwave radiation (secs) integer :: levr = -99 !< number of vertical levels for radiation calculations - integer :: nfxr = 39 !< second dimension of input/output array fluxr + integer :: nfxr = 39+6 !< second dimension of input/output array fluxr logical :: aero_in = .false. !< flag for initializing aero data integer :: iflip = 1 !< iflip - is not the same as flipv integer :: isol = 0 !< use prescribed solar constant @@ -1417,7 +1425,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: lwhtr = .true. !< flag to output lw heating rate (Radtend%lwhc) logical :: swhtr = .true. !< flag to output sw heating rate (Radtend%swhc) - !--- Z-C microphysical parameters +!--- Z-C microphysical parameters integer :: ncld = 1 !< cnoice of cloud scheme integer :: imp_physics = 99 !< cnoice of cloud scheme real(kind=kind_phys) :: psautco(2) = (/6.0d-4,3.0d-4/) !< [in] auto conversion coeff from ice to snow @@ -1425,11 +1433,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: evpco = 2.0d-5 !< [in] coeff for evaporation of largescale rain real(kind=kind_phys) :: wminco(2) = (/1.0d-5,1.0d-5/) !< [in] water and ice minimum threshold for Zhao - !--- M-G microphysical parameters +!--- M-G microphysical parameters integer :: fprcp = 0 !< no prognostic rain and snow (MG) real(kind=kind_phys) :: mg_dcs = 350.0 !< Morrison-Gettleman microphysics parameters real(kind=kind_phys) :: mg_qcvar = 2.0 real(kind=kind_phys) :: mg_ts_auto_ice = 3600.0 !< ice auto conversion time scale + logical :: effr_in = .false. !< flag to use effective radii of cloud species in radiation + logical :: microp_uniform = .false. + logical :: do_cldice = .true. + logical :: hetfrz_classnuc = .false. !--- Thompson microphysical parameters logical :: ltaerosol = .false. !< flag for aerosol version @@ -1449,7 +1461,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: mom4ice = .false. !< flag controls mom4 sea ice logical :: use_ufo = .false. !< flag for gcycle surface option - !--- tuning parameters for physical parameterizations +!--- tuning parameters for physical parameterizations logical :: ras = .false. !< flag for ras convection scheme logical :: flipv = .true. !< flag for vertical direction flip (ras) !< .true. implies surface at k=1 @@ -1461,6 +1473,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: cscnv = .false. !< flag for Chikira-Sugiyama convection logical :: cal_pre = .false. !< flag controls precip type algorithm logical :: do_aw = .false. !< AW scale-aware option in cs convection + logical :: do_awdd = .false. !< AW scale-aware option in cs convection + logical :: flx_form = .false. !< AW scale-aware option in cs convection logical :: do_shoc = .false. !< flag for SHOC logical :: shocaftcnv = .false. !< flag for SHOC logical :: shoc_cld = .false. !< flag for SHOC in grrad @@ -1487,13 +1501,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & integer :: nmtvr = 14 !< number of topographic variables such as variance etc !< used in the GWD parameterization integer :: jcap = 1 !< number of spectral wave trancation used only by sascnv shalcnv - real(kind=kind_phys) :: cs_parm(10) = (/5.0,2.5,1.0e3,3.0e3,20.0,-999.,-999.,0.,0.,0./) +! real(kind=kind_phys) :: cs_parm(10) = (/5.0,2.5,1.0e3,3.0e3,20.0,-999.,-999.,0.,0.,0./) + real(kind=kind_phys) :: cs_parm(10) = (/10.0,4.0,1.0e3,2.0e3,20.0,1.0,-999.,0.,0.,0./) real(kind=kind_phys) :: flgmin(2) = (/0.180,0.220/) !< [in] ice fraction bounds real(kind=kind_phys) :: cgwf(2) = (/0.5d0,0.05d0/) !< multiplication factor for convective GWD real(kind=kind_phys) :: ccwf(2) = (/1.0d0,1.0d0/) !< multiplication factor for critical cloud !< workfunction for RAS real(kind=kind_phys) :: cdmbgwd(2) = (/2.0d0,0.25d0/) !< multiplication factors for cdmb and gwd - real(kind=kind_phys) :: sup = 1.1 !< supersaturation in pdf cloud when t is very low + real(kind=kind_phys) :: sup = 1.0 !< supersaturation in pdf cloud (IMP_physics=98) when t is very low + !< or ice super saturation in SHOC (when do_shoc=.true.) real(kind=kind_phys) :: ctei_rm(2) = (/10.0d0,10.0d0/) !< critical cloud top entrainment instability criteria !< (used if mstrat=.true.) real(kind=kind_phys) :: crtrh(3) = (/0.90d0,0.90d0,0.90d0/) !< critical relative humidity at the surface @@ -1501,12 +1517,13 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: dlqf(2) = (/0.0d0,0.0d0/) !< factor for cloud condensate detrainment !< from cloud edges for RAS real(kind=kind_phys) :: rbcr = 0.25 !< Critical Richardson Number in PBL scheme + real(kind=kind_phys) :: shoc_pcrit = 7000.0 !< critical pressure in Pa for tke dissipation in shoc - !--- Rayleigh friction +!--- Rayleigh friction real(kind=kind_phys) :: prslrd0 = 0.0d0 !< pressure level from which Rayleigh Damping is applied real(kind=kind_phys) :: ral_ts = 0.0d0 !< time scale for Rayleigh damping in days - !--- mass flux deep convection +!--- mass flux deep convection real(kind=kind_phys) :: clam_deep = 0.1 !< c_e for deep convection (Han and Pan, 2011, eq(6)) real(kind=kind_phys) :: c0s_deep = 0.002 !< convective rain conversion parameter real(kind=kind_phys) :: c1_deep = 0.002 !< conversion parameter of detrainment from liquid water into grid-scale cloud water @@ -1524,7 +1541,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land - !--- mass flux shallow convection +!--- mass flux shallow convection real(kind=kind_phys) :: clam_shal = 0.3 !< c_e for shallow convection (Han and Pan, 2011, eq(6)) real(kind=kind_phys) :: c0s_shal = 0.002 !< conversion parameter of detrainment from liquid water into convetive precipitaiton real(kind=kind_phys) :: c1_shal = 5.e-4 !< conversion parameter of detrainment from liquid water into grid-scale cloud water @@ -1538,7 +1555,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !< Until a realistic Nccn is provided, Nccns are assumed !< as Nccn=100 for sea and Nccn=1000 for land - !--- near surface temperature model +!--- near surface temperature model logical :: nst_anl = .false. !< flag for NSSTM analysis in gcycle/sfcsub integer :: lsea = 0 real(kind=kind_phys) :: xkzm_m = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum @@ -1555,21 +1572,26 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: xkzminv = 0.3 !< diffusivity in inversion layers real(kind=kind_phys) :: moninq_fac = 1.0 !< turbulence diffusion coefficient factor - !--- IAU options +!--- IAU options real(kind=kind_phys) :: iau_delthrs = 6 ! iau time interval (to scale increments) character(len=240) :: iau_inc_files(7)='' ! list of increment files real(kind=kind_phys) :: iaufhrs(7)=-1 ! forecast hours associated with increment files - !--- debug flag +!--- debug flag logical :: debug = .false. logical :: pre_rad = .false. !< flag for testing purpose - !--- stochastic physics control parameters +! max and min lon and lat for critical relative humidity + integer :: max_lon=5000, max_lat=2000, min_lon=192, min_lat=94 + real(kind=kind_phys) :: rhcmax = 0.9999999 !< max critical rel. hum. + +!--- stochastic physics control parameters logical :: do_sppt = .false. logical :: use_zmtnblck = .false. logical :: do_shum = .false. logical :: do_skeb = .false. integer :: skeb_npass = 11 - !--- END NAMELIST VARIABLES + +!--- END NAMELIST VARIABLES NAMELIST /gfs_physics_nml/ & !--- general parameters @@ -1583,7 +1605,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & isubc_lw, crick_proof, ccnorm, lwhtr, swhtr, & !--- microphysical parameterizations ncld, imp_physics, psautco, prautco, evpco, wminco, & - fprcp, mg_dcs, mg_qcvar, mg_ts_auto_ice, & + fprcp, mg_dcs, mg_qcvar, mg_ts_auto_ice, effr_in, & + microp_uniform, do_cldice, hetfrz_classnuc, & ltaerosol, lradar, lgfdlmprad, & !--- land/surface model control lsm, lsoil, nmtvr, ivegsrc, mom4ice, use_ufo, & @@ -1593,7 +1616,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & h2o_phys, pdfcld, shcnvcw, redrag, hybedmf, dspheat, cnvcld, & random_clds, shal_cnv, imfshalcnv, imfdeepcnv, do_deep, jcap,& cs_parm, flgmin, cgwf, ccwf, cdmbgwd, sup, ctei_rm, crtrh, & - dlqf,rbcr, & + dlqf, rbcr, shoc_pcrit, & !--- Rayleigh friction prslrd0, ral_ts, & !--- mass flux deep convection @@ -1608,20 +1631,24 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & !--- IAU iau_delthrs,iaufhrs,iau_inc_files, & !--- debug options - debug, pre_rad + debug, pre_rad, & + !--- parameter range for critical relative humidity + max_lon, max_lat, min_lon, min_lat, rhcmax, & + phys_version - !--- other parameters +!--- other parameters integer :: nctp = 0 !< number of cloud types in CS scheme logical :: gen_coord_hybrid = .false. !< for Henry's gen coord - !--- SHOC parameters +!--- SHOC parameters integer :: nshoc_2d = 0 !< number of 2d fields for SHOC integer :: nshoc_3d = 0 !< number of 3d fields for SHOC - !--- convective clouds +!--- convective clouds integer :: ncnvcld3d = 0 !< number of convective 3d clouds fields +!--- read in the namelist !--- read in the namelist #ifdef INTERNAL_FILE_NML Model%input_nml_file => input_nml_file @@ -1638,14 +1665,14 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & read (nlunit, nml=gfs_physics_nml) close (nlunit) #endif - !--- write version number and namelist to log file --- +!--- write version number and namelist to log file --- if (me == master) then write(logunit, '(a80)') '================================================================================' - write(logunit, '(a64)') version + write(logunit, '(a64)') phys_version write(logunit, nml=gfs_physics_nml) endif - !--- MPI parameters +!--- MPI parameters Model%me = me Model%master = master Model%nlunit = nlunit @@ -1669,17 +1696,17 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%levs = levs Model%cnx = cnx Model%cny = cny - Model%lonr = gnx - Model%latr = gny + Model%lonr = gnx ! number longitudinal points + Model%latr = gny ! number of latitudinal points from pole to pole - !--- coupling parameters +!--- coupling parameters Model%cplflx = cplflx Model%cplwav = cplwav - !--- integrated dynamics through earth's atmosphere +!--- integrated dynamics through earth's atmosphere Model%lsidea = lsidea - !--- calendars and time parameters and activation triggers +!--- calendars and time parameters and activation triggers Model%dtp = dt_phys Model%dtf = dt_dycore Model%nscyc = nint(fhcyc*3600./Model%dtp) @@ -1691,7 +1718,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%idate(3) = Model%idat(3) Model%idate(4) = Model%idat(1) - !--- radiation control parameters +!--- radiation control parameters Model%fhswr = fhswr Model%fhlwr = fhlwr Model%nsswr = nint(fhswr/Model%dtp) @@ -1719,26 +1746,38 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%lwhtr = lwhtr Model%swhtr = swhtr - !--- microphysical switch +!--- microphysical switch Model%ncld = ncld Model%imp_physics = imp_physics - !--- Zhao-Carr MP parameters +!--- Zhao-Carr MP parameters Model%psautco = psautco Model%prautco = prautco Model%evpco = evpco Model%wminco = wminco - !--- Morroson-Gettleman MP parameters +!--- Morroson-Gettleman MP parameters Model%fprcp = fprcp Model%mg_dcs = mg_dcs Model%mg_qcvar = mg_qcvar Model%mg_ts_auto_ice = mg_ts_auto_ice - !--- Thompson MP parameters + Model%effr_in = effr_in + Model%microp_uniform = microp_uniform + Model%do_cldice = do_cldice + Model%hetfrz_classnuc = hetfrz_classnuc + if (ncld == 1) then ! ncnd is the number of cloud condensate types + Model%ncnd = 1 + else + Model%ncnd = ncld + if(abs(fprcp) == 1 .and. ncld == 2) then + Model%ncnd = 4 + endif + endif +!--- Thompson MP parameters Model%ltaerosol = ltaerosol Model%lradar = lradar - !--- gfdl MP parameters +!--- gfdl MP parameters Model%lgfdlmprad = lgfdlmprad - !--- land/surface model parameters +!--- land/surface model parameters Model%lsm = lsm Model%lsoil = lsoil Model%ivegsrc = ivegsrc @@ -1746,7 +1785,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%mom4ice = mom4ice Model%use_ufo = use_ufo - !--- tuning parameters for physical parameterizations +!--- tuning parameters for physical parameterizations Model%ras = ras Model%flipv = flipv Model%trans_trac = trans_trac @@ -1757,7 +1796,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%cscnv = cscnv Model%cal_pre = cal_pre Model%do_aw = do_aw + Model%cs_parm = cs_parm Model%do_shoc = do_shoc + Model%shoc_pcrit = shoc_pcrit Model%shocaftcnv = shocaftcnv Model%shoc_cld = shoc_cld Model%h2o_phys = h2o_phys @@ -1774,9 +1815,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%do_deep = do_deep Model%nmtvr = nmtvr Model%jcap = jcap - Model%cs_parm = cs_parm Model%flgmin = flgmin - Model%cs_parm = cs_parm Model%cgwf = cgwf Model%ccwf = ccwf Model%cdmbgwd = cdmbgwd @@ -1786,11 +1825,12 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%dlqf = dlqf Model%rbcr = rbcr - !--- Rayleigh friction + +!--- Rayleigh friction Model%prslrd0 = prslrd0 Model%ral_ts = ral_ts - !--- mass flux deep convection +!--- mass flux deep convection Model%clam_deep = clam_deep Model%c0s_deep = c0s_deep Model%c1_deep = c1_deep @@ -1824,13 +1864,13 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%do_shum = do_shum Model%do_skeb = do_skeb - ! IAU flags - !--- iau parameters +! IAU flags +!--- iau parameters Model%iaufhrs = iaufhrs Model%iau_inc_files = iau_inc_files Model%iau_delthrs = iau_delthrs - !--- tracer handling +!--- tracer handling Model%ntrac = size(tracer_names) allocate (Model%tracer_names(Model%ntrac)) Model%tracer_names(:) = tracer_names(:) @@ -1849,17 +1889,17 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%ntwa = get_tracer_index(Model%tracer_names, 'liq_aero', Model%me, Model%master, Model%debug) Model%ntia = get_tracer_index(Model%tracer_names, 'ice_aero', Model%me, Model%master, Model%debug) - !--- quantities to be used to derive phy_f*d totals +!--- quantities to be used to derive phy_f*d totals Model%nshoc_2d = nshoc_2d Model%nshoc_3d = nshoc_3d Model%ncnvcld3d = ncnvcld3d Model%nctp = nctp - !--- debug flag +!--- debug flag Model%debug = debug Model%pre_rad = pre_rad - !--- set initial values for time varying properties +!--- set initial values for time varying properties Model%ipt = 1 Model%lprnt = .false. Model%lsswr = .false. @@ -1878,36 +1918,40 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%kdt = 0 Model%jdat(1:8) = jdat(1:8) - !--- stored in wam_f107_kp module +!--- stored in wam_f107_kp module f107_kp_size = 56 f107_kp_skip_size = 0 f107_kp_data_size = 56 f107_kp_interval = 10800 - !--- BEGIN CODE FROM GFS_PHYSICS_INITIALIZE - !--- define physcons module variables - tem = con_rerth*con_rerth*(con_pi+con_pi)*con_pi - dxmax = log(tem/(max_lon*max_lat)) - dxmin = log(tem/(min_lon*min_lat)) - dxinv = 1.0d0 / (dxmax-dxmin) - if (Model%me == Model%master) write(0,*)' dxmax=',dxmax,' dxmin=',dxmin,' dxinv=',dxinv +!--- BEGIN CODE FROM GFS_PHYSICS_INITIALIZE +!--- define physcons module variables + tem = con_rerth*con_rerth*(con_pi+con_pi)*con_pi + dxmax = log(tem/(max_lon*max_lat)) + dxmin = log(tem/(min_lon*min_lat)) + dxinv = 1.0d0 / (dxmax-dxmin) + rhc_max = rhcmax + if (Model%me == Model%master) write(0,*)' dxmax=',dxmax,' dxmin=',dxmin,' dxinv=',dxinv, & + 'max_lon=',max_lon,' max_lat=',max_lat,' min_lon=',min_lon,' min_lat=',min_lat, & + ' rhc_max=',rhc_max + +!--- set nrcm - !--- set nrcm if (Model%ras) then Model%nrcm = min(nrcmax, Model%levs-1) * (Model%dtp/1200.d0) + 0.10001d0 else Model%nrcm = 2 endif - !--- cal_pre +!--- cal_pre if (Model%cal_pre) then Model%random_clds = .true. endif - !--- END CODE FROM GFS_PHYSICS_INITIALIZE +!--- END CODE FROM GFS_PHYSICS_INITIALIZE - !--- BEGIN CODE FROM COMPNS_PHYSICS - !--- shoc scheme +!--- BEGIN CODE FROM COMPNS_PHYSICS +!--- shoc scheme if (do_shoc) then Model%nshoc_3d = 3 Model%nshoc_2d = 0 @@ -1918,18 +1962,20 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ' Boundary layer and Shallow Convection', & ' nshoc_3d=',Model%nshoc_3d, & ' nshoc_2d=',Model%nshoc_2d, & - ' ntke=',Model%ntke + ' ntke=',Model%ntke,' shoc_pcrit=',shoc_pcrit endif - !--- set number of cloud types +!--- set number of cloud types if (Model%cscnv) then Model%nctp = nint(Model%cs_parm(5)) Model%nctp = max(Model%nctp,10) if (Model%cs_parm(7) < 0.0) Model%cs_parm(7) = Model%dtp + Model%do_awdd = Model%do_aw .and. Model%cs_parm(6) > 0.0 + Model%flx_form = Model%do_aw .and. Model%cs_parm(8) > 0.0 endif Model%nctp = max(Model%nctp,1) - !--- output information about the run +!--- output information about the run if (Model%me == Model%master) then if (Model%lsm == 1) then print *,' NOAH Land Surface Model used' @@ -1949,31 +1995,31 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & print *,' nstf_name(4)=',Model%nstf_name(4) print *,' nstf_name(5)=',Model%nstf_name(5) endif - if (.not. Model%cscnv) then - if (Model%ras) then - print *,' RAS Convection scheme used with ccwf=',Model%ccwf - Model%imfdeepcnv = -1 + if (Model%do_deep) then + if (.not. Model%cscnv) then + if (Model%ras) then + print *,' RAS Convection scheme used with ccwf=',Model%ccwf + Model%imfdeepcnv = -1 + else + if (Model%imfdeepcnv == 0) then + print *,' old SAS Convection scheme before July 2010 used' + elseif(Model%imfdeepcnv == 1) then + print *,' July 2010 version of SAS conv scheme used' + elseif(Model%imfdeepcnv == 2) then + print *,' scale & aerosol-aware mass-flux deep conv scheme' + endif + endif else - if (Model%do_deep) then - if (Model%imfdeepcnv == 0) then - print *,' old SAS Convection scheme before July 2010 used' - elseif(Model%imfdeepcnv == 1) then - print *,' July 2010 version of SAS conv scheme used' - elseif(Model%imfdeepcnv == 2) then - print *,' scale & aerosol-aware mass-flux deep conv scheme' - endif - else - print*, ' Deep convection scheme disabled' - endif + if (Model%do_aw) then + print *,'Chikira-Sugiyama convection scheme with Arakawa-Wu'& + &, ' unified parameterization used' + else + print *,'Chikira-Sugiyama convection scheme used' + endif + print *,' cs_parm=',Model%cs_parm,' nctp=',Model%nctp endif else - if (Model%do_aw) then - print *,'Chikira-Sugiyama convection scheme with Arakawa-Wu'& - &, ' unified parameterization used' - else - print *,'Chikira-Sugiyama convection scheme used' - endif - print *,' cs_parm=',Model%cs_parm,' nctp=',Model%nctp + print*, ' Deep convection scheme disabled' endif if (.not. Model%old_monin .and. .not. Model%do_shoc) print *,' New PBL scheme used' if (.not. Model%shal_cnv) then @@ -2018,41 +2064,34 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & endif endif - !--- set up cloud schemes and tracer elements +!--- set up cloud schemes and tracer elements if (Model%imp_physics == 99) then - Model%npdf3d = 0 + Model%npdf3d = 0 Model%num_p3d = 4 Model%num_p2d = 3 Model%shcnvcw = .false. if (Model%me == Model%master) print *,' Using Zhao/Carr/Sundqvist Microphysics' - else if (Model%imp_physics == 98) then !Zhao Microphysics with PDF cloud - Model%npdf3d = 3 + + elseif (Model%imp_physics == 98) then !Zhao Microphysics with PDF cloud + Model%npdf3d = 3 Model%num_p3d = 4 Model%num_p2d = 3 if (Model%me == Model%master) print *,'Using Zhao/Carr/Sundqvist Microphysics with PDF Cloud' + else if (Model%imp_physics == 5) then ! F-A goes here print *,' Ferrier Microphysics scheme has been deprecated - job aborted' stop - elseif (Model%imp_physics == 11) then !GFDL microphysics - Model%npdf3d = 0 - Model%num_p3d = 1 ! rsun 4 before - Model%num_p2d = 1 - Model%pdfcld = .false. - Model%shcnvcw = .false. - Model%cnvcld = .false. - if (Model%me == Model%master) print *,' Using GFDL Cloud Microphysics' elseif (Model%imp_physics == 6) then !WSM6 microphysics - Model%npdf3d = 0 + Model%npdf3d = 0 Model%num_p3d = 3 Model%num_p2d = 1 Model%pdfcld = .false. Model%shcnvcw = .false. - if (Model%me == Model%master) print *,' Using wsm6 ', & - ' microphysics' - + if (Model%me == Model%master) print *,' Using wsm6 microphysics' + elseif (Model%imp_physics == 8) then !Thompson microphysics - Model%npdf3d = 0 + Model%npdf3d = 0 Model%num_p3d = 3 Model%num_p2d = 1 Model%pdfcld = .false. @@ -2068,32 +2107,41 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ' lradar =',Model%lradar,Model%num_p3d,Model%num_p2d else if (Model%imp_physics == 10) then ! Morrison-Gettelman Microphysics - Model%npdf3d = 0 - Model%num_p3d = 1 + Model%npdf3d = 0 + Model%num_p3d = 5 Model%num_p2d = 1 Model%pdfcld = .false. Model%shcnvcw = .false. - if (Model%me == Model%master) print *,' Using Morrison-Gettelman double moment', & + if (Model%me == Model%master) print *,' Using Morrison-Gettelman double moment', & ' microphysics',' aero_in=',Model%aero_in, & ' mg_dcs=',Model%mg_dcs,' mg_qcvar=',Model%mg_qcvar, & ' mg_ts_auto_ice=',Model%mg_ts_auto_ice + elseif (Model%imp_physics == 11) then !GFDL microphysics + Model%npdf3d = 0 + Model%num_p3d = 1 ! rsun 4 before + Model%num_p2d = 1 + Model%pdfcld = .false. + Model%shcnvcw = .false. + Model%cnvcld = .false. + if (Model%me == Model%master) print *,' Using GFDL Cloud Microphysics' + else if (Model%me == Model%master) print *,'Wrong imp_physics value. Job abort.' stop endif Model%uni_cld = .false. -! if ((Model%shoc_cld) .or. (Model%ncld == 2)) then +! if (Model%shoc_cld .or. Model%ncld == 2 .or. Model%ntclamt > 0) then if ((Model%shoc_cld) .or. (Model%imp_physics == 10)) then Model%uni_cld = .true. endif - if(Model%ras .or. Model%cscnv) Model%cnvcld = .false. + if(Model%ras .or. Model%cscnv) Model%cnvcld = .false. if(Model%do_shoc .or. Model%pdfcld) Model%cnvcld = .false. if(Model%cnvcld) Model%ncnvcld3d = 1 - !--- derived totals for phy_f*d +!--- derived totals for phy_f*d Model%ntot2d = Model%num_p2d + Model%nshoc_2d Model%ntot3d = Model%num_p3d + Model%nshoc_3d + Model%npdf3d + Model%ncnvcld3d if (me == Model%master) print *,' num_p3d=',Model%num_p3d,' num_p2d=',Model%num_p2d, & @@ -2103,19 +2151,21 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ' do_shoc=',Model%do_shoc,' nshoc3d=',Model%nshoc_3d, & ' nshoc_2d=',Model%nshoc_2d,' shoc_cld=',Model%shoc_cld,& ' ntot3d=',Model%ntot3d,' ntot2d=',Model%ntot2d, & - ' shocaftcnv=',Model%shocaftcnv + ' shocaftcnv=',Model%shocaftcnv,' shoc_pcrit=',Model%shoc_pcrit + +!--- END CODE FROM COMPNS_PHYSICS - !--- END CODE FROM COMPNS_PHYSICS +!--- BEGIN CODE FROM GLOOPR +!--- set up parameters for Xu & Randell's cloudiness computation (Radiation) - !--- BEGIN CODE FROM GLOOPR - !--- set up parameters for Xu & Randell's cloudiness computation (Radiation) Model%lmfshal = (Model%shal_cnv .and. (Model%imfshalcnv > 0)) Model%lmfdeep2 = (Model%imfdeepcnv == 2) - !--- END CODE FROM GLOOPR +!--- END CODE FROM GLOOPR + +!--- BEGIN CODE FROM GLOOPB +!--- set up random number seed needed for RAS and old SAS and when cal_pre=.true. - !--- BEGIN CODE FROM GLOOPB - !--- set up random number seed needed for RAS and old SAS and when cal_pre=.true. if ((Model%imfdeepcnv <= 0) .or. (Model%cal_pre)) then if (Model%random_clds) then seed0 = Model%idate(1) + Model%idate(2) + Model%idate(3) + Model%idate(4) @@ -2124,7 +2174,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%seed0 = seed0 + nint(wrk(1)*1000.0d0) endif endif - !--- END CODE FROM GLOOPB +!--- END CODE FROM GLOOPB call Model%print () @@ -2138,7 +2188,7 @@ subroutine control_print(Model) implicit none - !--- interface variables +!--- interface variables class(GFS_control_type) :: Model if (Model%me == Model%master) then @@ -2149,6 +2199,8 @@ subroutine control_print(Model) print *, ' nlunit : ', Model%nlunit print *, ' fn_nml : ', trim(Model%fn_nml) print *, ' fhzero : ', Model%fhzero + print *, ' lprecip_accu : ', Model%lprecip_accu + if (Model%lprecip_accu) print *,' continuous accumulation precip bucket is used' print *, ' ldiag3d : ', Model%ldiag3d print *, ' lssav : ', Model%lssav print *, ' fhcyc : ', Model%fhcyc @@ -2215,22 +2267,36 @@ subroutine control_print(Model) print *, 'microphysical switch' print *, ' ncld : ', Model%ncld print *, ' imp_physics : ', Model%imp_physics - print *, ' Z-C microphysical parameters' - print *, ' psautco : ', Model%psautco - print *, ' prautco : ', Model%prautco - print *, ' evpco : ', Model%evpco - print *, ' wminco : ', Model%wminco - print *, ' Thompson microphysical parameters' - print *, ' ltaerosol : ', Model%ltaerosol - print *, ' lradar : ', Model%lradar - print *, ' GFDL microphysical parameters' - print *, ' GFDL MP radiation inter: ', Model%lgfdlmprad - print *, ' M-G microphysical parameters' - print *, ' fprcp : ', Model%fprcp - print *, ' mg_dcs : ', Model%mg_dcs - print *, ' mg_qcvar : ', Model%mg_qcvar - print *, ' mg_ts_auto_ice : ', Model%mg_ts_auto_ice print *, ' ' + + if (Model%imp_physics == 99 .or. Model%imp_physics == 98) then + print *, ' Z-C microphysical parameters' + print *, ' psautco : ', Model%psautco + print *, ' prautco : ', Model%prautco + print *, ' evpco : ', Model%evpco + print *, ' wminco : ', Model%wminco + print *, ' ' + endif + if (Model%imp_physics == 6 .or. Model%imp_physics == 8) then + print *, ' Thompson microphysical parameters' + print *, ' ltaerosol : ', Model%ltaerosol + print *, ' lradar : ', Model%lradar + print *, ' ' + endif + if (Model%imp_physics == 10) then + print *, ' M-G microphysical parameters' + print *, ' fprcp : ', Model%fprcp + print *, ' mg_dcs : ', Model%mg_dcs + print *, ' mg_qcvar : ', Model%mg_qcvar + print *, ' mg_ts_auto_ice : ', Model%mg_ts_auto_ice + print *, ' ' + endif + if (Model%imp_physics == 11) then + print *, ' GFDL microphysical parameters' + print *, ' GFDL MP radiation inter: ', Model%lgfdlmprad + print *, ' ' + endif + print *, 'land/surface model parameters' print *, ' lsm : ', Model%lsm print *, ' lsoil : ', Model%lsoil @@ -2251,6 +2317,7 @@ subroutine control_print(Model) print *, ' cal_pre : ', Model%cal_pre print *, ' do_aw : ', Model%do_aw print *, ' do_shoc : ', Model%do_shoc + print *, ' shoc_pcrit : ', Model%shoc_pcrit print *, ' shocaftcnv : ', Model%shocaftcnv print *, ' shoc_cld : ', Model%shoc_cld print *, ' uni_cld : ', Model%uni_cld @@ -2284,31 +2351,37 @@ subroutine control_print(Model) print *, ' prslrd0 : ', Model%prslrd0 print *, ' ral_ts : ', Model%ral_ts print *, ' ' - print *, 'mass flux deep convection' - print *, ' clam_deep : ', Model%clam_deep - print *, ' c0s_deep : ', Model%c0s_deep - print *, ' c1_deep : ', Model%c1_deep - print *, ' betal_deep : ', Model%betal_deep - print *, ' betas_deep : ', Model%betas_deep - print *, ' evfact_deep : ', Model%evfact_deep - print *, ' evfactl_deep : ', Model%evfactl_deep - print *, ' pgcon_deep : ', Model%pgcon_deep - print *, ' asolfac_deep : ', Model%asolfac_deep - print *, ' ' - print *, 'mass flux shallow convection' - print *, ' clam_shal : ', Model%clam_shal - print *, ' c0s_shal : ', Model%c0s_shal - print *, ' c1_shal : ', Model%c1_shal - print *, ' pgcon_shal : ', Model%pgcon_shal - print *, ' asolfac_shal : ', Model%asolfac_shal + if (Model%imfdeepcnv >= 0) then + print *, 'mass flux deep convection' + print *, ' clam_deep : ', Model%clam_deep + print *, ' c0s_deep : ', Model%c0s_deep + print *, ' c1_deep : ', Model%c1_deep + print *, ' betal_deep : ', Model%betal_deep + print *, ' betas_deep : ', Model%betas_deep + print *, ' evfact_deep : ', Model%evfact_deep + print *, ' evfactl_deep : ', Model%evfactl_deep + print *, ' pgcon_deep : ', Model%pgcon_deep + print *, ' asolfac_deep : ', Model%asolfac_deep + print *, ' ' + endif + if (Model%imfshalcnv >= 0) then + print *, 'mass flux shallow convection' + print *, ' clam_shal : ', Model%clam_shal + print *, ' c0s_shal : ', Model%c0s_shal + print *, ' c1_shal : ', Model%c1_shal + print *, ' pgcon_shal : ', Model%pgcon_shal + print *, ' asolfac_shal : ', Model%asolfac_shal + endif print *, ' ' print *, 'near surface temperature model' print *, ' nst_anl : ', Model%nst_anl + print *, ' nstf_name : ', Model%nstf_name print *, ' lsea : ', Model%lsea + print *, ' ' + print *, 'background vertical diffusion coefficients' print *, ' xkzm_m : ', Model%xkzm_m print *, ' xkzm_h : ', Model%xkzm_h print *, ' xkzm_s : ', Model%xkzm_s - print *, ' nstf_name : ', Model%nstf_name print *, ' xkzminv : ', Model%xkzminv print *, ' moninq_fac : ', Model%moninq_fac print *, ' ' @@ -2395,14 +2468,14 @@ subroutine grid_create (Grid, IM, Model) Grid%area = clear_val Grid%dx = clear_val - !--- ozone active +!--- ozone active if ( Model%ntoz > 0 ) then allocate (Grid%ddy_o3 (IM)) allocate (Grid%jindx1_o3 (IM)) allocate (Grid%jindx2_o3 (IM)) endif - !--- stratosphere h2o active +!--- stratosphere h2o active if ( Model%h2o_phys ) then allocate (Grid%ddy_h (IM)) allocate (Grid%jindx1_h (IM)) @@ -2422,14 +2495,14 @@ subroutine tbd_create (Tbd, IM, Model) integer, intent(in) :: IM type(GFS_control_type), intent(in) :: Model - !--- In - !--- sub-grid cloud radiation +!--- In +!--- sub-grid cloud radiation if ( Model%isubc_lw == 2 .or. Model%isubc_sw == 2 ) then allocate (Tbd%icsdsw (IM)) allocate (Tbd%icsdlw (IM)) endif - !--- ozone and stratosphere h2o needs +!--- ozone and stratosphere h2o needs allocate (Tbd%ozpl (IM,levozp,oz_coeff)) allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) Tbd%ozpl = clear_val @@ -2438,7 +2511,7 @@ subroutine tbd_create (Tbd, IM, Model) allocate (Tbd%rann (IM,Model%nrcm)) Tbd%rann = rann_init - !--- In/Out +!--- In/Out allocate (Tbd%acv (IM)) allocate (Tbd%acvb (IM)) allocate (Tbd%acvt (IM)) @@ -2468,6 +2541,8 @@ subroutine tbd_create (Tbd, IM, Model) Tbd%phy_fctd = clear_val Tbd%phy_f2d = clear_val Tbd%phy_f3d = clear_val +! if (Model%do_shoc) Tbd%phy_f3d(:,1,Model%ntot3d-1) = 3.0 +! if (Model%do_shoc) Tbd%phy_f3d(:,:,Model%ntot3d-1) = 1.0 end subroutine tbd_create @@ -2532,12 +2607,12 @@ subroutine radtend_create (Radtend, IM, Model) Radtend%tsflw = clear_val Radtend%semis = clear_val - !--- In/Out (???) (radiation only) +!--- In/Out (???) (radiation only) allocate (Radtend%coszdg (IM)) Radtend%coszdg = clear_val - !--- In/Out (???) (physics only) +!--- In/Out (???) (physics only) allocate (Radtend%swhc (IM,Model%levs)) allocate (Radtend%lwhc (IM,Model%levs)) allocate (Radtend%lwhd (IM,Model%levs,6)) @@ -2564,8 +2639,8 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%fluxr (IM,Model%nfxr)) allocate (Diag%topfsw (IM)) allocate (Diag%topflw (IM)) - !--- Physics - !--- In/Out +!--- Physics +!--- In/Out allocate (Diag%srunoff (IM)) allocate (Diag%evbsa (IM)) allocate (Diag%evcwa (IM)) @@ -2640,14 +2715,14 @@ subroutine diag_create (Diag, IM, Model) allocate (Diag%skebv_wts(IM,Model%levs)) allocate (Diag%sppt_wts(IM,Model%levs)) allocate (Diag%shum_wts(IM,Model%levs)) +!--- 3D diagnostics allocate (Diag%zmtnblck(IM)) - !--- 3D diagnostics if (Model%ldiag3d) then allocate (Diag%du3dt (IM,Model%levs,4)) allocate (Diag%dv3dt (IM,Model%levs,4)) allocate (Diag%dt3dt (IM,Model%levs,6)) allocate (Diag%dq3dt (IM,Model%levs,oz_coeff+5)) - !--- needed to allocate GoCart coupling fields +!--- needed to allocate GoCart coupling fields allocate (Diag%upd_mf (IM,Model%levs)) allocate (Diag%dwn_mf (IM,Model%levs)) allocate (Diag%det_mf (IM,Model%levs)) @@ -2695,77 +2770,77 @@ subroutine diag_phys_zero (Diag, Model, linit) logical,optional, intent(in) :: linit !--- In/Out - Diag%srunoff = zero - Diag%evbsa = zero - Diag%evcwa = zero - Diag%snohfa = zero - Diag%transa = zero - Diag%sbsnoa = zero - Diag%snowca = zero - Diag%soilm = zero - Diag%tmpmin = huge - Diag%tmpmax = zero - Diag%dusfc = zero - Diag%dvsfc = zero - Diag%dtsfc = zero - Diag%dqsfc = zero - Diag%gflux = zero - Diag%dlwsfc = zero - Diag%ulwsfc = zero - Diag%suntim = zero - Diag%runoff = zero - Diag%ep = zero - Diag%cldwrk = zero - Diag%dugwd = zero - Diag%dvgwd = zero - Diag%psmean = zero - Diag%spfhmin = huge - Diag%spfhmax = zero - Diag%u10mmax = zero - Diag%v10mmax = zero + Diag%srunoff = zero + Diag%evbsa = zero + Diag%evcwa = zero + Diag%snohfa = zero + Diag%transa = zero + Diag%sbsnoa = zero + Diag%snowca = zero + Diag%soilm = zero + Diag%tmpmin = huge + Diag%tmpmax = zero + Diag%dusfc = zero + Diag%dvsfc = zero + Diag%dtsfc = zero + Diag%dqsfc = zero + Diag%gflux = zero + Diag%dlwsfc = zero + Diag%ulwsfc = zero + Diag%suntim = zero + Diag%runoff = zero + Diag%ep = zero + Diag%cldwrk = zero + Diag%dugwd = zero + Diag%dvgwd = zero + Diag%psmean = zero + Diag%spfhmin = huge + Diag%spfhmax = zero + Diag%u10mmax = zero + Diag%v10mmax = zero Diag%wind10mmax = zero - Diag%rain = zero - Diag%rainc = zero - Diag%ice = zero - Diag%snow = zero - Diag%graupel = zero + Diag%rain = zero + Diag%rainc = zero + Diag%ice = zero + Diag%snow = zero + Diag%graupel = zero !--- Out - Diag%u10m = zero - Diag%v10m = zero - Diag%dpt2m = zero - Diag%zlvl = zero - Diag%psurf = zero - Diag%hpbl = zero - Diag%pwat = zero - Diag%t1 = zero - Diag%q1 = zero - Diag%u1 = zero - Diag%v1 = zero - Diag%chh = zero - Diag%cmm = zero - Diag%dlwsfci = zero - Diag%ulwsfci = zero - Diag%dswsfci = zero - Diag%uswsfci = zero - Diag%dusfci = zero - Diag%dvsfci = zero - Diag%dtsfci = zero - Diag%dqsfci = zero - Diag%gfluxi = zero - Diag%epi = zero - Diag%smcwlt2 = zero - Diag%smcref2 = zero - Diag%wet1 = zero - Diag%sr = zero - Diag%tdomr = zero - Diag%tdomzr = zero - Diag%tdomip = zero - Diag%tdoms = zero - Diag%skebu_wts = zero - Diag%skebv_wts = zero - Diag%sppt_wts = zero - Diag%shum_wts = zero + Diag%u10m = zero + Diag%v10m = zero + Diag%dpt2m = zero + Diag%zlvl = zero + Diag%psurf = zero + Diag%hpbl = zero + Diag%pwat = zero + Diag%t1 = zero + Diag%q1 = zero + Diag%u1 = zero + Diag%v1 = zero + Diag%chh = zero + Diag%cmm = zero + Diag%dlwsfci = zero + Diag%ulwsfci = zero + Diag%dswsfci = zero + Diag%uswsfci = zero + Diag%dusfci = zero + Diag%dvsfci = zero + Diag%dtsfci = zero + Diag%dqsfci = zero + Diag%gfluxi = zero + Diag%epi = zero + Diag%smcwlt2 = zero + Diag%smcref2 = zero + Diag%wet1 = zero + Diag%sr = zero + Diag%tdomr = zero + Diag%tdomzr = zero + Diag%tdomip = zero + Diag%tdoms = zero + Diag%skebu_wts = zero + Diag%skebv_wts = zero + Diag%sppt_wts = zero + Diag%shum_wts = zero if (Model%ldiag3d) then Diag%du3dt = zero @@ -2787,8 +2862,8 @@ subroutine diag_phys_zero (Diag, Model, linit) Diag%totice = zero Diag%totsnw = zero Diag%totgrp = zero - if(Model%me == Model%master) print *,'in diag_phys_zero, set diag variable to zero',& - 'size(Diag%totprcp)=',size(Diag%totprcp) +! if(Model%me == Model%master) print *,'in diag_phys_zero, set diag variable to zero',& +! 'size(Diag%totprcp)=',size(Diag%totprcp) endif end subroutine diag_phys_zero diff --git a/gfsphysics/makefile b/gfsphysics/makefile index 183c82db8..6924264c2 100644 --- a/gfsphysics/makefile +++ b/gfsphysics/makefile @@ -139,7 +139,9 @@ SRCS_F90 = \ ./physics/GFDL_parse_tracers.F90 \ ./physics/gcycle.F90 \ ./physics/gfdl_cloud_microphys.F90 \ - ./physics/module_mp_radar.F90 \ + ./physics/micro_mg_utils.F90 \ + ./physics/micro_mg2_0.F90 \ + ./physics/module_mp_radar.F90 \ ./physics/module_mp_thompson_gfs.F90 \ ./physics/module_mp_wsm6_fv3.F90 \ ./GFS_layer/GFS_abstraction_layer.F90 \ diff --git a/gfsphysics/physics/cldmacro.F b/gfsphysics/physics/cldmacro.F index 34568dac9..084db5da5 100644 --- a/gfsphysics/physics/cldmacro.F +++ b/gfsphysics/physics/cldmacro.F @@ -75,13 +75,13 @@ module cldmacro real :: CNVDDRFC real :: ANVDDRFC real :: LSDDRFC - integer :: tanhrhcrit - real :: minrhcrit - real :: maxrhcrit +! integer :: tanhrhcrit +! real :: minrhcrit +! real :: maxrhcrit +! real :: maxrhcritland real :: turnrhcrit real :: turnrhcrit_upper real :: MIN_RI, MAX_RI, MIN_RL, MAX_RL, RI_ANV - real :: maxrhcritland real, parameter :: T_ICE_MAX = MAPL_TICE @@ -95,7 +95,7 @@ module cldmacro real, parameter :: PI_0 = 4.*atan(1.) - real omeps, trinv + real omeps, trinv, t_ice_denom !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -103,7 +103,7 @@ module cldmacro subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev - &, EXNP_dev, FRLAND_dev, RMFDTR_dev + &, FRLAND_dev, RMFDTR_dev &, QLWDTR_dev, QRN_CU_dev, CNV_UPDFRC_dev &, U_dev, V_dev, TH_dev, Q_dev &, QLW_LS_dev, QLW_AN_dev, QIW_LS_dev @@ -120,13 +120,12 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev &, CNV_NDROP_dev, CNV_NICE_dev, SCICE_dev &, NCPL_dev, NCPI_dev, PFRZ_dev &, QRAIN_CN, QSNOW_CN - &, KCBL, lprnt, ipr ) + &, KCBL, lprnt, ipr, rhc ) integer, intent(in ) :: IRUN, LM real, intent(in ) :: DT real, intent(in ), dimension(IRUN, LM) :: PP_dev real, intent(in ), dimension(IRUN,0:LM) :: PPE_dev - real, intent(in ), dimension(IRUN, LM) :: EXNP_dev real, intent(in ), dimension(IRUN ) :: FRLAND_dev real, intent(in ), dimension(IRUN, LM) :: RMFDTR_dev real, intent(in ), dimension(IRUN, LM) :: QLWDTR_dev @@ -134,6 +133,7 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev real, intent(inout), dimension(IRUN, LM) :: CNV_UPDFRC_dev real, intent(in ), dimension(IRUN, LM) :: U_dev real, intent(in ), dimension(IRUN, LM) :: V_dev + real, intent(in ), dimension(IRUN, LM) :: rhc real, intent(inout), dimension(IRUN, LM) :: TH_dev real, intent(inout), dimension(IRUN, LM) :: Q_dev real, intent(inout), dimension(IRUN, LM) :: QLW_LS_dev @@ -189,13 +189,16 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev integer :: FRACTION_REMOVAL - real :: MASS, iMASS, TOTFRC, QRN_CU_1D, QSN_CU, QRN_ALL, QSN_ALL + real :: MASS, iMASS, TOTFRC, QRN_CU_1D, QSN_CU, QRN_ALL, QSN_ALL &, QTMP1, QTMP2, QTMP3, QTOT, TEMP, RHCRIT, AA3, BB3, ALPHA &, VFALL, VFALLRN, VFALLSN, TOT_PREC_UPD, AREA_UPD_PRC - &, AREA_UPD_PRC_tolayer, U_above,U_below, V_above,V_below - &, DZET_above,DZET_below, PRN_CU_above, PSN_CU_above + &, AREA_UPD_PRC_tolayer + &, PRN_CU_above, PSN_CU_above +! &, AREA_UPD_PRC_tolayer, U_above,U_below, V_above,V_below +! &, DZET_above,DZET_below, PRN_CU_above, PSN_CU_above &, EVAP_DD_CU_above, SUBL_DD_CU_above &, NIX, TOTAL_WATER, dti, tx1, tend, fqi +! &, NIX, TOTAL_WATER, dti, tx1, tend, fqi, psinv, pops logical :: use_autoconv_timescale ! @@ -203,9 +206,9 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev ! omeps = 1. - epsqs + dti = 1.0 /dt + trinv = 1.0/ttrice - dti = 1.0 /dt - trinv = 1.0/ttrice CNV_BETA = PHYSPARAMS(1) ANV_BETA = PHYSPARAMS(2) LS_BETA = PHYSPARAMS(3) @@ -244,11 +247,11 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev CNVDDRFC = PHYSPARAMS(36) ANVDDRFC = PHYSPARAMS(37) LSDDRFC = PHYSPARAMS(38) - tanhrhcrit = INT( PHYSPARAMS(41) ) - minrhcrit = PHYSPARAMS(42) - maxrhcrit = PHYSPARAMS(43) - turnrhcrit = PHYSPARAMS(45) - maxrhcritland = PHYSPARAMS(46) +! tanhrhcrit = INT( PHYSPARAMS(41) ) +! minrhcrit = PHYSPARAMS(42) +! maxrhcrit = PHYSPARAMS(43) + turnrhcrit = PHYSPARAMS(45) * 0.001 +! maxrhcritland = PHYSPARAMS(46) fr_ls_wat = INT( PHYSPARAMS(47) ) fr_ls_ice = INT( PHYSPARAMS(48) ) fr_an_wat = INT( PHYSPARAMS(49) ) @@ -261,10 +264,11 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev pdfflag = INT(PHYSPARAMS(57)) - turnrhcrit_upper = PHYSPARAMS(58) + turnrhcrit_upper = PHYSPARAMS(58) * 0.001 use_autoconv_timescale = .false. + t_ice_denom = 1.0 / (T_ICE_MAX-T_ICE_ALL) RUN_LOOP: DO I = 1, IRUN ! Anning initialization here @@ -272,6 +276,7 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev PSN_CU_above = 0. EVAP_DD_CU_above = 0. SUBL_DD_CU_above = 0. +! psinv = 1.0 / ppe_dev(i,lm) K_LOOP: DO K = 1, LM @@ -286,7 +291,6 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev CUARF_dev(I) = 0. end if - QRN_CU_1D = 0. QSN_CU = 0. VFALL = 0. @@ -299,8 +303,6 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev PFI_CN_dev(I,0) = 0. END IF - - RHX_dev(I,K) = 0.0 REV_CN_dev(I,K) = 0.0 RSU_CN_dev(I,K) = 0.0 @@ -316,7 +318,6 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev VFALLSN = 0.0 VFALLRN = 0.0 - ! DNDCNV_dev(I, K) = 0.0 ! DNCCNV_dev(I, K) = 0.0 ! RAS_DT_dev(I, K) = 0.0 @@ -325,13 +326,12 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev QSNOW_CN(I,K) = 0.0 NIX = 0.0 - QRN_CU_1D = QRN_CU_dev(I,K) MASS = (PPE_dev(I,K) - PPE_dev(I,K-1)) & * (100./MAPL_GRAV) iMASS = 1.0 / MASS - TEMP = EXNP_dev(I,K) * TH_dev(I,K) + TEMP = TH_dev(I,K) FRZ_PP_dev(I,K) = 0.00 @@ -369,37 +369,41 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev ANVFRC_dev(I,K) = min(ANVFRC_dev(I,K) + TEND*DT, 1.0) ! - ! DCNVi_dev(I,K) = (QIW_AN_dev(I,K) - DCNVi_dev(I,K) ) * DTi ! DCNVL_dev(I,K) = (QLW_AN_dev(I,K) - DCNVL_dev(I,K) ) * DTi ! DNDCNV_dev(I,K) = (NCPL_dev(I,K) - DNDCNV_dev(I,K)) * DTi ! DNCCNV_dev(I,K) = (NCPI_dev(I,K) - DNCCNV_dev(I,K)) * DTi - if (k == 1 .or. k == lm) then - U_above = 0.0 - U_below = 0.0 - V_above = 0.0 - V_below = 0.0 - DZET_above = 0.0 - DZET_below = 0.0 - else - U_above = U_dev(i,k-1) - U_below = U_dev(i,k+1) - V_above = V_dev(i,k-1) - V_below = V_dev(i,k+1) - DZET_above = DZET_dev(i,k-1) - DZET_below = DZET_dev(i,k+1) - end if - - call pdf_spread (K, LM, U_dev(I,K), U_above, U_below, - & V_dev(I,K), V_above, V_below, - & DZET_above, DZET_below, CNV_UPDFRC_dev(I,K), - & PP_dev(I,K), ALPHA, ALPHT_dev(I,K), - & FRLAND_dev(I) ) - - - ALPHA = MAX( ALPHA , 1.0 - RH00 ) +! if (k == 1 .or. k == lm) then +! U_above = 0.0 +! U_below = 0.0 +! V_above = 0.0 +! V_below = 0.0 +! DZET_above = 0.0 +! DZET_below = 0.0 +! else +! U_above = U_dev(i,k-1) +! U_below = U_dev(i,k+1) +! V_above = V_dev(i,k-1) +! V_below = V_dev(i,k+1) +! DZET_above = DZET_dev(i,k-1) +! DZET_below = DZET_dev(i,k+1) +! end if + +! call pdf_spread (K, LM, U_dev(I,K), U_above, U_below, +! & V_dev(I,K), V_above, V_below, +! & DZET_above, DZET_below, CNV_UPDFRC_dev(I,K), +! & PP_dev(I,K), ALPHA, ALPHT_dev(I,K), +! & FRLAND_dev(I) ) +! pops = PP_dev(I,K) * psinv + +! call pdf_spread (K, LM, PP_dev(I,K), ALPHA, ALPHT_dev(I,K), +! call pdf_spread (K, LM, pops, ALPHA, ALPHT_dev(I,K), +! & FRLAND_dev(I), rhc(i) ) + + ALPHA = max(1.0e-4, 1.0-rhc(i,k)) + ALPHT_dev(I,K) = ALPHA RHCRIT = 1.0 - ALPHA @@ -407,10 +411,10 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev call Pfreezing (ALPHA , PP_dev(I,K) , TEMP , Q_dev(I,K), - & QLW_LS_dev(I,K), QLW_AN_dev(I,K), - & QIW_LS_dev(I,K), QIW_AN_dev(I,K), - & SCICE_dev(I,K) , CLDFRC_dev(I,K), - & ANVFRC_dev(I,K), PFRZ_dev(I,K) ) + & QLW_LS_dev(I,K), QLW_AN_dev(I,K), + & QIW_LS_dev(I,K), QIW_AN_dev(I,K), + & SCICE_dev(I,K) , CLDFRC_dev(I,K), + & ANVFRC_dev(I,K), PFRZ_dev(I,K) ) !=============Collect convective precip============== @@ -538,14 +542,18 @@ subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev end if !*********************** end of if(false)******************************** + if (lprnt .and. i== ipr) write(0,*)'in macrocld1 clffrc=', + & CLDFRC_dev(I,K) ,' k=',k CALL fix_up_clouds_2M( Q_dev(I,K) , TEMP , QLW_LS_dev(I,K), & QIW_LS_dev(I,K), CLDFRC_dev(I,K), QLW_AN_dev(I,K), & QIW_AN_dev(I,K), ANVFRC_dev(I,K), NCPL_dev(I, K), & NCPI_dev(I, K)) + if (lprnt .and. i== ipr) write(0,*)'in macrocld1 clffrc=', + & CLDFRC_dev(I,K) , ' k=',k - TH_dev(I,K) = TEMP / EXNP_dev(I,K) + TH_dev(I,K) = TEMP end do K_LOOP @@ -604,41 +612,36 @@ END SUBROUTINE MACRO_CLOUD !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine pdf_spread (K,LM, U,U_above,U_below, V,V_above, - & V_below, DZ_above,DZ_below, UPDF, - & PP,ALPHA, ALPHT_DIAG, FRLAND ) + subroutine pdf_spread (K, LM, PP, ALPHA, ALPHT_DIAG, FRLAND, rhc) integer, intent(in) :: k,lm - real, intent(in) :: U, U_above, U_below, V, V_above, V_below - &, DZ_above, DZ_below, UPDF, PP, FRLAND + real, intent(in) :: PP, FRLAND, rhc real, intent(out) :: ALPHA, ALPHT_DIAG - real :: tempmaxrh, slope, slope_up, turnrhcrit_up - &, aux1, aux2, maxalpha, A1,A2,A3 - - slope = 20.0 - slope_up = 20.0 +! real, parameter :: slope = 20.0, slope_up = 20.0 + real, parameter :: slope = 0.02, slope_up = 0.02 - turnrhcrit_up = turnrhcrit_upper + real :: aux1, aux2, maxalpha - maxalpha = 1.0 - minrhcrit +! maxalpha = 1.0 - minrhcrit + maxalpha = 1.0 - rhc - aux1 = min(max((pp- turnrhcrit)/slope, -20.0), 20.0) - aux2 = min(max((turnrhcrit_up - pp)/slope_up, -20.0), 20.0) + aux1 = min(max((pp - turnrhcrit)/slope, -20.0), 20.0) + aux2 = min(max((turnrhcrit_upper - pp)/slope_up, -20.0), 20.0) if (frland > 0.05) then - aux1 = 1.0 +! aux1 = 1.0 + aux1 = 1.0 / (1.0+exp(aux1+aux1)) else - aux1 = 1.0 / (1.0+exp(aux1)) + aux1 = 2.0 / (1.0+exp(aux1+aux1)) end if aux2 = 1.0 / (1.0+exp(aux2)) + alpha = max(1.0e-4, min(0.3, maxalpha*aux1*aux2)) +! alpha = min(0.3, maxalpha*aux1*aux2) !Anning - alpha = maxalpha*aux1*aux2*2 !Anning - - ALPHA = MIN( ALPHA , 0.4 ) ALPHT_DIAG = ALPHA end subroutine pdf_spread @@ -744,48 +747,42 @@ end subroutine fix_up_clouds_2M !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine update_cld( irun, lm, DT, ALPHA, - & PDFSHAPE, PL, QV, QCl, - & QAl, QCi, QAi, TE, CF, AF, - & SCICE, NI, NL, NCnuc, RHcmicro) + & PDFSHAPE, PL, QV, QCl, QAl, + & QCi, QAi, TE, CF, AF, + & SCICE, NI, NL) +! & SCICE, NI, NL, NCnuc) integer, intent(in) :: irun, lm, pdfshape real, intent(in) :: DT - real, intent(in), dimension(irun,lm) :: ALPHA,PL, NCnuc + real, intent(in), dimension(irun,lm) :: ALPHA, PL +! real, intent(in), dimension(irun,lm) :: ALPHA, PL, NCnuc real, intent(inout), dimension(irun,lm) :: te, qv, qcl, qci - &, CF,QAl,QAi,AF, NI, RHCmicro, NL, SCICE - - real :: CFO,pl100 - real :: QT, DQ - - real :: QSx,DQsx + &, CF, QAl, QAi, AF, NI, NL, SCICE - real :: QCx, QC, QA - - real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA + real :: CFO, pl100, QT, DQ, QSx, DQsx, QCx, QC, QA + &, QX, QSLIQ, QSICE, CFALL, DQx, FQA real :: esl, esi, esn !temp use only Anning integer :: i,k - - pdfflag = PDFSHAPE do k=1,lm do i=1,irun if(QV(i,k) > 1.e-6) then - pl100=pl(i,k)*100 - QC = QCl(i,k) + QCi(i,k) - QA = QAl(i,k) + QAi(i,k) + pl100 = pl(i,k)*100 + QC = QCl(i,k) + QCi(i,k) + QA = QAl(i,k) + QAi(i,k) !Anning do not let empty cloud exist - if(QC.le.0.) CF(i,k)=0. - if(QA.le.0.) AF(i,k)=0. - QT = QC + QA + QV(i,k) - CFALL = AF(i,k) + CF(i,k) + if(QC <= 0.) CF(i,k) = 0. + if(QA <= 0.) AF(i,k) = 0. + QT = QC + QA + QV(i,k) + CFALL = AF(i,k) + CF(i,k) - if (QA+QC > 0.0) then - FQA = QA / (QA+QC) - else - FQA = 0.0 - end if + if (QA+QC > 0.0) then + FQA = QA / (QA+QC) + else + FQA = 0.0 + end if !================================================ ! First find the cloud fraction that would correspond to the current ! condensate @@ -795,67 +792,62 @@ subroutine update_cld( irun, lm, DT, ALPHA, ! & esl,QSLIQ,DQx) ! call vqsatd2_ice_single(TE(i,k),PL(i,k)*100.0, ! & esi,QSICE,DQx) - esl=min(fpvsl(TE(i,k)),pl100) - QSLIQ= min(epsqs*esl/(pl100-omeps*esl),1.) - esi=min(fpvsi(TE(i,k)),pl100) - QSICE= min(epsqs*esi/(pl100-omeps*esi),1.) - - if ((QC+QA) > 0.0) then - QSx = ( (QCl(i,k)+QAl(i,k))*QSLIQ - & + (QCi(i,k)+QAi(i,k))*QSICE ) / (QC+QA) - else -! DQSx = DQSAT( TEo , PL , 35.0, QSAT=QSx ) + esl = min(fpvsl(TE(i,k)),pl100) + QSLIQ = min(epsqs*esl/(pl100-omeps*esl),1.) + esi = min(fpvsi(TE(i,k)),pl100) + QSICE = min(epsqs*esi/(pl100-omeps*esi),1.) + + if ((QC+QA) > 0.0) then + QSx = ( (QCl(i,k)+QAl(i,k))*QSLIQ + & + (QCi(i,k)+QAi(i,k))*QSICE ) / (QC+QA) + else +! DQSx = DQSAT( TEo , PL , 35.0, QSAT=QSx ) ! call vqsatd2_single( TE(i,k), pl(i,k)*100., esl,QSx,DQSx) - esn=min(fpvs(TE(i,k)),pl100) - QSx= min(epsqs*esn/(pl100-omeps*esn),1.) + esn = min(fpvs(TE(i,k)),pl100) + QSx = min(epsqs*esn/(pl100-omeps*esn),1.) + + end if - end if +! if (TE(i,k) > T_ICE_ALL) SCICE(i,k) = 1.0 - if (TE(i,k) > T_ICE_ALL) SCICE(i,k) = 1.0 - QCx = QC + QA - QX = QT - QSx*SCICE(i,k) - CFo = 0. + QCx = QC + QA + QX = QT - QSx*SCICE(i,k) + CFo = 0. ! recalculate QX if too low and SCICE 0.0)) then - CFo = (1.0+SQRT(1.0-(QX/QCx))) - if (CFo > 1.e-6) then - CFo = min(1.0/CFo, 1.0) - DQ = 2.0*QCx/(CFo*CFo) - else - CFo = 0.0 - end if - else - if (QCx > 0.0) then - CFo = 1.0 - end if - DQ = 2.0*ALPHA(i,k)*QSx - end if - - if (QSx > 0.0) then - RHCmicro(i,k) = SCICE(i,k) - 0.5*DQ/Qsx - else - RHCmicro(i,k) = 0.0 - end if + if ((QX <= QCx) .and. (QCx > 0.0)) then + CFo = (1.0+SQRT(1.0-(QX/QCx))) + if (CFo > 1.e-6) then + CFo = min(1.0/CFo, 1.0) + DQ = 2.0*QCx/(CFo*CFo) + else + CFo = 0.0 + end if + else + if (QCx > 0.0) then + CFo = 1.0 + end if + DQ = 2.0*ALPHA(i,k)*QSx + end if - CFALL = max(CFo, 0.0) - CFALL = min(CFo, 1.0) + CFALL = max(CFo, 0.0) + CFALL = min(CFo, 1.0) - CF(i,k) = CFALL*(1.0-FQA) - AF(i,k) = CFALL*FQA + CF(i,k) = CFALL*(1.0-FQA) + AF(i,k) = CFALL*FQA -! if ((TE(i,k) <= T_ICE_ALL)) cycle +! if ((TE(i,k) <= T_ICE_ALL)) cycle - call hystpdf( DT, ALPHA(i,k), PDFSHAPE, PL(i,k), QV(i,k) - &, QCl(i,k), QAl(i,k), QCi(i,k) - &, QAi(i,k), TE(i,k), CF(i,k), AF(i,k) - &, SCICE(i,k), NI(i,k), NL(i,k), i, k ) + call hystpdf( DT, ALPHA(i,k), PDFSHAPE, PL(i,k), QV(i,k) + &, QCl(i,k), QAl(i,k), QCi(i,k) + &, QAi(i,k), TE(i,k), CF(i,k), AF(i,k) + &, SCICE(i,k), NI(i,k), NL(i,k), i, k ) !Anning do not let empty cloud exist - if(QCl(i,k)+QCi(i,k).le.0.) CF(i,k)=0. - if(QAl(i,k)+QAi(i,k).le.0.) AF(i,k)=0. + if(QCl(i,k)+QCi(i,k) <= 0.0) CF(i,k) = 0. + if(QAl(i,k)+QAi(i,k) <= 0.0) AF(i,k) = 0. end if enddo enddo @@ -873,84 +865,81 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF, NI, NL, & SCICE + integer, parameter :: nmax=20 - real :: QCO, QVO, CFO, QAO, TAU, SCICE_x + real :: QCO, QVO, CFO, QAO, TAU real :: QT, QMX, QMN, DQ, QVtop, sigmaqt1, sigmaqt2, qsnx - real :: TEO,QSx,DQsx,QS,DQs - - real :: TEp, QSp, CFp, QVp, QCp - real :: TEn, QSn, CFn, QVn, QCn + real :: TEO, QSx, DQsx, QS, DQs + &, TEp, QSp, CFp, QVp, QCp + &, TEn, QSn, CFn, QVn, QCn real :: QCx, QVx, CFx, QAx, QC, QA, fQi, fQi_A - real :: dQAi, dQAl, dQCi, dQCl - - real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA, DQSI, DQSL, LHcorr, - & fQip,pl100 - - real :: tmpARR - real :: esn,desdt,weight,tc,hlatsb,hlatvp,hltalt,tterm,gam - logical lflg - real :: ALHX, DQCALL - + &, dQAi, dQAl, dQCi, dQCl - integer :: N, nmax,i,k + real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA, pl100, tmpARR + &, ALHX, DQCALL, esn, desdt, tc, hltalt, tterm + integer :: N, i, k pdfflag = PDFSHAPE - pl100=pl*100 + pl100 = pl*100 QC = QCl + QCi QA = QAl + QAi - QT = QC + QA + QV - CFALL = AF+CF + QT = QC + QA + QV + CFALL = AF + CF FQA = 0.0 fQi = 0.0 tmpARR = 0.0 - nmax = 20 QAx = 0.0 if (QA+QC > 0.0) FQA = QA / (QA+QC) if (QA > 0.0) fQi_A = QAi / QA if (QT > 0.0) fQi = (QCI+QAI) / QT if (TE < T_ICE_ALL) fQi = 1.0 - if ( AF < 1.0 ) tmpARR = 1. / (1.-AF) + if ( AF < 1.0 ) tmpARR = 1.0 / (1.0-AF) TEo = TE - fQi = ice_fraction( TEn ) +! + fqi = 1.0 - max(0.0, min(1.0, (te-t_ice_all)*t_ice_denom)) + fqi = (max(0.0,min(1.0,fqi))) ** ICEFRPWR + +! fQi = ice_fraction( TE ) +! fQi = ice_fraction( TEn ) ! DQS = DQSAT( TE, PL, QSAT=QSx ) Anning changed to the foollowing ! DQSx = DQSAT( TE, PL, QSAT=QSx ) ! call vqsatd2_single( TE, pl*100., esn,QSx,DQSx) - esn=min(fpvs(TE),pl100) - QSx= min(epsqs*esn/(pl100-omeps*esn),1.) - tc = TE - MAPL_TICE - lflg = (tc >= -ttrice .and. tc < 0.) - weight = min(-tc*trinv,1.0) - hlatsb = hlatv + weight*hlatf - hlatvp = hlatv - 2369.0*tc - if (TE < MAPL_TICE) then - hltalt = hlatsb - else - hltalt = hlatvp - end if - if (lflg) then - tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) - & +tc*(pcf(4) + tc*pcf(5)))) + + esn = min(fpvs(TE),pl100) + QSx = min(epsqs*esn/(pl100-omeps*esn),1.) + + if (qsx < 1.0) then + tc = TE - MAPL_TICE + if (TE < MAPL_TICE) then + hltalt = hlatv + hlatf * min(-tc*trinv,1.0) + else + hltalt = hlatv - 2369.0*tc + end if + if (tc >= -ttrice .and. tc < 0.0) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + & + tc*(pcf(4) + tc*pcf(5)))) + else + tterm = 0.0 + end if + desdt = hltalt*esn/(rgasv*TE*TE) + tterm*trinv + dqsx = qsx*pl100*desdt/(esn*(pl100-omeps*esn)) else - tterm = 0. - end if - desdt = hltalt*esn/(rgasv*TE*TE) + tterm*trinv - gam = hltalt*qsx*pl100*desdt/(MAPL_cp*esn*(pl100-omeps*esn)) - if (qsx == 1.0) gam = 0.0 - DQSx=(MAPL_cp/hltalt)*gam + DQSx = 0.0 + endif CFx = CF*tmpARR QCx = QC*tmpARR QVx = ( QV - QSx*AF )*tmpARR ! if ( AF >= 1.0 ) QVx = QSx*1.e-4 - if ( AF > 0. ) QAx = QA/AF + if ( AF > 0.0 ) QAx = QA/AF QT = QCx + QVx @@ -962,14 +951,13 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, QCn = QCx DQS = DQSx - do n=1,nmax QVp = QVn QCp = QCn CFp = CFn TEp = TEn - fQip= fQi +! fQip= fQi if(pdfflag < 2) then sigmaqt1 = ALPHA*QSn @@ -982,13 +970,13 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, endif qsnx = qsn*SCICE - if ((QCI >= 0.0) .and. (qsn > qt)) qsnx = qsn + if (QCI >= 0.0 .and. qsn > qt) qsnx = qsn call pdffrac(PDFSHAPE,qt,sigmaqt1,sigmaqt2,qsnx,CFn) - call pdfcondensate(PDFSHAPE,qt,sigmaqt1,sigmaqt2,qsnx,QCn, CFn) + call pdfcondensate(PDFSHAPE,qt,sigmaqt1,sigmaqt2,qsnx,QCn,CFn) DQCALL = QCn - QCp - CF = CFn * ( 1.-AF) + CF = CFn * ( 1.0-AF) ! call Bergeron_iter (DT, PL, TEp, QT, QCi, QAi, QCl, QAl, ! & CF, AF, NL, NI, DQCALL, fQi) @@ -1004,60 +992,62 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, if(pdfflag == 1) then QCn = QCp + (QCn- QCp) - & / (1. - (CFn*(ALPHA-1.) - QCn/QSn) *DQS*ALHX) + & / (1.0 - (CFn*(ALPHA-1.0) - QCn/QSn) *DQS*ALHX) elseif(pdfflag == 2) then - if (n.ne.nmax) QCn = QCp + ( QCn - QCp ) *0.5 + if (n < nmax) QCn = QCp + ( QCn - QCp ) * 0.5 endif QVn = QVp - (QCn - QCp) - TEn = TEp + ((1.0-fQi)*alhlbcp + fQi*alhsbcp) - & *((QCn - QCp)*(1.-AF) + (QAo-QAx)*AF) + TEn = TEp + ALHX * ((QCn-QCp)*(1.0-AF) + (QAo-QAx)*AF) + +! fqi = 1.0 - max(0.0, min(1.0, (ten-t_ice_all)*t_ice_denom)) +! fqi = (max(0.0,min(1.0,fqi))) ** ICEFRPWR - if (abs(Ten - Tep) < 0.00001) exit + if (abs(Ten-Tep) < 0.00001) exit ! DQS = DQSAT( TEn, PL, QSAT=QSn ) ! call vqsatd2_single( TEn, pl*100., esn,QSn,DQS) - esn=min(fpvs(TEn),pl100) - QSn= min(epsqs*esn/(pl100-omeps*esn),1.) - tc = TEn - MAPL_TICE - lflg = (tc >= -ttrice .and. tc < 0.) - weight = min(-tc*trinv,1.0) - hlatsb = hlatv + weight*hlatf - hlatvp = hlatv - 2369.0*tc - if (TEn < MAPL_TICE) then - hltalt = hlatsb - else - hltalt = hlatvp - end if - if (lflg) then - tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) - & +tc*(pcf(4) + tc*pcf(5)))) + esn = min(fpvs(TEn),pl100) + QSn = min(epsqs*esn/(pl100-omeps*esn),1.0) + + if (qsx < 1.0) then + tc = TEn - MAPL_TICE + if (TEn < MAPL_TICE) then + hltalt = hlatv + hlatf * min(-tc*trinv,1.0) + else + hltalt = hlatv - 2369.0*tc + end if + if (tc >= -ttrice .and. tc < 0.0) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + & + tc*(pcf(4) + tc*pcf(5)))) + else + tterm = 0.0 + end if + desdt = hltalt*esn/(rgasv*TEn*TEn) + tterm*trinv + dqs = QSn*pl100*desdt/(esn*(pl100-omeps*esn)) else - tterm = 0. - end if - desdt = hltalt*esn/(rgasv*TEn*TEn) + tterm*trinv - gam = hltalt*QSn*pl100*desdt/(MAPL_cp*esn*(pl100-omeps*esn)) - if (qsx == 1.0) gam = 0.0 - DQS=(MAPL_cp/hltalt)*gam + DQS = 0.0 + endif enddo CFo = CFn CF = CFn QCo = QCn - QVo = QVn - TEo = TEn +! QVo = QVn +! TEo = TEn +! TE = TEn if ( AF < 1.0 ) then - CF = CFo * ( 1.-AF) - QCo = QCo * ( 1.-AF) + CF = CFo * ( 1.0-AF) + QCo = QCo * ( 1.0-AF) QAo = QAo * AF else - CF = 0. + CF = 0.0 QAo = QA + QC - QCo = 0. + QCo = 0.0 QT = QAo + QV - QAo = MAX( QT - QSx, 0. ) + QAo = MAX(QT-QSx, 0.0) end if dQCl = 0.0 @@ -1072,10 +1062,10 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, if (QCx < -1.e-3) QCx = -1.e-3 if (QCx < 0.0) then dQCl = max(QCx, -QCl) - dQCi = max(QCx - dQCl, -QCi) + dQCi = max(QCx-dQCl, -QCi) else - dQCl = (1.0-fQi)*QCx - dQCi = fQi * QCx + dQCi = QCx * fQi + dQCl = QCx - dQCi end if !Anvil QAx is not in anvil @@ -1085,10 +1075,10 @@ subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, if (QAx < 0.0) then dQAl = max(QAx, -QAl) - dQAi = max(QAx - dQAl, -QAi) + dQAi = max(QAx-dQAl, -QAi) else - dQAl = (1.0-fQi)*QAx - dQAi = QAx*fQi + dQAi = QAx * fQi + dQAl = QAx - dQAi end if ! if(.false.) then !Anning turn it off causing unstable @@ -1133,51 +1123,44 @@ subroutine pdffrac (flag,qtmean,sigmaqt1,sigmaqt2,qstar,clfrac) integer flag - real qtmean - real sigmaqt1 - real sigmaqt2 - real qstar - real clfrac - - real :: qtmode, qtmin, qtmax - + real :: qtmean, sigmaqt1, sigmaqt2, qstar, clfrac - real :: qtmedian, aux + real :: qtmode, qtmin, qtmax, qtmedian, aux - if(flag.eq.1) then - if((qtmean+sigmaqt1).lt.qstar) then + if(flag == 1) then + aux = qtmean + sigmaqt1 - qstar + if (aux < 0.0) then clfrac = 0. else - if(sigmaqt1.gt.0.) then - clfrac = min((qtmean + sigmaqt1 - qstar),2.*sigmaqt1) - & /(2.*sigmaqt1) + if(sigmaqt1 > 0.0) then + clfrac = min(0.5*aux/sigmaqt1, 1.0) else clfrac = 1. endif endif - elseif(flag.eq.2) then + elseif(flag == 2) then qtmode = qtmean + (sigmaqt1-sigmaqt2)/3. - qtmin = min(qtmode-sigmaqt1,0.) - qtmax = qtmode + sigmaqt2 - if(qtmax.lt.qstar) then + qtmin = min(qtmode-sigmaqt1,0.) + qtmax = qtmode + sigmaqt2 + if(qtmax < qstar) then clfrac = 0. - elseif ( (qtmode.le.qstar).and.(qstar.lt.qtmax) ) then + elseif ( (qtmode <= qstar).and.(qstar < qtmax) ) then clfrac = (qtmax-qstar)*(qtmax-qstar) / & ((qtmax-qtmin)*(qtmax-qtmode)) - elseif ( (qtmin.le.qstar).and.(qstar.lt.qtmode) ) then + elseif ( (qtmin <= qstar).and.(qstar < qtmode) ) then clfrac = 1. - ((qstar-qtmin)*(qstar-qtmin) & /( (qtmax-qtmin)*(qtmode-qtmin))) - elseif ( qstar.le.qtmin ) then + elseif ( qstar <= qtmin ) then clfrac = 1. endif - elseif(flag.eq.4) then - if (qtmean .gt. 1.0e-20) then + elseif(flag == 4) then + if (qtmean > 1.0e-20) then qtmedian = qtmean*exp(-0.5*sigmaqt1*sigmaqt1) - aux = log(qtmedian/qstar)/sqrt(2.0)/sigmaqt1 - aux=min(max(aux, -20.0), 20.0) - clfrac=0.5*(1.0+erf_app(aux)) + aux = log(qtmedian/qstar)/sqrt(2.0)/sigmaqt1 + aux = min(max(aux, -20.0), 20.0) + clfrac = 0.5*(1.0+erf_app(aux)) else - clfrac = 0.0 + clfrac = 0.0 end if endif @@ -2049,74 +2032,62 @@ end subroutine Bergeron_iter subroutine Pfreezing ( ALPHA , PL , TE , QV , QCl , QAl , QCi , & QAi , SC_ICE , CF , AF , PF ) - - real , intent(in) :: PL,ALPHA, QV, SC_ICE, AF, TE, QCl, QCi, QAl, & QAi, CF real , intent(out) :: PF - real :: qt, QCx, QSn, tmpARR, CFALL, QVx, CFio, QA, QAx, QC, QI, - & QL, DQSx - real :: sigmaqt1, sigmaqt2, qsnx - real :: esl, esi,pl100 - - pl100=pl*100 + & QL, DQSx, sigmaqt1, sigmaqt2, qsnx, esl, esi,pl100 - QA = QAl + QAi - QC = QCl + QCi - CFALL = AF + pl100 = pl*100 - if ( CFALL >= 1.0 ) then - PF = 0.0 - return - end if - -! QSn = QSATIC( TE , PL*100.0 , DQ=DQSx ) -! call vqsatd2_ice_single(TE,PL*100.0,esl,QSn,DQSx) - esi=min(fpvsi(TE),pl100) - QSn= min(epsqs*esi/(pl100-omeps*esi),1.) + QA = QAl + QAi + QC = QCl + QCi + CFALL = AF - QSn = MAX( QSn , 1.0e-9 ) + if ( CFALL >= 1.0 ) then + PF = 0.0 + return + end if +! QSn = QSATIC( TE , PL*100.0 , DQ=DQSx ) +! call vqsatd2_ice_single(TE,PL*100.0,esl,QSn,DQSx) + esi = min(fpvsi(TE),pl100) + QSn = max(min(epsqs*esi/(pl100-omeps*esi), 1.0), 1.0e-9) - tmpARR = 0.0 - if ( CFALL < 0.99 ) then - tmpARR = 1./(1.0-CFALL) - end if + tmpARR = 0.0 + if ( CFALL < 0.99 ) then + tmpARR = 1./(1.0-CFALL) + end if - QCx = QC*tmpARR - QVx = ( QV - QSn*CFALL )*tmpARR -! QVx = QV*tmpARR + QCx = QC*tmpARR + QVx = ( QV - QSn*CFALL )*tmpARR +! QVx = QV*tmpARR - qt = QCx + QVx + qt = QCx + QVx - CFio = 0.0 + CFio = 0.0 - QSn = QSn*SC_ICE + QSn = QSn*SC_ICE - if(pdfflag.lt.2) then - sigmaqt1 = max(ALPHA, 0.1)*QSn - sigmaqt2 = max(ALPHA, 0.1)*QSn - elseif(pdfflag.eq.2) then + if(pdfflag < 2) then + sigmaqt1 = max(ALPHA, 0.1) * QSn + sigmaqt2 = max(ALPHA, 0.1) * QSn + elseif(pdfflag == 2) then ! for triangular, symmetric: sigmaqt1 = sigmaqt2 = alpha*qsn (alpha is half width) ! for triangular, skewed r : sigmaqt1 < sigmaqt2 ! try: skewed right below 500 mb !!! if(pl.lt.500.) then - sigmaqt1 = ALPHA*QSn - sigmaqt2 = ALPHA*QSn - elseif(pdfflag .eq. 4) then - sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) - endif - - - - call pdffrac(pdfflag,qt,sigmaqt1,sigmaqt2,qsn,CFio) + sigmaqt1 = ALPHA * QSn + sigmaqt2 = ALPHA * QSn + elseif(pdfflag == 4) then + sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) + endif - PF = CFio*(1.0-CFALL) + call pdffrac(pdfflag,qt,sigmaqt1,sigmaqt2,qsn,CFio) - PF = min(max(PF, 0.0), 0.999) + PF = min(max(CFio*(1.0-CFALL), 0.0), 0.999) end subroutine Pfreezing diff --git a/gfsphysics/physics/cldwat2m_micro.F b/gfsphysics/physics/cldwat2m_micro.F index 75446f29f..4f5f2d92c 100644 --- a/gfsphysics/physics/cldwat2m_micro.F +++ b/gfsphysics/physics/cldwat2m_micro.F @@ -392,7 +392,7 @@ subroutine ini_micro(Dcs_, QCVAR_, ts_auto_ice_) ! smallest mixing ratio considered in microphysics - qsmall = 1.e-18_r8 + qsmall = 1.e-18_r8 qvsmall = 1.e-6_r8 ! immersion freezing parameters, bigg 1953 @@ -501,7 +501,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & npccnin, rndst,nacon, rhdfda, rhu00, fice, tlat, qvlat, qctend, & qitend, nctend, nitend, effc, effc_fn, effi, prect, preci, & nevapr, evapsnow, prain, prodsnow, cmeout, deffi, pgamrad, - & lamcrad,qsout2,qrout2, drout2, qcsevap,qisevap,qvres, + & lamcrad,qsout2,dsout2,qrout2, drout2, qcsevap,qisevap,qvres, & cmeiout, vtrmc,vtrmi,qcsedten,qisedten, prao, & prco,mnuccco,mnuccto, & msacwio,psacwso, bergso,bergo,melto,homoo,qcreso,prcio,praio, @@ -510,7 +510,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, & nsout2, nrout2, ncnst, ninst, nimm, miu_disp, nsoot, rnsoot, & ui_scale, dcrit, nnuccdo, nnuccco, nsacwio, nsubio, nprcio, & npraio, npccno, npsacwso, nsubco, nprao, nprc1o, tlataux, - & nbincontactdust, lprint,xlat,xlon) + & nbincontactdust, lprint, xlat, xlon, rhc) ! & nbincontactdust, ts_auto_ice,xlat,xlon) @@ -569,6 +569,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, real(r8), intent(in) :: rpdel(pcols,pver) real(r8), intent(in) :: zm(pcols,pver) ! real(r8), intent(in) :: omega(pcols,pver) + real(r8), intent(in) :: rhc(pcols,pver) real(r8), intent(out) :: rate1ord_cw2pr_st(pcols,pver) @@ -892,8 +893,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, real(r8) :: freqs(pcols,pver) real(r8) :: freqr(pcols,pver) real(r8) :: dumfice - real(r8), intent(out) :: drout2(pcols,pver) - real(r8) :: dsout2(pcols,pver) + real(r8), intent(out), dimension(pcols,pver) :: drout2, dsout2 !ice nucleation, droplet activation real(r8) :: dum2i(pcols,pver) @@ -1177,14 +1177,14 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !Get humidity and saturation vapor pressures big loop1 - do k=1,pver + do k=1,pver ! big loop1 - k loop ! find wet bulk temperature and saturation value for provisional t and q without ! condensation ! call vqsatd_water(t(1,k),p(1,k),es,qs,gammas,ncol) - do i=1,ncol + do i=1,ncol ! big i loop1 #ifdef NEMS_GSM esl(i,k) = min(fpvsl(t(i,k)), p(i,k)) @@ -1313,7 +1313,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, lami(k) = (cons1*ci*niic(i,k)/qiic(i,k))**oneodi -! miu_ice=mui_hemp_l(lami(k)) +! miu_ice = mui_hemp_l(lami(k)) miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, & 10.0_r8), 0.1_r8) tx1 = one + miu_ice(k) @@ -1542,7 +1542,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, dum2i(i,k) = zero end if - end do ! end big i loop + end do ! end big i loop1 end do !end big loop1 - k loop !! @@ -1578,7 +1578,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! assign number of sub-steps to iter ! use 2 sub-steps, following tests described in MG2008 ! Anning Cheng 9/17/2016 - if(fprcp==1) then + if (fprcp == 1) then iter = 1 else iter = 2 @@ -1830,7 +1830,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, lami(k) = (cons1*ci*niic(i,k)/qiic(i,k))**oneodi -! miu_ice(k)=mui_hemp_l(lami(k)) +! miu_ice(k) = mui_hemp_l(lami(k)) miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, & 10.0_r8), 0.1_r8) tx1 = one + miu_ice(k) @@ -2009,41 +2009,42 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! 0.45 m/s is fallspeed of new rain drop (80 micron diameter) - if(fprcp==1) then - qric(i,k) = min(qrn(i,k)/lcldm(i,k), 5.e-3_r8) - nric(i,k) = max(nrn(i,k)/lcldm(i,k), zero) - else - dum = 0.45_r8 - dum1 = 0.45_r8 - - if (k == 1) then - tx1 = lcldm(i,k)*dz(i,k)/(cldmax(i,k)*dum) - qric(i,k) = prc(k) * tx1 - nric(i,k) = nprc(k) * tx1 + if (fprcp == 1) then + tx1 = one / lcldm(i,k) + qric(i,k) = min(qrn(i,k)*tx1, 10.e-3_r8) + nric(i,k) = max(nrn(i,k)*tx1, zero) else - if (qric(i,km) >= qsmall) then + dum = 0.45_r8 + dum1 = 0.45_r8 + + if (k == 1) then + tx1 = lcldm(i,k)*dz(i,k)/(cldmax(i,k)*dum) + qric(i,k) = prc(k) * tx1 + nric(i,k) = nprc(k) * tx1 + else + if (qric(i,km) >= qsmall) then ! dum=umr(k-1) ! dum1=unr(k-1) ! Anning Cheng find a possible untable case here - dum = max(umr(km),dum) - dum1 = max(unr(km),dum1) - endif + dum = max(umr(km),dum) + dum1 = max(unr(km),dum1) + endif ! no autoconversion of rain number if rain/snow falling from above ! this assumes that new drizzle drops formed by autoconversion are rapidly collected ! by the existing rain/snow particles from above - if (qric(i,km) >= 1.e-9_r8 .or. - & qniic(i,km) >= 1.e-9_r8) then - nprc(k) = zero - endif + if (qric(i,km) >= 1.e-9_r8 .or. + & qniic(i,km) >= 1.e-9_r8) then + nprc(k) = zero + endif - tx1 = rho(i,km) * cldmax(i,km) - tx3 = rho(i,k) * cldmax(i,k) - qric(i,k) = (tx1*umr(km)*qric(i,km) - & + (rdz*((pra(km)+prc(k))*lcldm(i,k) - & + (pre(km)-pracs(km)-mnuccr(km))*cldmax(i,k)))) - & / (dum*tx3) + tx1 = rho(i,km) * cldmax(i,km) + tx3 = rho(i,k) * cldmax(i,k) + qric(i,k) = (tx1*umr(km)*qric(i,km) + & + (rdz*((pra(km)+prc(k))*lcldm(i,k) + & + (pre(km)-pracs(km)-mnuccr(km))*cldmax(i,k)))) + & / (dum*tx3) ! nric(i,k) = (rho(i,k-1)*unr(k-1)*nric(i,k-1)*cldmax(i,k-1)+ @@ -2052,13 +2053,13 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! &k)) ! Anning nsubr never given a value before - nric(i,k) = (tx1*unr(km)*nric(i,km) + nric(i,k) = (tx1*unr(km)*nric(i,km) & + (rdz*(nprc(k)*lcldm(i,k) & +(-npracs(km)-nnuccr(km)+nragg(km))*cldmax(i,k)))) & / (dum1*tx3) - endif - endif !fprcp + endif + endif !fprcp !....................................................................... ! Autoconversion of cloud ice to snow (Ice_aut) @@ -2070,28 +2071,28 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, !vaux = 180.0_r8*10.0_r8 if (.false.) then - vaux = ts_auto_ice * 10.0_r8 - - nprci(k) = (niic(i, k)/vaux)*exp(-lami(k)*dcs) - tx1 = one / lami(k) - tx2 = tx1 * tx1 - prci(k) = pi*irho(i,k)*niic(i,k)*lami(k) - & / (6._r8*vaux) - & * (cons23*tx1+three*cons24*tx2 - & + 6._r8*dcs*tx1*tx2+6._r8*tx2*tx2) - & * exp(-lami(k)*dcs) + vaux = ts_auto_ice * 10.0_r8 + + nprci(k) = (niic(i, k)/vaux)*exp(-lami(k)*dcs) + tx1 = one / lami(k) + tx2 = tx1 * tx1 + prci(k) = pi*irho(i,k)*niic(i,k)*lami(k) + & / (6._r8*vaux) + & * (cons23*tx1+three*cons24*tx2 + & + 6._r8*dcs*tx1*tx2+6._r8*tx2*tx2) + & * exp(-lami(k)*dcs) else -! miu_ice(k) = mui_hemp_l(lami(k)) - miu_ice(k) =max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, - & 10.0_r8), 0.1_r8) - tx1 = lami(k)*dcs - nprci(k) = (niic(i,k)/ts_auto_ice) - & * (one - gamma_incomp(miu_ice(k), tx1)) +! miu_ice(k) = mui_hemp_l(lami(k)) + miu_ice(k) =max(min(0.008_r8*(lami(k)*0.01)**0.87_r8 + &, 10.0_r8), 0.1_r8) + tx1 = lami(k)*dcs + nprci(k) = (niic(i,k)/ts_auto_ice) + & * (one - gamma_incomp(miu_ice(k), tx1)) - prci(k) = (qiic(i,k)/ts_auto_ice) - & * (one - gamma_incomp(miu_ice(k)+three, tx1)) + prci(k) = (qiic(i,k)/ts_auto_ice) + & * (one - gamma_incomp(miu_ice(k)+three, tx1)) end if else @@ -2103,48 +2104,49 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! add autoconversion to flux from level above to get provisional snow mixing ratio ! and number concentration (qniic and nsic) ! Anning Cheng 9/16/2016 forecasting rain and snow, corresponding to MG2 - if(fprcp==1) then - qniic(i,k) = min(qsnw(i,k)/icldm(i,k), 5.e-3_r8) - nsic(i,k) = max(nsnw(i,k)/icldm(i,k), 0._r8) - else + if (fprcp == 1) then + tx1 = one / icldm(i,k) + qniic(i,k) = min(qsnw(i,k)*tx1, 10.e-3_r8) + nsic(i,k) = max(nsnw(i,k)*tx1, 0._r8) + else - dum = (asn(i,k)*cons25) - dum1 = (asn(i,k)*cons25) + dum = (asn(i,k)*cons25) + dum1 = (asn(i,k)*cons25) - if (k == 1) then - tx1 = icldm(i,k)*dz(i,k)/(cldmax(i,k)*dum) - qniic(i,k) = prci(k) * tx1 - nsic(i,k) = nprci(k) * tx1 - else - if (qniic(i,km) >= qsmall) then - dum = ums(km) - dum1 = uns(km) - end if + if (k == 1) then + tx1 = icldm(i,k)*dz(i,k)/(cldmax(i,k)*dum) + qniic(i,k) = prci(k) * tx1 + nsic(i,k) = nprci(k) * tx1 + else + if (qniic(i,km) >= qsmall) then + dum = ums(km) + dum1 = uns(km) + end if - tx1 = rho(i,km) * cldmax(i,km) - tx3 = rho(i,k) * cldmax(i,k) - qniic(i,k) = (tx1*ums(km)*qniic(i,km) + (rdz* - & ((prci(k)+prai(km)+psacws(km)+bergs(km))*icldm(i,k) - & +(prds(km)+pracs(km)+mnuccr(km))*cldmax(i,k)))) - & / (dum*tx3) + tx1 = rho(i,km) * cldmax(i,km) + tx3 = rho(i,k) * cldmax(i,k) + qniic(i,k) = (tx1*ums(km)*qniic(i,km) + (rdz* + & ((prci(k)+prai(km)+psacws(km)+bergs(km))*icldm(i,k) + & +(prds(km)+pracs(km)+mnuccr(km))*cldmax(i,k)))) + & / (dum*tx3) ! nsic(i,k) = (rho(i,k-1)*uns(k-1)*nsic(i,k-1)*cldmax(i,k-1)+ ! & (rho(i,k)*dz(i,k)*(nprci(k)*icldm(i,k)+(nsubs(k-1)+nsagg(k-1)+ ! &nnuccr(k-1))*cldmax(i,k)))) /(dum1*rho(i,k)*cldmax(i,k)) ! nsubs never given a value before - nsic(i,k) = (tx1*uns(km)*nsic(i,km) - & + (rdz*(nprci(k)*icldm(i,k)+(nsagg(km) - & + nnuccr(km))*cldmax(i,k)))) /(dum1*tx3) + nsic(i,k) = (tx1*uns(km)*nsic(i,km) + & + (rdz*(nprci(k)*icldm(i,k)+(nsagg(km) + & + nnuccr(km))*cldmax(i,k)))) /(dum1*tx3) - end if - end if !fprcp + end if + end if !fprcp ! if precip mix ratio is zero so should number concentration if (qniic(i,k) < qsmall) then - qniic(i,k) = zero - nsic(i,k) = zero + qniic(i,k) = zero + nsic(i,k) = zero end if if (qric(i,k) < qsmall) then @@ -2213,7 +2215,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, else if (lams(k) > lammaxs) then lams(k) = lammaxs n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) - nsic(i,k) = n0s(k)/lams(k) + nsic(i,k) = n0s(k)/lams(k) end if ! provisional snow number and mass weighted mean fallspeed (m/s) @@ -2265,7 +2267,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, viscosity = 1.8e-5_r8*(t(i,k)/298.0_r8)**0.85_r8 mfp = two*viscosity & / (p(i,k) *sqrt(8.0_r8*28.96e-3_r8/(pi* - & 8.314409_r8*t(i,k)))) + & 8.314409_r8*t(i,k)))) taux = t(i,k) - three taux = max(taux-273.15, -40.0) @@ -2481,7 +2483,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! from Beheng(1994) if (qric(i,k) >= qsmall) then - nragg(k) = -8._r8*nric(i,k)*qric(i,k)*rho(i,k) + nragg(k) = -8._r8*nric(i,k)*qric(i,k)*rho(i,k) else nragg(k) = zero end if @@ -2519,13 +2521,13 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! evaporation of rain ! only calculate if there is some precip fraction > cloud fraction - if (qcic(i,k)+qiic(i,k) < 1.e-6_r8 .or. + if (qcic(i,k)+qiic(i,k) < 1.e-7_r8 .or. & cldmax(i,k) > lcldm(i,k)) then ! set temporary cloud fraction to zero if cloud water + ice is very small ! this will ensure that evaporation/sublimation of precip occurs over ! entire grid cell, since min cloud fraction is specified otherwise - if (qcic(i,k)+qiic(i,k) < 1.e-6_r8) then + if (qcic(i,k)+qiic(i,k) < 1.e-7_r8) then dum = zero else dum = lcldm(i,k) @@ -2967,56 +2969,56 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! get final values for precipitation q and N, based on ! flux of precip from above, source/sink term, and terminal fallspeed ! see eq. 15-16 in MG2008 - if(fprcp==0) then + if (fprcp == 0) then ! rain - if (qric(i,k) >= qsmall) then - if (k == 1) then - qric(i,k) = qrtend(i,k)*dz(i,k)/(cldmax(i,k)*umr(k)) - nric(i,k) = nrtend(i,k)*dz(i,k)/(cldmax(i,k)*unr(k)) - else - tx1 = rho(i,km) * cldmax(i,km) - tx3 = rho(i,k) * cldmax(i,k) + if (qric(i,k) >= qsmall) then + if (k == 1) then + qric(i,k) = qrtend(i,k)*dz(i,k)/(cldmax(i,k)*umr(k)) + nric(i,k) = nrtend(i,k)*dz(i,k)/(cldmax(i,k)*unr(k)) + else + tx1 = rho(i,km) * cldmax(i,km) + tx3 = rho(i,k) * cldmax(i,k) - qric(i,k) = (tx1*umr(km)*qric(i,km) - & + rdz*qrtend(i,k)) / (umr(k)*tx3) + qric(i,k) = (tx1*umr(km)*qric(i,km) + & + rdz*qrtend(i,k)) / (umr(k)*tx3) - nric(i,k) = (tx1*unr(km)*nric(i,km) - & + rdz*nrtend(i,k)) / (unr(k)*tx3) + nric(i,k) = (tx1*unr(km)*nric(i,km) + & + rdz*nrtend(i,k)) / (unr(k)*tx3) + end if + else + qric(i,k) = zero + nric(i,k) = zero end if - else - qric(i,k) = zero - nric(i,k) = zero - end if ! snow - if (qniic(i,k) >= qsmall) then - if (k == 1) then - tx1 = dz(i,k)/cldmax(i,k) - qniic(i,k) = qnitend(i,k)*tx1/ums(k) - nsic(i,k) = nstend(i,k)*tx1/uns(k) - else - tx1 = rho(i,km) * cldmax(i,km) - tx3 = rho(i,k) * cldmax(i,k) + if (qniic(i,k) >= qsmall) then + if (k == 1) then + tx1 = dz(i,k)/cldmax(i,k) + qniic(i,k) = qnitend(i,k)*tx1/ums(k) + nsic(i,k) = nstend(i,k)*tx1/uns(k) + else + tx1 = rho(i,km) * cldmax(i,km) + tx3 = rho(i,k) * cldmax(i,k) - qniic(i,k) = (tx1*ums(km)*qniic(i,km) - & + rdz*qnitend(i,k)) / (ums(k)*tx3) - nsic(i,k) = (tx1*uns(km)*nsic(i,km) - & + rdz*nstend(i,k)) / (uns(k)*tx3) + qniic(i,k) = (tx1*ums(km)*qniic(i,km) + & + rdz*qnitend(i,k)) / (ums(k)*tx3) + nsic(i,k) = (tx1*uns(km)*nsic(i,km) + & + rdz*nstend(i,k)) / (uns(k)*tx3) + end if + else + qniic(i,k) = zero + nsic(i,k) = zero end if - else - qniic(i,k) = zero - nsic(i,k) = zero - end if ! calculate precipitation flux at surface ! divide by density of water to get units of m/s - tx1 = rdz/rhow - prect(i) = prect(i) + (qrtend(i,k)+ qnitend(i,k))*tx1 - preci(i) = preci(i) + qnitend(i,k)*tx1 + tx1 = rdz/rhow + prect(i) = prect(i) + (qrtend(i,k)+ qnitend(i,k))*tx1 + preci(i) = preci(i) + qnitend(i,k)*tx1 ! if (lprint) write(0,*)' prect=',prect(i),' preci=',preci(i) ! &,' qrtend=',qrtend(i,k),' qnitend=',qnitend(i,k),' rdz=',rdz @@ -3024,100 +3026,100 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, - rainrt(i,k) = qric(i,k)*rho(i,k)*umr(k) - & / rhow*3600._r8*1000._r8 + rainrt(i,k) = qric(i,k)*rho(i,k)*umr(k) + & / rhow*3600._r8*1000._r8 ! vertically-integrated precip source/sink terms (note: grid-averaged) - qrtot = max(qrtot + qrtend(i,k)*rdz, zero) - qstot = max(qstot + qnitend(i,k)*rdz, zero) - nrtot = max(nrtot + nrtend(i,k)*rdz, zero) - nstot = max(nstot + nstend(i,k)*rdz, zero) + qrtot = max(qrtot + qrtend(i,k)*rdz, zero) + qstot = max(qstot + qnitend(i,k)*rdz, zero) + nrtot = max(nrtot + nrtend(i,k)*rdz, zero) + nstot = max(nstot + nstend(i,k)*rdz, zero) !!!! done up to here - Moorthi ! calculate melting and freezing of precip ! melt snow at +2 C - taux = 1.0 + taux = 1.0 - if (.true.) then + if (.true.) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - tx1 = t(i,k) + tlat(i,k)*onebcp*deltat - if (tx1 > 275.15_r8) then + tx1 = t(i,k) + tlat(i,k)*onebcp*deltat + if (tx1 > 275.15_r8) then - if (qstot > zero) then + if (qstot > zero) then ! make sure melting snow doesn't reduce temperature below threshold - dum = xlfocp*qstot*rdzi - if (tx1-dum*deltat < 273.15_r8) then - tx2 = (tx1-275.15_r8) * dti - dum = min(one,max(zero,tx2/dum)) - else - dum = one - end if - - qric(i,k) = qric(i,k) + dum*qniic(i,k) - nric(i,k) = nric(i,k) + dum*nsic(i,k) - qniic(i,k) = (one-dum)*qniic(i,k) - nsic(i,k) = (one-dum)*nsic(i,k) + dum = xlfocp*qstot*rdzi + if (tx1-dum*deltat < 273.15_r8) then + tx2 = (tx1-275.15_r8) * dti + dum = min(one,max(zero,tx2/dum)) + else + dum = one + end if + + qric(i,k) = qric(i,k) + dum*qniic(i,k) + nric(i,k) = nric(i,k) + dum*nsic(i,k) + qniic(i,k) = (one-dum)*qniic(i,k) + nsic(i,k) = (one-dum)*nsic(i,k) ! heating tendency - tmp = -xlf*dum*qstot*rdzi - meltsdt(i,k) = meltsdt(i,k) + tmp + tmp = -xlf*dum*qstot*rdzi + meltsdt(i,k) = meltsdt(i,k) + tmp - tlat(i,k) = tlat(i,k) + tmp + tlat(i,k) = tlat(i,k) + tmp ! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 ! & .and.xlat<1.347.and.k==38) ! & write(*,*)"anning_m1",tmp - qrtot = qrtot + dum*qstot - nrtot = nrtot + dum*nstot - qstot = (one-dum)*qstot - nstot = (one-dum)*nstot - preci(i) = (one-dum)*preci(i) + qrtot = qrtot + dum*qstot + nrtot = nrtot + dum*nstot + qstot = (one-dum)*qstot + nstot = (one-dum)*nstot + preci(i) = (one-dum)*preci(i) + endif endif - endif - end if - tlataux(i, k) = tlat(i, k) + end if + tlataux(i, k) = tlat(i, k) ! freeze all rain at -5C for Arctic - if(.true.) then + if(.true.) then !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - tx1 = t(i,k) + tlat(i,k)*onebcp*deltat - if (tx1 < tmelt-five) then + tx1 = t(i,k) + tlat(i,k)*onebcp*deltat + if (tx1 < tmelt-five) then - if (qrtot > zero) then + if (qrtot > zero) then ! make sure freezing rain doesn't increase temperature above threshold - dum = xlfocp*qrtot*rdzi - if (tx1+dum*deltat > tmelt-five) then - tx2 = -(tx1 - (tmelt-five)) * dti - dum = min(one,max(zero,tx2/dum)) - else - dum = one - endif - qniic(i,k) = qniic(i,k) + dum*qric(i,k) - nsic(i,k) = nsic(i,k) + dum*nric(i,k) - qric(i,k) = (one-dum)*qric(i,k) - nric(i,k) = (one-dum)*nric(i,k) + dum = xlfocp*qrtot*rdzi + if (tx1+dum*deltat > tmelt-five) then + tx2 = -(tx1 - (tmelt-five)) * dti + dum = min(one,max(zero,tx2/dum)) + else + dum = one + endif + qniic(i,k) = qniic(i,k) + dum*qric(i,k) + nsic(i,k) = nsic(i,k) + dum*nric(i,k) + qric(i,k) = (one-dum)*qric(i,k) + nric(i,k) = (one-dum)*nric(i,k) ! heating tendency - tmp = xlf*dum*qrtot*rdzi - frzrdt(i,k) = frzrdt(i,k) + tmp + tmp = xlf*dum*qrtot*rdzi + frzrdt(i,k) = frzrdt(i,k) + tmp - tlat(i,k) = tlat(i,k) + tmp + tlat(i,k) = tlat(i,k) + tmp ! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 ! & .and.xlat<1.347.and.k==38) ! & write(*,*)"anning_m2",tmp - qstot = qstot + dum*qrtot - qrtot = (one-dum)*qrtot - nstot = nstot + dum*nrtot - nrtot = (one-dum)*nrtot - preci(i) = preci(i) + dum*(prect(i)-preci(i)) - end if + qstot = qstot + dum*qrtot + qrtot = (one-dum)*qrtot + nstot = nstot + dum*nrtot + nrtot = (one-dum)*nrtot + preci(i) = preci(i) + dum*(prect(i)-preci(i)) + end if + end if end if - end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -3127,117 +3129,117 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! if rain/snow mix ratio is zero so should number concentration - if (qniic(i,k) < qsmall) then - qniic(i,k) = zero - nsic(i,k) = zero - end if + if (qniic(i,k) < qsmall) then + qniic(i,k) = zero + nsic(i,k) = zero + end if - if (qric(i,k) < qsmall) then - qric(i,k) = zero - nric(i,k) = zero - end if + if (qric(i,k) < qsmall) then + qric(i,k) = zero + nric(i,k) = zero + end if ! make sure number concentration is a positive number to avoid ! taking root of negative - nric(i,k) = max(nric(i,k), zero) - nsic(i,k) = max(nsic(i,k), zero) + nric(i,k) = max(nric(i,k), zero) + nsic(i,k) = max(nsic(i,k), zero) !....................................................................... ! get size distribution parameters for fallspeed calculations !...................................................................... ! rain - if (qric(i,k) >= qsmall) then - lamr(k) = (pirhow*nric(i,k)/qric(i,k))**oneb3 - n0r(k) = nric(i,k)*lamr(k) + if (qric(i,k) >= qsmall) then + lamr(k) = (pirhow*nric(i,k)/qric(i,k))**oneb3 + n0r(k) = nric(i,k)*lamr(k) ! check for slope ! change lammax and lammin for rain and snow ! adjust vars - if (lamr(k) < lamminr) then - lamr(k) = lamminr - tx1 = lamr(k) * lamr(k) - n0r(k) = tx1*tx1*qric(i,k)/pirhow - nric(i,k) = n0r(k)/lamr(k) - else if (lamr(k) > lammaxr) then - lamr(k) = lammaxr - tx1 = lamr(k) * lamr(k) - n0r(k) = tx1*tx1*qric(i,k)/pirhow - nric(i,k) = n0r(k)/lamr(k) - end if + if (lamr(k) < lamminr) then + lamr(k) = lamminr + tx1 = lamr(k) * lamr(k) + n0r(k) = tx1*tx1*qric(i,k)/pirhow + nric(i,k) = n0r(k)/lamr(k) + else if (lamr(k) > lammaxr) then + lamr(k) = lammaxr + tx1 = lamr(k) * lamr(k) + n0r(k) = tx1*tx1*qric(i,k)/pirhow + nric(i,k) = n0r(k)/lamr(k) + end if ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) - tx1 = arn(i,k) / lamr(k)**br - tx2 = 9.1_r8*rhof(i,k) - unr(k) = min(tx1*cons4, tx2) - umr(k) = min(tx1*(cons5/6._r8),tx2) - - else - lamr(k) = zero - n0r(k) = zero - umr(k) = zero - unr(k) = zero - end if + tx1 = arn(i,k) / lamr(k)**br + tx2 = 9.1_r8*rhof(i,k) + unr(k) = min(tx1*cons4, tx2) + umr(k) = min(tx1*(cons5/6._r8),tx2) + + else + lamr(k) = zero + n0r(k) = zero + umr(k) = zero + unr(k) = zero + end if !calculate mean size of combined rain and snow - if (lamr(k) > zero) then - Artmp = n0r(k) * (0.5*pi) / (lamr(k)*lamr(k)*lamr(k)) - else - Artmp = zero - endif + if (lamr(k) > zero) then + Artmp = n0r(k) * (0.5*pi) / (lamr(k)*lamr(k)*lamr(k)) + else + Artmp = zero + endif - if (lamc(k) > zero) then - Actmp = cdist1(k) * pi * gamma(pgam(k)+three) - & / (four * lamc(k)*lamc(k)) - else - Actmp = zero - endif + if (lamc(k) > zero) then + Actmp = cdist1(k) * pi * gamma(pgam(k)+three) + & / (four * lamc(k)*lamc(k)) + else + Actmp = zero + endif - if (Actmp > zero .or.Artmp > zero) then - rercld(i,k) = rercld(i,k) + three*(qric(i,k)+qcic(i,k)) - & /(four*rhow*(Actmp+Artmp)) - arcld(i,k) = arcld(i,k) + one - endif + if (Actmp > zero .or.Artmp > zero) then + rercld(i,k) = rercld(i,k)+three*(qric(i,k)+qcic(i,k)) + & /(four*rhow*(Actmp+Artmp)) + arcld(i,k) = arcld(i,k) + one + endif !...................................................................... ! snow - if (qniic(i,k) >= qsmall) then - lams(k) = (cons6*cs*nsic(i,k) / qniic(i,k))**(one/ds) - n0s(k) = nsic(i,k)*lams(k) + if (qniic(i,k) >= qsmall) then + lams(k) = (cons6*cs*nsic(i,k) / qniic(i,k))**(one/ds) + n0s(k) = nsic(i,k)*lams(k) ! check for slope ! adjust vars - if (lams(k) < lammins) then - lams(k) = lammins - n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) - nsic(i,k) = n0s(k)/lams(k) + if (lams(k) < lammins) then + lams(k) = lammins + n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) - else if (lams(k) > lammaxs) then - lams(k) = lammaxs - n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) - nsic(i,k) = n0s(k)/lams(k) - end if + else if (lams(k) > lammaxs) then + lams(k) = lammaxs + n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + end if ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) - tx1 = asn(i,k) / lams(k)**bs - tx2 = 1.2_r8*rhof(i,k) - ums(k) = min(tx1*(cons8/6._r8), tx2) - uns(k) = min(tx1*cons7, tx2) + tx1 = asn(i,k) / lams(k)**bs + tx2 = 1.2_r8*rhof(i,k) + ums(k) = min(tx1*(cons8/6._r8), tx2) + uns(k) = min(tx1*cons7, tx2) - else - lams(k) = zero - n0s(k) = zero - ums(k) = zero - uns(k) = zero - end if + else + lams(k) = zero + n0s(k) = zero + ums(k) = zero + uns(k) = zero + end if !c........................................................................ ! sum over sub-step for average process rates @@ -3245,47 +3247,47 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! convert rain/snow q and N for output to history, note, ! output is for gridbox average - qrout(i,k) = qrout(i,k) + qric(i,k)*cldmax(i,k) - qsout(i,k) = qsout(i,k) + qniic(i,k)*cldmax(i,k) - tx1 = rho(i,k)*cldmax(i,k) - nrout(i,k) = nrout(i,k) + nric(i,k)*tx1 - nsout(i,k) = nsout(i,k) + nsic(i,k)*tx1 + qrout(i,k) = qrout(i,k) + qric(i,k)*cldmax(i,k) + qsout(i,k) = qsout(i,k) + qniic(i,k)*cldmax(i,k) + tx1 = rho(i,k)*cldmax(i,k) + nrout(i,k) = nrout(i,k) + nric(i,k)*tx1 + nsout(i,k) = nsout(i,k) + nsic(i,k)*tx1 - end if !fprcp Anning Cheng 9/16/2016 - tlat1(i,k) = tlat1(i,k) + tlat(i,k) - tlat1_aux(i,k) = tlat1_aux(i,k) + tlataux(i,k) + end if !fprcp Anning Cheng 9/16/2016 + tlat1(i,k) = tlat1(i,k) + tlat(i,k) + tlat1_aux(i,k) = tlat1_aux(i,k) + tlataux(i,k) - qvlat1(i,k) = qvlat1(i,k) + qvlat(i,k) - qctend1(i,k) = qctend1(i,k) + qctend(i,k) - qitend1(i,k) = qitend1(i,k) + qitend(i,k) - nctend1(i,k) = nctend1(i,k) + nctend(i,k) - nitend1(i,k) = nitend1(i,k) + nitend(i,k) + qvlat1(i,k) = qvlat1(i,k) + qvlat(i,k) + qctend1(i,k) = qctend1(i,k) + qctend(i,k) + qitend1(i,k) = qitend1(i,k) + qitend(i,k) + nctend1(i,k) = nctend1(i,k) + nctend(i,k) + nitend1(i,k) = nitend1(i,k) + nitend(i,k) - t(i,k) = t(i,k) + tlat(i,k)*deltat/cpp - q(i,k) = q(i,k) + qvlat(i,k)*deltat - qc(i,k) = qc(i,k) + qctend(i,k)*deltat - qi(i,k) = qi(i,k) + qitend(i,k)*deltat - nc(i,k) = nc(i,k) + nctend(i,k)*deltat - ni(i,k) = ni(i,k) + nitend(i,k)*deltat + t(i,k) = t(i,k) + tlat(i,k) * deltat/cpp + q(i,k) = q(i,k) + qvlat(i,k) * deltat + qc(i,k) = qc(i,k) + qctend(i,k) * deltat + qi(i,k) = qi(i,k) + qitend(i,k) * deltat + nc(i,k) = nc(i,k) + nctend(i,k) * deltat + ni(i,k) = ni(i,k) + nitend(i,k) * deltat - rainrt1(i,k) = rainrt1(i,k) + rainrt(i,k) + rainrt1(i,k) = rainrt1(i,k) + rainrt(i,k) !divide rain radius over substeps for average - if (arcld(i,k) > zero) then - rercld(i,k) = rercld(i,k) / arcld(i,k) - end if + if (arcld(i,k) > zero) then + rercld(i,k) = rercld(i,k) / arcld(i,k) + end if !calculate precip fluxes and adding them to summing sub-stepping variables - rflx(i,1) = zero - sflx(i,1) = zero + rflx(i,1) = zero + sflx(i,1) = zero - rflx(i,k+1) = qrout(i,k)*rho(i,k)*umr(k) - sflx(i,k+1) = qsout(i,k)*rho(i,k)*ums(k) + rflx(i,k+1) = qrout(i,k)*rho(i,k)*umr(k) + sflx(i,k+1) = qsout(i,k)*rho(i,k)*ums(k) - rflx1(i,k+1) = rflx1(i,k+1) + rflx(i,k+1) - sflx1(i,k+1) = sflx1(i,k+1) + sflx(i,k+1) + rflx1(i,k+1) = rflx1(i,k+1) + rflx(i,k+1) + sflx1(i,k+1) = sflx1(i,k+1) + sflx(i,k+1) !c........................................................................ @@ -3460,7 +3462,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, dumni(i,k) = min(dumni(i,k),dumi(i,k)*1.e20_r8) lami(k) = (cons1*ci* dumni(i,k)/dumi(i,k))**oneodi -! miu_ice(k)=mui_hemp_l(lami(k)) Anning changed here +! miu_ice(k) = mui_hemp_l(lami(k)) Anning changed here miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, & 10.0_r8), 0.1_r8) tx1 = one + miu_ice(k) @@ -3703,112 +3705,116 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ! initialize nstep for sedimentation sub-steps ! reuse dumc, dumi, dumnc, and dumni - if(fprcp==1) then + if (fprcp == 1) then nstep = 1 do k=1,pver -! tx1 = one / lcldm(i,k) -! tx2 = one / icldm(i,k) - dumc(i,k) = max((qrn(i,k)+qrtend(i,k)*deltat),zero) - dumi(i,k) = max((qsnw(i,k)+qnitend(i,k)*deltat),zero) - dumnc(i,k) = max((nrn(i,k)+nrtend(i,k)*deltat),zero) - dumni(i,k) = max((nsnw(i,k)+nstend(i,k)*deltat),zero) +! tx1 = deltat / lcldm(i,k) +! tx2 = deltat / icldm(i,k) +! dumc(i,k) = max(qrn(i,k)+qrtend(i,k)*tx1, zero) +! dumi(i,k) = max(qsnw(i,k)+qnitend(i,k)*tx2,zero) +! dumnc(i,k) = max(nrn(i,k)+nrtend(i,k)*tx1, zero) +! dumni(i,k) = max(nsnw(i,k)+nstend(i,k)*tx2, zero) + + dumc(i,k) = max(qrn(i,k)+qrtend(i,k)*deltat, zero) + dumi(i,k) = max(qsnw(i,k)+qnitend(i,k)*deltat,zero) + dumnc(i,k) = max(nrn(i,k)+nrtend(i,k)*deltat, zero) + dumni(i,k) = max(nsnw(i,k)+nstend(i,k)*deltat, zero) ! if rain/snow mix ratio is zero so should number concentration - if (dumi(i,k) < qsmall) then - dumi(i,k) = zero - dumni(i,k) = zero - endif + if (dumi(i,k) < qsmall) then + dumi(i,k) = zero + dumni(i,k) = zero + endif - if (dumc(i,k) < qsmall) then - dumc(i,k) = zero - dumnc(i,k) = zero - endif + if (dumc(i,k) < qsmall) then + dumc(i,k) = zero + dumnc(i,k) = zero + endif ! make sure number concentration is a positive number to avoid ! taking root of negative - dumnc(i,k) = max(dumnc(i,k),zero) - dumni(i,k) = max(dumni(i,k),zero) + dumnc(i,k) = max(dumnc(i,k),zero) + dumni(i,k) = max(dumni(i,k),zero) !....................................................................... ! get size distribution parameters for fallspeed calculations !...................................................................... ! rain - if (dumc(i,k) >= qsmall) then - lamr(k) = (pi*rhow*dumnc(i,k)/dumc(i,k))**oneb3 - n0r(k) = dumnc(i,k)*lamr(k) + if (dumc(i,k) >= qsmall) then + lamr(k) = (pi*rhow*dumnc(i,k)/dumc(i,k))**oneb3 + n0r(k) = dumnc(i,k)*lamr(k) ! check for slope ! change lammax and lammin for rain and snow ! adjust vars - if (lamr(k) < lamminr) then + if (lamr(k) < lamminr) then - lamr(k) = lamminr + lamr(k) = lamminr - n0r(k) = lamr(k)**4*dumc(i,k)/(pi*rhow) - dumnc(i,k) = n0r(k)/lamr(k) - else if (lamr(k) > lammaxr) then - lamr(k) = lammaxr - n0r(k) = lamr(k)**4*dumc(i,k)/(pi*rhow) - dumnc(i,k) = n0r(k)/lamr(k) - end if + n0r(k) = lamr(k)**4*dumc(i,k)/(pi*rhow) + dumnc(i,k) = n0r(k)/lamr(k) + else if (lamr(k) > lammaxr) then + lamr(k) = lammaxr + n0r(k) = lamr(k)**4*dumc(i,k)/(pi*rhow) + dumnc(i,k) = n0r(k)/lamr(k) + end if ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) - tx1 = arn(i,k) / lamr(k)**br - tx2 = 9.1_r8*rhof(i,k) - unr(k) = min(tx1*cons4, tx2) - umr(k) = min(tx1*(cons5/6._r8),tx2) + tx1 = arn(i,k) / lamr(k)**br + tx2 = 9.1_r8*rhof(i,k) + unr(k) = min(tx1*cons4, tx2) + umr(k) = min(tx1*(cons5/6._r8),tx2) - else - lamr(k) = zero - n0r(k) = zero - umr(k) = zero - unr(k) = zero - end if + else + lamr(k) = zero + n0r(k) = zero + umr(k) = zero + unr(k) = zero + end if !...................................................................... ! snow - if (dumi(i,k) >= qsmall) then - lams(k) = (cons6*cs*dumni(i,k)/ dumi(i,k))**(one/ds) - n0s(k) = dumni(i,k)*lams(k) + if (dumi(i,k) >= qsmall) then + lams(k) = (cons6*cs*dumni(i,k)/ dumi(i,k))**(one/ds) + n0s(k) = dumni(i,k)*lams(k) ! check for slope ! adjust vars - if (lams(k) < lammins) then - lams(k) = lammins - n0s(k) = lams(k)**(ds+one)*dumi(i,k)/(cs*cons6) - dumni(i,k) = n0s(k)/lams(k) - - else if (lams(k) > lammaxs) then - lams(k) = lammaxs - n0s(k) = lams(k)**(ds+one)*dumi(i,k)/(cs*cons6) - dumni(i,k) = n0s(k)/lams(k) - end if + if (lams(k) < lammins) then + lams(k) = lammins + n0s(k) = lams(k)**(ds+one)*dumi(i,k)/(cs*cons6) + dumni(i,k) = n0s(k)/lams(k) + else if (lams(k) > lammaxs) then + lams(k) = lammaxs + n0s(k) = lams(k)**(ds+one)*dumi(i,k)/(cs*cons6) + dumni(i,k) = n0s(k)/lams(k) + end if ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) - tx1 = asn(i,k) / lams(k)**bs - tx2 = 1.2_r8*rhof(i,k) - ums(k) = min(tx1*(cons8/6._r8), tx2) - uns(k) = min(tx1*cons7, tx2) + tx1 = asn(i,k) / lams(k)**bs + tx2 = 1.2_r8*rhof(i,k) + ums(k) = min(tx1*(cons8/6._r8), tx2) + uns(k) = min(tx1*cons7, tx2) - else - lams(k) = zero - n0s(k) = zero - ums(k) = zero - uns(k) = zero - end if + else + lams(k) = zero + n0s(k) = zero + ums(k) = zero + uns(k) = zero + end if - tx1 = g*rho(i,k) + tx1 = g*rho(i,k) fi(k) = tx1*ums(k) fni(k) = tx1*uns(k) fc(k) = tx1*umr(k) @@ -3817,7 +3823,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! calculate number of split time steps to ensure courant stability criteria ! for sedimentation calculations - rgvm = max(fi(k),fc(k),fni(k),fnc(k)) + rgvm = max(fi(k),fc(k),fni(k),fnc(k)) nstep = max(int(rgvm*deltat/pdel(i,k)+one),nstep) ! redefine dummy variables - sedimentation is calculated over grid-scale @@ -3838,10 +3844,10 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, do n = 1,nstep do k = 1,pver - falouti(k) = max(fi(k) * qsnw(i,k),zero) - faloutni(k) = max(fni(k) * nsnw(i,k),zero) - faloutc(k) = max(fc(k) * qrn(i,k),zero) - faloutnc(k) = max(fnc(k) * nrn(i,k),zero) + falouti(k) = max(fi(k) * qsnw(i,k), zero) + faloutni(k) = max(fni(k) * nsnw(i,k), zero) + faloutc(k) = max(fc(k) * qrn(i,k), zero) + faloutnc(k) = max(fnc(k) * nrn(i,k), zero) end do ! top of model @@ -3862,10 +3868,10 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! sedimentation tendencies for output - qsnw(i,k) = qsnw(i,k) - faltndi *tx3 - nsnw(i,k) = nsnw(i,k) - faltndni*tx3 - qrn(i,k) = qrn(i,k) - faltndc *tx3 - nrn(i,k) = nrn(i,k) - faltndnc*tx3 + qsnw(i,k) = qsnw(i,k) - faltndi * tx3 + nsnw(i,k) = nsnw(i,k) - faltndni * tx3 + qrn(i,k) = qrn(i,k) - faltndc * tx3 + nrn(i,k) = nrn(i,k) - faltndnc * tx3 do k = 2,pver @@ -3874,16 +3880,16 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! dum = min(one, lcldm(i,k)/lcldm(i,k-1)) ! dum1 = min(one, icldm(i,k)/icldm(i,k-1)) - faltndc = (faloutc(k)- faloutc(k-1)) * tx1 - faltndnc = (faloutnc(k)- faloutnc(k-1)) * tx1 + faltndc = (faloutc(k) - faloutc(k-1)) * tx1 + faltndnc = (faloutnc(k) - faloutnc(k-1)) * tx1 - faltndi = (falouti(k) - falouti(k-1)) * tx1 + faltndi = (falouti(k) - falouti(k-1)) * tx1 faltndni = (faloutni(k) - faloutni(k-1)) * tx1 - qsnw(i,k) = qsnw(i,k) - faltndi * tx3 + qsnw(i,k) = qsnw(i,k) - faltndi * tx3 nsnw(i,k) = nsnw(i,k) - faltndni * tx3 qrn(i,k) = qrn(i,k) - faltndc * tx3 - nrn(i,k) = nrn(i,k) - faltndnc * tx3 + nrn(i,k) = nrn(i,k) - faltndnc * tx3 end do @@ -3901,7 +3907,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! DONE UP TO HERE do k=1,pver - if (fprcp==1) then + if (fprcp == 1) then ! calculate melting and freezing of precip ! melt snow at +2 C @@ -3949,7 +3955,7 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, dum = one end if - qsnw(i,k) = qsnw(i,k) + dum*qrn(i,k) + qsnw(i,k) = qsnw(i,k) + dum*qrn(i,k) nsnw(i,k) = nsnw(i,k) + dum*nrn(i,k) qrn(i,k) = (one-dum)*qrn(i,k) nrn(i,k) = (one-dum)*nrn(i,k) @@ -3978,6 +3984,10 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, nrn(i,k) = max(nrn(i,k),zero) nsnw(i,k) = max(nsnw(i,k),zero) + qrout(i,k) = qrout(i,k) + qrn(i,k) + qsout(i,k) = qsout(i,k) + qsnw(i,k) + nrout(i,k) = nrout(i,k) + nrn(i,k)*rho(i,k) + nsout(i,k) = nsout(i,k) + nsnw(i,k)*rho(i,k) !....................................................................... end if !fprcp ==1 @@ -4277,11 +4287,11 @@ subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, ! convert dt from sub-step back to full time step - deltat = deltat*real(iter) - dti = one / deltat + deltat = deltat*real(iter) + dti = one / deltat - do k=1,pver + do k=1,pver ! if updated q (after microphysics) is zero, then ensure updated n is also zero if (qc(i,k)+qctend(i,k)*deltat < qsmall) diff --git a/gfsphysics/physics/cs_conv.f90 b/gfsphysics/physics/cs_conv.f90 index f3030f0ad..85a07e5da 100644 --- a/gfsphysics/physics/cs_conv.f90 +++ b/gfsphysics/physics/cs_conv.f90 @@ -19,6 +19,18 @@ module cs_conv ! Oct 2016 : S. Moorthi - added sigma affects on tracers and CUMFLX and CUMDET ! made many cosmetic changes ! Nov 2016 : S. Moorthi - further optimization and cleanup and several bug fixes +! April 2017 : S. moorthi - many changes including removing elam and making gcym +! a function of cloud type. This makes it possible for +! AW affect propagate to other routines such as CUMUPR +! Apr 12, 2017 : S. Moorthi Added flx_form logical and relevant code to compute AW +! without flux form when false. +! May 17, 2017 : S. Moorthi - Added routine CUMSBW for just momentum change +! in advective form +! Sep 08, 2017 : D. Dazlich - tracers in flux form for AW +! Nov -- 2017 : S. Moorthi - fix some bugs and fix fluxform for tracers +! Nov 22 2017 : S. Moorthi - add kcnv array to identify points where deep convection +! operates - 0 - no convection 1 - with convection +! Jan 30 2018 : S, Moorthi - fixed sigmad dimension error in CUMDWN and an error when adjustp=.true. ! ! Arakawa-Wu implemtation: for background, consult An Introduction to the ! General Circulation of the Atmosphere, Randall, chapter six. @@ -44,61 +56,55 @@ module cs_conv & epsv => con_eps, epsvm1 => con_epsm1, & & epsvt => con_fvirt, & & el => con_hvap, emelt => con_hfus, t0c => con_t0c - use funcphys, only : fpvs ! this is saturation vapor pressure in funcphys.f + use funcphys, only : fpvs ! this is saturation vapor pressure in funcphys.f implicit none private ! Make default type private to the module - real(r8), parameter :: zero=0.0d0, one=1.0d0, half=0.5d0 + real(r8), parameter :: zero=0.0d0, one=1.0d0, half=0.5d0 real(r8), parameter :: cpoel=cp/el, cpoesub=cp/(el+emelt), esubocp=1.0/cpoesub, & elocp=el/cp, oneocp=one/cp, gocp=grav/cp, gravi=one/grav,& - emeltocp=emelt/cp, cpoemelt=cp/emelt - real(r8), parameter :: fact1=(cvap-cliq)/rvap, fact2=el/rvap-fact1*t0c + emeltocp=emelt/cp, cpoemelt=cp/emelt, epsln=1.e-10_r8 + + real(r8), parameter :: fact1=(cvap-cliq)/rvap, fact2=el/rvap-fact1*t0c ! to calculate d(qs)/dT + logical, parameter :: adjustp=.true. +! logical, parameter :: adjustp=.false. ! Tuning parameters set from namelist ! ! real(r8), save, public :: CLMD = 0.6, & ! entrainment efficiency - real(r8), save, public :: CLMD = 0.7, & ! entrainment efficiency - PA=0.15, & ! factor for buoyancy to affect updraft velocity - CPRES = 0.55, & ! pressure factor for momentum transport - ALP0 = 8.0e7 ! alpha parameter in prognostic closure - -!DD next two parameters control partitioning of water between detrainment + real(r8), parameter, public :: CLMD = 0.7, & ! entrainment efficiency + PA=0.15, & ! factor for buoyancy to affect updraft velocity + CPRES = 0.55, & ! pressure factor for momentum transport + ALP0 = 8.0e7, & ! alpha parameter in prognostic closure + CLMP = (one-CLMD)*(PA+PA), & + spblcrit=0.05, & ! minimum cloudbase height in p/ps +! spblcrit=0.03, & ! minimum cloudbase height in p/ps +! spblcrit=0.035,& ! minimum cloudbase height in p/ps +! spblcrit=0.025,& ! minimum cloudbase height in p/ps + cincrit=-150.0 +! cincrit=-120.0 +! cincrit=-100.0 + +!DD precz0 and preczh control partitioning of water between detrainment !DD and precipitation. Decrease for more precip -!M REAL(r8), public, save :: PRECZ0 = 1.5e3_r8 ! default = 1.5e3 -!M REAL(r8), public, save :: PRECZ0 = 1.5e3_r8 ! default = 1.5e3 -! REAL(r8), public, save :: PRECZ0 = 1.5e3_r8 ! default = 1.5e3 -! REAL(r8), public, save :: PRECZH = 4.e3_r8 ! default = 4.e3 - -! REAL(r8), public, save :: PRECZ0 = 1.0e3_r8 ! default = 1.5e3 -! REAL(r8), public, save :: PRECZH = 3.e3_r8 ! default = 4.e3 - -! REAL(r8), public, save :: PRECZ0 = 0.5e3_r8 ! default = 1.5e3 -! REAL(r8), public, save :: PRECZH = 2.e3_r8 ! default = 4.e3 real(r8), public :: precz0, preczh ! ! Private data ! - real(r8), parameter :: unset_r8 = -999._r8 ! missing value + real(r8), parameter :: unset_r8 = -999._r8 ! missing value ! integer :: iulog ! unit to write debugging and diagnostic output - !DD Note - see if I can find corresponding variable in a GFS module + !DD Note - see if I can find corresponding variable in a GFS module ! ! Shared variables ! integer, parameter :: ITI = 2, ITL = 3 ! index of ice and liquid water -! logical :: outputflag(100) - -!DD integer, save :: ICHNK ! chunk identifier - -! [INTERNAL PARM] !DD moved to module scope and allocatable - -! logical, save, dimension(50) :: OTSPT1, OTSPT2 integer, save, dimension(50) :: IMFXR ! 0: mass fixer is not applied ! tracers which may become negative ! values e.g. subgrid-PDFs @@ -110,84 +116,25 @@ module cs_conv ! never change through cumulus scheme ! e.g. CO2 -! LOGICAL, SAVE, ALLOCATABLE, DIMENSION(:) :: OTSPT1 ! tracer transport by updraft, downdraft on/off - ! should not include subgrid PDF and turbulence -! LOGICAL, SAVE, ALLOCATABLE, DIMENSION(:) :: OTSPT2 ! tracer transport by subsidence on/off - ! should include subgrid PDF and turbulence -! INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: IMFXR -! REAL(r8), SAVE, ALLOCATABLE, DIMENSION(:) :: FSCAV !DD split declaration and initialization -! REAL(r8), SAVE, ALLOCATABLE, DIMENSION(:) :: FSWTR !DD split declaration and initialization -! -! -! - ! PUBLIC: interfaces ! public cs_convr ! CS scheme main driver contains -!--------------------------------------------------------------------------------- -! use GFS functions - function FQSAT( T, P ) ! calculate saturation water vapor - - implicit none - - real(r8) :: FQSAT ! saturation water vapor - real(r8), intent(in) :: T ! temperature [K] - real(r8), intent(in) :: P ! pressure [Pa] - -! real(r8), parameter :: one_m10=1.0d-10, & -! ES0 = 611._r8, & ! saturation e at 0 deg C (Pa) -! TQICE = 273.15_r8, & ! T threshold for ice QSAT -! TMELT = 273.15_r8 ! melting point of water - -!DD FQSAT = EPSV * ES0 / P & -!DD * EXP( (EL+EMELT/2._r8*(1._r8-SIGN(1._r8,T-TQICE))) & -!DD /RVAP *( 1._r8/TMELT - 1._r8/T ) ) - - FQSAT = min(p,fpvs(T)) !DD this is saturation vapor pressure - -! FQSAT = EPSV * FQSAT / P !DD This is saturation mixing ratio -! FQSAT = EPSV * FQSAT / (max(p+epsvm1*fqsat,ONE_M10)) !DD&Moo This is saturation specific humidity - FQSAT = min(EPSV*FQSAT/max(p+epsvm1*fqsat,1.0e-10), 1.0) !DD&Moo This is saturation specific humidity - - end function FQSAT -!--------------------------------------------------------------------------------- -! following GFS - function FDQSAT( T, QS ) ! calculate d(qs)/dT - - implicit none - - real(r8) :: FDQSAT ! d(QSAT)/d(T) - real(r8), intent(in) :: T ! temperature [K] - real(r8), intent(in) :: QS ! saturation water vapor [kg/kg] - real(r8) :: wrk - - real(r8), parameter :: fact1=(cvap-cliq)/rvap,fact2=el/rvap-fact1*t0c - -!DD FDQSAT = (EL+EMELT/2._r8*(1._r8-SIGN(1._r8,T-TMELT))) & -!DD * QS / ( RVAP * T*T ) - - wrk = 1.0 / t - FDQSAT = qs * wrk * (fact1 + fact2*wrk) -! FDQSAT = qs * (fact1 / t + fact2 / (t**2)) - - - end function FDQSAT !--------------------------------------------------------------------------------- subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dimensions - otspt , lat ,kdt , & + otspt , lat , kdt , & t , q , prec , clw , & zm , zi , pap , paph , & delta , delti , ud_mf , dd_mf , dt_mf, & u , v , fscav , fswtr, & cbmfx , mype , wcbmaxm , precz0in, preczhin, & - sigmai , sigma , vverti , do_aw, do_awdd, & - lprnt, ipr, & + sigma , do_aw , do_awdd, flx_form, & + lprnt , ipr, kcnv, & ! for coupling to Morrison microphysics QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & - CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,ncld) + CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys) !--------------------------------------------------------------------------------- ! Purpose: @@ -202,9 +149,11 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime ! ! input arguments ! - INTEGER, INTENT(IN) :: IM,IJSDIM, KMAX, NTR, mype, nctp, ncld, kdt,lat !! DD, for GFS, pass in - logical, intent(in) :: otspt(ntr,2) - + INTEGER, INTENT(IN) :: IM,IJSDIM, KMAX, NTR, mype, nctp, mp_phys, kdt,lat !! DD, for GFS, pass in + logical, intent(in) :: otspt(ntr,2) ! otspt(:,1) - on/off switch for tracer transport by updraft and + ! downdraft. should not include subgrid PDF and turbulence + ! otspt(:,2) - on/off switch for tracer transport by subsidence + ! should include subgrid PDF and turbulence real(r8), intent(inout) :: t(IM,KMAX) ! temperature at mid-layer (K) real(r8), intent(inout) :: q(IM,KMAX) ! water vapor array including moisture (kg/kg) @@ -221,7 +170,7 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime real(r8), intent(in) :: DELTA ! physics time step real(r8), intent(in) :: DELTI ! dynamics time step (model time increment in seconds) - logical, intent(in) :: do_aw, do_awdd + logical, intent(in) :: do_aw, do_awdd, flx_form ! ! modified arguments ! @@ -236,17 +185,20 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime real(r8), intent(out), dimension(ijsdim,kmax) :: qlcn, qicn, w_upi,cnv_mfd, cnv_prc3,& cnv_dqldt, clcn, cnv_fice, & cnv_ndrop, cnv_nice, cf_upi + integer, intent(inout) :: kcnv(im) ! zero if no deep convection and 1 otherwise !DDsigma - output added for AW sigma diagnostics ! interface sigma and vertical velocity by cloud type (1=sfc) - real(r8), intent(out), dimension(IM,KMAX,nctp) :: sigmai, vverti +! real(r8), intent(out), dimension(IM,KMAX,nctp) :: sigmai, vverti real(r8), intent(out), dimension(IM,KMAX) :: sigma ! sigma sigma totaled over cloud type - on interfaces (1=sfc) ! sigma terms in eq 91 and 92 - real(r8), dimension(IM,KMAX) :: sfluxterm, qvfluxterm, condterm +! real(r8), dimension(IM,KMAX) :: sfluxterm, qvfluxterm, condterm !DDsigma ! ! output arguments of CS_CUMLUS ! + real(r8), dimension(IM,KMAX,nctp) :: vverti + real(r8) GTT(IJSDIM,KMAX) ! temperature tendency [K/s] real(r8) GTQ(IJSDIM,KMAX,NTR) ! tracer tendency [kg/kg/s] real(r8) GTU(IJSDIM,KMAX) ! zonal velocity tendency [m/s2] @@ -254,27 +206,10 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime real(r8) GTPRP(IJSDIM,KMAX) ! precipitation (including snowfall) flux at interfaces [kg/m2/s] real(r8) GSNWP(IJSDIM,KMAX) ! snowfall flux at interfaces [kg/m2/s] -! real(r8) CMDET(IJSDIM,KMAX) ! detrainment mass flux [kg/m2/s] -! real(r8) GTLDET(IJSDIM,KMAX) ! cloud liquid tendency by detrainment [1/s] -! real(r8) GTIDET(IJSDIM,KMAX) ! cloud ice tendency by detrainment [1/s] - -!DD removed as output arguments -! real(r8) :: jctop(IJSDIM) ! o row of top-of-deep-convection indices passed out. -! real(r8) :: jcbot(IJSDIM) ! o row of base of cloud indices passed out. - -! The following commented by moorthi to save memory for now - oct 2016 -! real(r8) :: dlf(IJSDIM,KMAX) ! scattered version of the detraining cld h2o tend (kg/kg/s) -! real(r8) :: pflx(IJSDIM,KMAX+1) ! scattered precip flux at each level -! real(r8) :: cme(IJSDIM,KMAX) ! condensation - evaporation -! real(r8) :: rliq(IJSDIM) ! reserved liquid (not yet in cldliq) for energy integrals (m/s) -! real(r8) :: flxprec(IJSDIM,KMAX+1) ! precipitation flux (including snowfall) at interfaces (kg/m2/s) -! real(r8) :: flxsnow(IJSDIM,KMAX+1) ! snowfall flux at interfaces (kg/m2/s) - integer KT(IJSDIM,nctp) ! cloud top index for each cloud type real(r8) :: cape(IJSDIM) ! convective available potential energy (J/kg) real(r8) :: snow(IJSDIM) ! snowfall at surface (kg/m2/s) - ! ! input arguments of CS_CUMLUS ! @@ -287,7 +222,8 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime real(r8) GDPM(IJSDIM,KMAX+1) ! pressure at boundaries of layers [Pa] real(r8) GDZ(IJSDIM,KMAX) ! altitude [m] real(r8) GDZM(IJSDIM,KMAX+1) ! altitude at boundaries of layers [m] - real(r8) delp(IJSDIM,KMAX) ! altitude at boundaries of layers [m] + real(r8) delp(IJSDIM,KMAX) ! pressure difference between layers [Pa] + real(r8) delpi(IJSDIM,KMAX) ! grav/delp ! ! local variables ! @@ -296,7 +232,6 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime integer KTMAX(IJSDIM) ! max of KT real(r8) :: ftintm, wrk, wrk1, tem integer i, k, n, ISTS, IENS, kp1, ipr -! integer i, k, n, iunit !DD borrowed from RAS to go form total condensate to ice/water separately ! parameter (tf=130.16, tcr=160.16, tcrf=1.0/(tcr-tf),tcl=2.0) @@ -305,13 +240,13 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime logical, save :: first=.true. logical lprnt +! lprnt = kdt == 1 .and. mype == 38 +! ipr = 43 precz0 = precz0in preczh = preczhin ! -! lprnt = lat == 15 .and. kdt <= 2 if (first) then -! write(1000+mype,*)' precz0=',precz0,' preczh=',preczh,' nctp=',nctp do i=1,ntr IMFXR(i) = 0 enddo @@ -340,6 +275,7 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime GDP(i,k) = pap(i,k) GDQ(i,k,1) = q(i,k) delp(i,k) = paph(i,k) - paph(i,k+1) + delpi(i,k) = grav / delp(i,k) enddo enddo @@ -363,48 +299,21 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime gdq(i,k,1) = gdq(i,k,1) + tem + wrk enddo enddo +! if (lprnt) write(0,*)'in cs clw1b=',clw(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)'in cs clw2b=',clw(ipr,:,2),' kdt=',kdt do n=2,NTR do k=1,KMAX do i=1,IJSDIM - GDQ(i,k,n) = clw(i,k,n-1) !DDsigmadiag + GDQ(i,k,n) = clw(i,k,n-1) enddo enddo enddo -!*************************************************************************************** -! iunit = 400 + mype -! write(iunit,*)kmax,'kmax',delta,'delta',im,'im',ijsdim,'ijsdim',iens,'iens',ists,'ists' !DDdebug -! write(iunit,*),i !DDdebug -! do i = 1, 1 !DDdebug -! write(iunit,*)'gdt' !DDdebug -! write(iunit,*)gdt(I,:) !DDdebug -! write(iunit,*)'gdu' !DDdebug -! write(iunit,*)gdu(I,:) !DDdebug -! write(iunit,*)'gdv' !DDdebug -! write(iunit,*)gdv(I,:) !DDdebug -! do k = 1,ntr !DDdebug -! write(iunit,*)'gdq',k !DDdebug -! write(iunit,*)gdq(I,:,k) !DDdebug -! enddo !DDdebug -! write(iunit,*)'gdz' !DDdebug -! write(iunit,*)gdz(I,:) !DDdebug -! write(iunit,*)'gdp' !DDdebug -! write(iunit,*)gdp(I,:) !DDdebug -! write(iunit,*)'gdzm' !DDdebug -! write(iunit,*)gdzm(I,:) !DDdebug -! write(iunit,*)'gdpm' !DDdebug -! write(iunit,*)gdpm(I,:) !DDdebug -! write(iunit,*)'cbmfx' !DDdebug -! write(iunit,*)cbmfx(I,:) !DDdebug -! enddo !DDdebug +! !*************************************************************************************** ! ! calculate temperature at interfaces ! -! call TINTP( IJSDIM, KMAX , & !DD dimensions -! GDTM, & ! output -! GDT, GDP, GDPM, & ! input -! ISTS, IENS ) ! active array size DO K=2,KMAX DO I=ISTS,IENS @@ -424,27 +333,20 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime do n=1,nctp do k=1,kmax do i=ists,iens - sigmai(i,k,n) = zero !DDsigma - vverti(i,k,n) = zero !DDsigma + vverti(i,k,n) = zero enddo enddo enddo do k=1,kmax do i=ists,iens - sigma(i,k) = zero !DDsigma + sigma(i,k) = zero enddo enddo ! -! call main routine -! !*************************************************************************************** call CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions otspt(1,1), otspt(1,2), lprnt, ipr,& GTT , GTQ , GTU , GTV , & ! output -! CMDET , GTLDET, GTIDET, & ! output -! GTPRP , GSNWP , GMFX0 , & ! output -! GMFX1 , cape , KT , & ! output -! dt_mf , GTLDET, GTIDET, & ! output dt_mf , & ! output GTPRP , GSNWP , ud_mf , & ! output dd_mf , cape , KT , & ! output @@ -452,62 +354,39 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime GDT , GDQ , GDU , GDV , & ! input GDTM , & ! input GDP , GDPM , GDZ , GDZM , & ! input + delp , delpi , & DELTA , DELTI , ISTS , IENS, mype,& ! input fscav, fswtr, wcbmaxm, nctp, & - sigmai, sigma, vverti, & ! input/output !DDsigma - sfluxterm, qvfluxterm, do_aw, do_awdd)!DDsigmadiag, output + sigma, vverti, & ! input/output !DDsigma + do_aw, do_awdd,flx_form) ! ! !DD detrainment has to be added in for GFS ! ! if (lprnt) write(0,*)' aft cs_cum gtqi=',gtq(ipr,:,2) ! if (lprnt) write(0,*)' aft cs_cum gtql=',gtq(ipr,:,3) + do n=2,NTR do k=1,KMAX do i=1,IJSDIM - clw(i,k,n-1) = GDQ(i,k,n) + GTQ(i,k,n) * delta -! clw(i,k,1) = GDQ(i,k,2) + (gtq(i,k,2) + gtidet(i,k)) * delta -! clw(i,k,2) = GDQ(i,k,3) + (gtq(i,k,3) + gtldet(i,k)) * delta + clw(i,k,n-1) = max(zero, GDQ(i,k,n) + GTQ(i,k,n) * delta) enddo enddo enddo - -! if (ntr > 3) then ! update tracers -! do n=4,ntr -! do k=1,kmax -! do i=1,ijsdim -! clw(i,k,n-1) = gdq(i,k,n) + gtq(i,k,n) * delta -! enddo -! enddo -! enddo -! endif +! if (lprnt) write(0,*)'in cs clw1a=',clw(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)'in cs clw2a=',clw(ipr,:,2),' kdt=',kdt ! do k=1,KMAX do i=1,IJSDIM -!DD heat(i,KMAX-k+1) = CP*GTT(i,k) - EMELT*GTIDET(i,k) -!DD dlf (i,k) = GTLDET(i,k) + GTIDET(i,k) -!DD rliq(i) = (GTLDET(i,k)+GTIDET(i,k))*(GDPM(i,k+1)-GDPM(i,k))/GRAV - - q(i,k) = GDQ(i,k,1) + GTQ(i,k,1) * delta + q(i,k) = max(zero, GDQ(i,k,1) + GTQ(i,k,1) * delta) t(i,k) = GDT(i,k) + GTT(i,k) * delta u(i,k) = GDU(i,k) + GTU(i,k) * delta v(i,k) = GDV(i,k) + GTV(i,k) * delta -! -! not used for now - moorthi -! flxprec(i,k) = GTPRP(i,k) -! flxsnow(i,k) = GSNWP(i,k) - -! Set the mass fluxes. -! ud_mf (i,k) = GMFX0(i,k) -! dd_mf (i,k) = GMFX1(i,k) -! dt_mf (i,k) = CMDET(i,k) -! if (lprnt .and. i == ipr) write(0,*)' k=',k,'in cs_conv qv=',q(ipr,k)& -! , ' GDQ=',gdq(ipr,k,1),' gtq=',GTQ(ipr,k,1)*delta,' kdt=',kdt enddo enddo -! if (lprnt) write(0,*)' in cs_conv qv=',q(ipr,1:35) - if (ncld == 2) then ! for 2M microphysics, always output these variables + + if (mp_phys == 10) then ! for 2M microphysics, always output these variables if (do_aw) then do k=1,KMAX kp1 = min(k+1,kmax) @@ -515,17 +394,20 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime qicn(i,k) = max(0.0, clw(i,k,1)-gdq(i,k,2)) qlcn(i,k) = max(0.0, clw(i,k,2)-gdq(i,k,3)) -!! qicn(i,k) = max(0.0, (gtq(i,k,2)+gtidet(i,k)) * delta) -!! qlcn(i,k) = max(0.0, (gtq(i,k,3)+gtldet(i,k)) * delta) - cnv_fice(i,k) = qicn(i,k) / max(1.0e-10,qicn(i,k)+qlcn(i,k)) + + wrk = qicn(i,k) + qlcn(i,k) + if (wrk > 1.0e-12) then + cnv_fice(i,k) = qicn(i,k) / wrk + else + cnv_fice(i,k) = 0.0 + endif ! CNV_MFD(i,k) = dt_mf(i,k) * (1.0/delta) -!! CNV_DQLDT(i,k) = dt_mf(i,k) * max(0.0,gtidet(i,k)+gtldet(i,k)) - CNV_DQLDT(i,k) = (qicn(i,k)+qlcn(i,k)) / delta + CNV_DQLDT(i,k) = tem / delta CNV_PRC3(i,k) = 0.0 CNV_NDROP(i,k) = 0.0 CNV_NICE(i,k) = 0.0 - cf_upi(i,k) = max(0.0, min(0.5, 0.5*(sigma(i,k)+sigma(i,kp1)))) + cf_upi(i,k) = max(0.0, min(1.0, 0.5*(sigma(i,k)+sigma(i,kp1)))) CLCN(i,k) = cf_upi(i,k) !downdraft is below updraft !! clcn(i,k) = max(0.0,min(0.01*log(1.0+500*ud_mf(i,k)/delta),0.25)) @@ -534,44 +416,26 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime !! / (delta*max(cf_upi(i,k),1.e-12)*gdp(i,k)) enddo enddo -!! do n=1,nctp - do k=1,kmax - do i=1,ijsdim -!! w_upi(i,k) = w_upi(i,k) + 0.25*(sigmai(i,k,n)+sigmai(i,k+1,n)) & -!! * (vverti(i,k,n)+vverti(i,k+1,n)) - tem = 0.0 - do n=1,nctp - tem = tem + sigmai(i,k,n) - w_upi(i,k) = w_upi(i,k) + sigmai(i,k,n) * vverti(i,k,n) - enddo - w_upi(i,k) = w_upi(i,k) / max (1.0e-10,tem) - -!! cf_upi(i,k) = max(0.0,min(0.01*log(1.0+500*ud_mf(i,k)/delta),0.25)) -!! & 500*ud_mf(i,k)/delta),0.60)) -!! CLCN(i,k) = cf_upi(i,k) !downdraft is below updraft - -!! w_upi(i,k) = ud_mf(i,k)*(t(i,k)+epsvt*gdq(i,k,1)) * rair & -!! / (delta*max(cf_upi(i,k),1.e-12)*gdp(i,k)) - + do k=1,KMAX + do i=1,ijsdim + do n=1,nctp + w_upi(i,k) = w_upi(i,k) + vverti(i,k,n) enddo + if (sigma(i,k) > 1.0e-10) then + w_upi(i,k) = w_upi(i,k) / sigma(i,k) + else + w_upi(i,k) = 0.0 + endif enddo -!! enddo -!! do k=1,kmax -!! do i=1,ijsdim -!! w_upi(i,k) = w_upi(i,k) / max(1.0e-9, 0.5*(sigma(i,k)+sigma(i,k+1))) -!! enddo -!! enddo + enddo else do k=1,KMAX do i=1,IJSDIM qicn(i,k) = max(0.0, clw(i,k,1)-gdq(i,k,2)) qlcn(i,k) = max(0.0, clw(i,k,2)-gdq(i,k,3)) -! qicn(i,k) = max(0.0, (gtq(i,k,2)+gtidet(i,k)) * delta) -! qlcn(i,k) = max(0.0, (gtq(i,k,3)+gtldet(i,k)) * delta) cnv_fice(i,k) = qicn(i,k) / max(1.0e-10,qicn(i,k)+qlcn(i,k)) ! CNV_MFD(i,k) = dt_mf(i,k) * (1/delta) -! CNV_DQLDT(i,k) = max(0.0,gtidet(i,k)+gtldet(i,k)) CNV_DQLDT(i,k) = (qicn(i,k)+qlcn(i,k)) / delta CNV_PRC3(i,k) = 0.0 CNV_NDROP(i,k) = 0.0 @@ -588,40 +452,7 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime endif !**************************************************************************** -! do i=1,1 !DDdebug -! write(iunit,*)'gtt' !DDdebug -! write(iunit,*)gtt(I,:) !DDdebug -! do k = 1,ntr !DDdebug -! write(iunit,*)'gtq',k !DDdebug -! write(iunit,*)gtq(I,:,k) !DDdebug -! enddo !DDdebug -! write(iunit,*)'gtu' !DDdebug -! write(iunit,*)gtu(I,:) !DDdebug -! write(iunit,*)'gtv' !DDdebug -! write(iunit,*)gtv(I,:) !DDdebug -! write(iunit,*)'gtprp' !DDdebug -! write(iunit,*)gtprp(I,:) !DDdebug -! write(iunit,*)'gsnwp' !DDdebug -! write(iunit,*)gsnwp(I,:) !DDdebug -! write(iunit,*)'gmfx0' !DDdebug -! write(iunit,*)gmfx0(I,:) !DDdebug -! write(iunit,*)'gmfx1' !DDdebug -! write(iunit,*)gmfx1(I,:) !DDdebug -! write(iunit,*)'cmdet' !DDdebug -! write(iunit,*)cmdet(I,:) !DDdebug -! write(iunit,*)'cbmfx' !DDdebug -! write(iunit,*)cbmfx(I,:) !DDdebug -! write(iunit,*)'kt' !DDdebug -! write(iunit,*)kt(I,:) !DDdebug -! write(iunit,*)'cape' !DDdebug -! write(iunit,*)cape(I) !DDdebug -! write(iunit,*)'gtldet' !DDdebug -! write(iunit,*)gtldet(I,:) !DDdebug -! write(iunit,*)'gtidet' !DDdebug -! write(iunit,*)gtldet(I,:) !DDdebug -! enddo !DDdebug -!**************************************************************************** -! + KTMAX = 1 do n=1,nctp do i=1,IJSDIM @@ -630,22 +461,18 @@ subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dime enddo ! do i=1,IJSDIM -! jctop(i) = KTMAX(i) prec(i) = GTPRP(i,1) snow(i) = GSNWP(i,1) -! rliq(i) = rliq(i)/1000._r8 ! kg/m2/s => m/s + if (prec(i)+snow(i) > 0.0) then + kcnv(i) = 1 + else + kcnv(i) = 0 + endif enddo ! if (lprnt) then ! write(0,*)' aft cs_cum prec=',prec(ipr),'GTPRP=',GTPRP(ipr,1) ! endif -! cme = zero ! temporarily set to be zero -! pflx = zero ! temporarily set to be zero -! jcbot = 1 ! set to be the lowest layer -! if (lprnt) then -! write(2000+mype,*)' gdq=',gdq(13,:,1) -! write(2000+mype,*)' q=',q(13,:) -! endif ! if (do_aw) then ! call moist_bud(ijsdim,ijsdim,im,kmax,mype,kdt,grav,delta,delp,prec & @@ -682,28 +509,27 @@ end subroutine cs_convr !************************************************************************ ! cumulus main routine ! -------------------- - SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions - otspt1, otspt2, lprnt, ipr, & - GTT , GTQ , GTU , GTV , & ! output -! CMDET , GTLDET, GTIDET, & ! output - CMDET , & ! output - GTPRP , GSNWP , GMFX0 , & ! output - GMFX1 , CAPE , KT , & ! output -! CUMCLW, CUMFRC, + SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions + otspt1, otspt2, lprnt , ipr , & + GTT , GTQ , GTU , GTV , & ! output + CMDET , & ! output + GTPRP , GSNWP , GMFX0 , & ! output + GMFX1 , CAPE , KT , & ! output CBMFX , & ! modified GDT , GDQ , GDU , GDV , & ! input GDTM , & ! input GDP , GDPM , GDZ , GDZM , & ! input -! GDCFRC, + delp , delpi , & DELTA , DELTI , ISTS , IENS, mype,& ! input fscav, fswtr, wcbmaxm, nctp, & ! - sigmai, sigma, vverti, & ! input/output !DDsigma - sfluxterm, qvfluxterm, do_aw, do_awdd ) ! output !DDsigmadiag + sigma, vverti, & ! input/output !DDsigma + do_aw, do_awdd, flx_form ) ! IMPLICIT NONE + Integer, parameter :: ntrq=4 ! tarting index for tracers INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, mype, nctp, ipr !! DD, for GFS, pass in - logical, intent(in) :: do_aw, do_awdd ! switch to apply Arakawa-Wu to the tendencies + logical, intent(in) :: do_aw, do_awdd, flx_form ! switch to apply Arakawa-Wu to the tendencies logical, intent(in) :: otspt1(ntr), otspt2(ntr), lprnt ! ! [OUTPUT] @@ -713,9 +539,6 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(r8), INTENT(OUT) :: GTV (IJSDIM, KMAX ) !! tendency of v REAL(r8), INTENT(OUT) :: CMDET (IJSDIM, KMAX ) !! detrainment mass flux -! REAL(r8), INTENT(OUT) :: GTLDET(IJSDIM, KMAX ) !! cloud liquid tendency by detrainment -! REAL(r8), INTENT(OUT) :: GTIDET(IJSDIM, KMAX ) !! cloud ice tendency by detrainment - ! assuming there is no flux at the top of the atmospherea - Moorthi REAL(r8), INTENT(OUT) :: GTPRP (IJSDIM, KMAX ) !! rain+snow flux REAL(r8), INTENT(OUT) :: GSNWP (IJSDIM, KMAX ) !! snowfall flux @@ -730,19 +553,20 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions !DDsigma - output added for AW sigma diagnostics ! sigma and vert. velocity as a function of cloud type (1==sfc) - real(r8), intent(out), dimension(IM,KMAX,nctp) :: sigmai, vverti real(r8), intent(out), dimension(IM,KMAX) :: sigma !DDsigma sigma totaled over cloud type - on interfaces (1=sfc) + real(r8), intent(out), dimension(IM,KMAX,nctp) :: vverti ! for computing AW flux form of tendencies ! The tendencies are summed over all cloud types - real(r8), intent(out), dimension(IM,KMAX) :: & !DDsigmadiag - sfluxterm, qvfluxterm ! tendencies of DSE and water vapor due to eddy mass flux - real(r8), dimension(IM,KMAX) :: qlfluxterm, qifluxterm ! tendencies of cloud water and cloud ice due to eddy mass flux +! real(r8), intent(out), dimension(IM,KMAX) :: & !DDsigmadiag + real(r8), allocatable, dimension(:,:) :: sfluxterm, qvfluxterm,& ! tendencies of DSE and water vapor due to eddy mass flux + qlfluxterm, qifluxterm,& ! tendencies of cloud water and cloud ice due to eddy mass flux ! The fluxes are for an individual cloud type and reused. ! condtermt, condtermq are eddy flux of temperature and water vapor - real(r8), dimension(IM,KMAX) :: condtermt, condtermq, frzterm, & - prectermq, prectermfrz + condtermt, condtermq, frzterm, & + prectermq, prectermfrz + real(r8), allocatable, dimension(:,:,:) :: trfluxterm ! tendencies of tracers due to eddy mass flux ! ! [INPUT] REAL(r8), INTENT(IN) :: GDT (IJSDIM, KMAX ) ! temperature T @@ -756,7 +580,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(r8), INTENT(IN) :: GDZM (IJSDIM, KMAX+1 ) ! altitude REAL(r8), INTENT(IN) :: DELTA ! delta(t) (dynamics) REAL(r8), INTENT(IN) :: DELTI ! delta(t) (internal variable) - INTEGER, INTENT(IN) :: ISTS, IENS ! array range + INTEGER, INTENT(IN) :: ISTS, IENS ! array range real(r8), intent(in) :: fscav(ntr), fswtr(ntr), wcbmaxm(ijsdim) ! @@ -765,23 +589,15 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(r8) GSNWC (IJSDIM) ! snowfall REAL(r8) CUMCLW(IJSDIM, KMAX) ! cloud water in cumulus REAL(r8) CUMFRC(IJSDIM) ! cumulus cloud fraction -!COSP -! REAL(r8) QLIQC (IJSDIM, KMAX) ! cumulus cloud liquid water [kg/kg] -! REAL(r8) QICEC (IJSDIM, KMAX) ! cumulus cloud ice [kg/kg] -! REAL(r8) GPRCPF(IJSDIM, KMAX) ! rainfall flux at full level -! REAL(r8) GSNWPF(IJSDIM, KMAX) ! snowfall flux at full level ! REAL(r8) GTCFRC(IJSDIM, KMAX) ! change in cloud fraction REAL(r8) FLIQC (IJSDIM, KMAX) ! liquid ratio in cumulus ! REAL(r8) GDCFRC(IJSDIM, KMAX) ! cloud fraction -! -! REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice -! REAL(r8) GTQI (IJSDIM, KMAX) ! tendency of cloud ice -! REAL(r8) GTQL (IJSDIM, KMAX) ! tendency of cloud liquid ! REAL(r8) GDW (IJSDIM, KMAX) ! total water REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) DELPI (IJSDIM, KMAX) REAL(r8) GDQS (IJSDIM, KMAX) ! saturate moisture REAL(r8) FDQS (IJSDIM, KMAX) REAL(r8) GAM (IJSDIM, KMAX) @@ -789,13 +605,13 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy REAL(r8) GDHS (IJSDIM, KMAX) ! saturate MSE ! - REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux (half lev) + REAL(r8) GCYM (IJSDIM, KMAX, NCTP)! norm. mass flux (half lev) REAL(r8) GCHB (IJSDIM) ! cloud base MSE-Li*Qi REAL(r8) GCWB (IJSDIM) ! cloud base total water REAL(r8) GCUB (IJSDIM) ! cloud base U REAL(r8) GCVB (IJSDIM) ! cloud base V REAL(r8) GCIB (IJSDIM) ! cloud base ice - REAL(r8) ELAM (IJSDIM, KMAX, NCTP)! entrainment (rate*massflux) + REAL(r8) GCtrB (IJSDIM,ntrq:ntr) ! cloud base tracer REAL(r8) GCYT (IJSDIM, NCTP) ! norm. mass flux @top REAL(r8) GCHT (IJSDIM, NCTP) ! cloud top MSE REAL(r8) GCQT (IJSDIM, NCTP) ! cloud top q @@ -804,11 +620,13 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(r8) GCVT (IJSDIM, NCTP) ! cloud top V REAL(r8) GCLT (IJSDIM, NCTP) ! cloud top cloud water REAL(r8) GCIT (IJSDIM, NCTP) ! cloud top cloud ice + REAL(r8) GCtrT (IJSDIM, ntrq:ntr, NCTP) ! cloud top tracer REAL(r8) GTPRT (IJSDIM, NCTP) ! precipitation/M REAL(r8) GCLZ (IJSDIM, KMAX) ! cloud liquid for each CTP REAL(r8) GCIZ (IJSDIM, KMAX) ! cloud ice for each CTP - REAL(r8) ACWF (IJSDIM, NCTP) ! cloud work function +! REAL(r8) ACWF (IJSDIM, NCTP) ! cloud work function + REAL(r8) ACWF (IJSDIM ) ! cloud work function REAL(r8) GPRCIZ(IJSDIM, KMAX) ! precipitation REAL(r8) GSNWIZ(IJSDIM, KMAX) ! snowfall REAL(r8) GTPRC0(IJSDIM) ! precip. before evap. @@ -828,7 +646,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! REAL(r8) CTOPP (IJSDIM) ! cloud top pressure REAL(r8) GDZTR (IJSDIM) ! tropopause height - REAL(r8) FLIQOU(IJSDIM, KMAX) ! liquid ratio in cumulus +! REAL(r8) FLIQOU(IJSDIM, KMAX) ! liquid ratio in cumulus INTEGER KB (IJSDIM) INTEGER KSTRT (IJSDIM) ! tropopause level REAL(r8) GAMX @@ -840,31 +658,30 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! SAVE ERMR INTEGER KTMX (NCTP) ! max of cloud top INTEGER KTMXT ! max of cloud top - REAL(r8) TIMED +! REAL(r8) TIMED REAL(r8) GDCLDX, GDMU2X, GDMU3X ! - LOGICAL OOUT1, OOUT2 - REAL(r8) HBGT (IJSDIM) ! imbalance in column heat REAL(r8) WBGT (IJSDIM) ! imbalance in column water !DDsigma begin local work variables - all on model interfaces (sfc=1) REAL(r8) lamdai ! lamda for cloud type ctp - REAL(r8) gdqm, gdlm, gdim ! water vaper - REAL(r8) gdtrm ! water vaper tracer - character(len=4) :: cproc !DDsigmadiag + REAL(r8) gdqm, gdlm, gdim ! water vapor + REAL(r8) gdtrm(ntrq:ntr) ! tracer ! the following are new arguments to cumup to get them out for AW REAL(r8) wcv (IJSDIM, KMAX) ! in-cloud vertical velocity - REAL(r8) GCTM (IJSDIM, KMAX) ! cloud T (half lev) !DDsigmadiag make output - REAL(r8) GCQM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output - REAL(r8) GCwM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output - REAL(r8) GCiM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output - REAL(r8) GClM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output - REAL(r8) GChM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GCTM (IJSDIM, KMAX) ! cloud T (half lev) !DDsigmadiag make output + REAL(r8) GCQM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GCwM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GCiM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GClM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GChM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GCtrM (IJSDIM, KMAX, ntrq:ntr) ! cloud tracer (half lev) !DDsigmadiag make output ! eddy flux profiles for dse, water vapor, cloud water, cloud ice - REAL(r8), dimension(Kmax+1) :: sfluxtem, qvfluxtem, qlfluxtem, qifluxtem + REAL(r8), dimension(Kmax+1) :: sfluxtem, qvfluxtem, qlfluxtem, qifluxtem + REAL(r8), dimension(Kmax+1,ntrq:ntr) :: trfluxtem ! tracer ! tendency profiles - condensation heating, condensation moistening, heating due to ! freezing, total precip production, frozen precip production @@ -877,9 +694,10 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(r8), dimension(ijsdim) :: moistening_aw real(r8), dimension(ijsdim,kmax) :: gctbl, gcqbl,gcwbl, gcqlbl, gcqibl, & !DDsigmadiag updraft profiles below cloud Base sigmad ! downdraft area fraction + real(r8), dimension(ijsdim,kmax,ntrq:ntr) :: gctrbl !DDsigmadiag tracer updraft profiles below cloud Base ! rhs_q, rhs_h are residuals of condensed water, MSE budgets to compute condensation, ! and heating due to freezing - real(r8) :: rhs_q, rhs_h, fsigma, delpinv + real(r8) :: rhs_q, rhs_h, fsigma, sigmai, delpinv ! real(r8) :: rhs_q, rhs_h, sftem, qftem, qlftem, qiftem, & ! fsigma ! factor to reduce mass flux terms (1-sigma**2) for AW !DDsigma end local work variables @@ -887,15 +705,17 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! profiles of heating due to precip evaporation, melting and sublimation, and the ! evap, melting and sublimation rates. - REAL(r8) dtdwn (IJSDIM, KMAX) ! t tendency downdraft detrainment - REAL(r8) dqvdwn (IJSDIM, KMAX) ! qv tendency downdraft detrainment - REAL(r8) dqldwn (IJSDIM, KMAX) ! ql tendency downdraft detrainment - REAL(r8) dqidwn (IJSDIM, KMAX) ! qi tendency downdraft detrainment + REAL(r8), allocatable, dimension(:,:) :: dtdwn, & ! t tendency downdraft detrainment + dqvdwn, & ! qv tendency downdraft detrainment + dqldwn, & ! ql tendency downdraft detrainment + dqidwn ! qi tendency downdraft detrainment + REAL(r8), allocatable, dimension(:,:,:) :: dtrdwn ! tracer tendency downdraft detrainment !DDsigma end local work variables ! ! [INTERNAL PARM] REAL(r8), parameter :: WCBMIN = zero ! min. of updraft velocity at cloud base + !M REAL(r8) :: WCBMAX = 1.4_r8 ! max. of updraft velocity at cloud base !M wcbas commented by Moorthi since it is not used !M REAL(r8) :: WCBAS = 2._r8 ! updraft velocity**2 at cloud base (ASMODE) @@ -914,27 +734,17 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions REAL(r8) :: GCRSTR = 1.e-4_r8 ! crit. dT/dz tropopause real(kind=r8) :: tem, esat, mflx_e, cbmfl, tem1, tem2, tem3 - INTEGER :: KBMX, I, K, CTP, ierr, n, kp1, km1, kk, kbi + INTEGER :: KBMX, I, K, CTP, ierr, n, kp1, km1, kk, kbi, l, l1 ! LOGICAL, SAVE :: OFIRST = .TRUE. ! called first time? ! -! [ONCE] - IF (OFIRST) THEN + IF (OFIRST) THEN OFIRST = .FALSE. - -! fscav = 0._r8 -! fswtr = 0._r8 -! write(0,*)' NTR in cs_conv=',ntr,' mype=',mype -! do n=1,ntr -! FSCAV(n) = 0._r8 !DD split declaration and initialization -! FSWTR(n) = 0._r8 !DD split declaration and initialization -! enddo - IF (OINICB) THEN CBMFX = zero ENDIF - ENDIF ! ofirst if + ENDIF ! do n=1,ntr do k=1,kmax @@ -946,38 +756,55 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions do k=1,kmax do i=1,ijsdim - gtt(i,k) = zero - gtu(i,k) = zero - gtv(i,k) = zero -! gtqi(i,k) = zero -! gtql(i,k) = zero - gmflx(i,k) = zero - gmfx0(i,k) = zero - gprci(i,k) = zero - gsnwi(i,k) = zero - qliq(i,k) = zero - qice(i,k) = zero - gtcfrc(i,k) = zero - cumclw(i,k) = zero - fliqc(i,k) = zero - fliqou(i,k) = zero -! gprcpf(i,k) = zero -! gsnwpf(i,k) = zero - sfluxterm(i,k) = zero - qvfluxterm(i,k) = zero - qlfluxterm(i,k) = zero - qifluxterm(i,k) = zero - condtermt(i,k) = zero - condtermq(i,k) = zero - frzterm(i,k) = zero - prectermq(i,k) = zero - prectermfrz(i,k) = zero - dtdwn(i,k) = zero - dqvdwn(i,k) = zero - dqidwn(i,k) = zero - dqvdwn(i,k) = zero + gtt(i,k) = zero + gtu(i,k) = zero + gtv(i,k) = zero + gmflx(i,k) = zero + gmfx0(i,k) = zero + gprci(i,k) = zero + gsnwi(i,k) = zero + qliq(i,k) = zero + qice(i,k) = zero + gtcfrc(i,k) = zero + cumclw(i,k) = zero + fliqc(i,k) = zero + sigma(i,k) = zero enddo enddo + if (do_aw .and. flx_form) then + allocate(sfluxterm(ijsdim,kmax), qvfluxterm(ijsdim,kmax), qlfluxterm(ijsdim,kmax), & + qifluxterm(ijsdim,kmax), condtermt(ijsdim,kmax), condtermq(ijsdim,kmax), & + frzterm(ijsdim,kmax), prectermq(ijsdim,kmax), prectermfrz(ijsdim,kmax), & + dtdwn(ijsdim,kmax), dqvdwn(ijsdim,kmax), dqldwn(ijsdim,kmax), & + dqidwn(ijsdim,kmax), trfluxterm(ijsdim,kmax,ntrq:ntr), & + dtrdwn(ijsdim,kmax,ntrq:ntr)) + do k=1,kmax + do i=1,ijsdim + sfluxterm(i,k) = zero + qvfluxterm(i,k) = zero + qlfluxterm(i,k) = zero + qifluxterm(i,k) = zero + condtermt(i,k) = zero + condtermq(i,k) = zero + frzterm(i,k) = zero + prectermq(i,k) = zero + prectermfrz(i,k) = zero + dtdwn(i,k) = zero + dqvdwn(i,k) = zero + dqldwn(i,k) = zero + dqidwn(i,k) = zero + cmdet(i,k) = zero + enddo + enddo + do n = ntrq,ntr + do k=1,kmax + do i=1,ijsdim + trfluxterm(i,k,n) = zero + dtrdwn(i,k,n) = zero + enddo + enddo + enddo + endif do i=1,ijsdim gprcc(i,:) = zero gtprc0(i) = zero @@ -989,19 +816,16 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions do k=1,kmax do i=1,ijsdim -! GDQI(i,k) = GDQ(i,k,ITI) GDW(i,k) = GDQ(i,k,1) + GDQ(i,k,ITL) + GDQ(i,k,iti) enddo enddo ! DO K=1,KMAX DO I=ISTS,IENS - DELP(I,K) = GDPM(I,K) - GDPM(I,K+1) esat = min(gdp(i,k), fpvs(gdt(i,k))) GDQS(I,K) = min(EPSV*esat/max(gdp(i,k)+epsvm1*esat, 1.0e-10), 1.0) -! FDQS(I,K) = FDQSAT(GDT(I,K), GDQS(I,K)) tem = one / GDT(I,K) - FDQS(I,K) = GDQS(I,K) * tem * (fact1 + fact2*tem) + FDQS(I,K) = GDQS(I,K) * tem * (fact1 + fact2*tem) ! calculate d(qs)/dT GAM (I,K) = ELOCP*FDQS(I,K) GDS (I,K) = CP*GDT(I,K) + GRAV*GDZ(I,K) ! layer dry static energy GDH (I,K) = GDS(I,K) + EL*GDQ(I,K,1) ! layer moist static energy @@ -1030,15 +854,46 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions !! Cloud Base properties CALL CUMBAS(IJSDIM, KMAX , & !DD dimensions - KB , GCYM , KBMX , & ! output + KB , GCYM(1,1,1) , KBMX , & ! output + ntr , ntrq , & GCHB , GCWB , GCUB , GCVB , & ! output - GCIB , & ! output + GCIB , gctrb, & ! output GDH , GDW , GDHS , GDQS , & ! input GDQ(1,1,iti) , GDU , GDV , GDZM , & ! input GDPM , FDQS , GAM , & ! input + lprnt, ipr, & ISTS , IENS , & !) ! input - gctbl, gcqbl,gdq(1,1,1),gcwbl, gcqlbl, gcqibl) ! sub cloud tendencies + gctbl, gcqbl,gdq,gcwbl, gcqlbl, gcqibl, gctrbl) ! sub cloud tendencies ! +! Compute CAPE and CIN +! + DO I=ISTS,IENS + CAPE(i) = zero + CIN(i) = zero + JBUOY(i) = 0 + enddo + DO K=2,KMAX + DO I=ISTS,IENS + if (kb(i) > 0) then + IF (K >= KB(I)) THEN + BUOY = (GDH(I,1)-GDHS(I,K)) / ((one+ELOCP*FDQS(I,K)) * CP*GDT(I,K)) + ELSE + BUOY = (GDS(I,1)-GDS(I,K)) / (CP*GDT(I,K)) + END IF + IF (BUOY > zero .AND. JBUOY(I) /= 0) THEN + CAPE(I) = CAPE(I) + BUOY * GRAV * (GDZM(I,K+1) - GDZM(I,K)) + JBUOY(I) = 2 + ELSEIF (BUOY < zero .AND. JBUOY(I) /= 2) THEN + CIN(I) = CIN(I) - BUOY * GRAV * (GDZM(I,K+1) - GDZM(I,K)) + JBUOY(I) = 1 + ENDIF + endif + ENDDO + ENDDO + DO I=ISTS,IENS + IF (JBUOY(I) /= 2) CIN(I) = -999.D0 + if (cin(i) < cincrit) kb(i) = -1 + ENDDO !DDsigma some initialization before summing over cloud type do k=1,kmax ! Moorthi @@ -1052,6 +907,14 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo enddo + do ctp=2,nctp + do k=1,kmax + do i=1,ijsdim + gcym(i,k,ctp) = gcym(i,k,1) + enddo + enddo + enddo + DO CTP=1,NCTP ! loop over cloud types tem = ctp / DBLE(NCTP) @@ -1065,34 +928,33 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions !! CUMUP computes In-cloud Properties - CALL CUMUP(IJSDIM, KMAX, NTR , & !DD dimensions - ACWF(1,CTP) , ELAM(1,1,CTP), & ! output + CALL CUMUP(IJSDIM, KMAX, NTR, ntrq, & !DD dimensions + ACWF , & ! output GCLZ , GCIZ , GPRCIZ , GSNWIZ, & ! output GCYT(1,CTP) , GCHT(1,CTP) , GCQT (1,CTP), & ! output GCLT(1,CTP) , GCIT(1,CTP) , GTPRT(1,CTP), & ! output - GCUT(1,CTP) , GCVT(1,CTP) , & ! output + GCUT(1,CTP) , GCVT(1,CTP) , gctrt(1,ntrq:ntr,ctp), & ! output KT (1,CTP) , KTMX(CTP) , & ! output - GCYM , & ! modified + GCYM(1,1,CTP) , & ! modified wcv , & ! !DD-sigma new output GCHB , GCWB , GCUB , GCVB , & ! input !DDsigmadiag - GCIB , & ! input + GCIB , gctrb , & ! input GDU , GDV , GDH , GDW , & ! input GDHS , GDQS , GDT , GDTM , & ! input GDQ , GDQ(1,1,iti) , GDZ , GDZM , & ! input GDPM , FDQS , GAM , GDZTR , & ! input CPRES , WCBX , & ! input -! CPRES , WCBX , ERMR(CTP), & ! input KB , CTP , ISTS , IENS , & ! input - gctm, gcqm, gcwm, gchm, gcwt, gclm, gcim, & ! additional incloud profiles and cloud top total water - cbmfx(1,ctp), dtcondtem, dqcondtem, dtfrztem ) !DDsigmadiag + gctm, gcqm, gcwm, gchm, gcwt, gclm, gcim,gctrm, & ! additional incloud profiles and cloud top total water + lprnt, ipr ) ! !! CUMBMX computes Cloud Base Mass Flux - CALL CUMBMX(IJSDIM, KMAX , & !DD dimensions - CBMFX(1,CTP), & ! modified - ACWF (1,CTP), GCYT(1,CTP), GDZM , & ! input - GDW , GDQS , DELP , & ! input - KT (1,CTP), KTMX(CTP) , KB , & ! input + CALL CUMBMX(IJSDIM, KMAX, & !DD dimensions + CBMFX(1,CTP), & ! modified + ACWF , GCYT(1,CTP), GDZM , & ! input + GDW , GDQS , DELP , & ! input + KT (1,CTP), KTMX(CTP) , KB , & ! input DELTI , ISTS , IENS ) !DDsigma - begin sigma computation @@ -1100,42 +962,27 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions if (do_aw) then do i=ISTS,IENS - do k=1,kmax+1 ! initialize eddy fluxes for this cloud time - sfluxtem(k) = zero - qvfluxtem(k) = zero - qlfluxtem(k) = zero - qifluxtem(k) = zero - enddo + if (flx_form) then +! initialize eddy fluxes for cloud type ctp + do k=1,kmax+1 + sfluxtem(k) = zero + qvfluxtem(k) = zero + qlfluxtem(k) = zero + qifluxtem(k) = zero + enddo + do n=ntrq,ntr ! tracers + do k=1,kmax+1 + trfluxtem(k,n) = zero + enddo + enddo + endif cbmfl = cbmfx(i,ctp) kk = kt(i,ctp) ! cloud top index if(cbmfl > zero) then ! this should avoid zero wcv in the denominator - kbi = kb(i) ! cloud top index - do k=2,kbi ! compute eddy fluxes below cloud base - tem = - gcym(i,k) * cbmfl - -! first get environment variables at layer interface - GDQM = half * (GDQ(I,K,1) + GDQ(I,K-1,1)) - GDlM = half * (GDQ(I,K,3) + GDQ(I,K-1,3)) - GDiM = half * (GDQ(I,K,2) + GDQ(I,K-1,2)) -! GDwM = half * (GDw(I,K) + GDw(I,K-1)) - -! flux = mass flux * (updraft variable minus environment variable) -!centered differences -! sfluxtem(k) = tem * (gdtm(i,k)-gctbl(i,k)) -! qvfluxtem(k) = tem * (gdqm-gcqbl(i,k)) -! qlfluxtem(k) = tem * (gdlm-gcqlbl(i,k)) -! qifluxtem(k) = tem * (gdim-gcqibl(i,k)) - -!upstream - This better matches what the original CS tendencies do - sfluxtem(k) = tem * (gdt(i,k)+gocp*(gdz(i,k)-gdzm(i,k))-gctbl(i,k)) - qvfluxtem(k) = tem * (gdq(i,k,1)-gcqbl(i,k)) - qlfluxtem(k) = tem * (gdq(i,k,3)-gcqlbl(i,k)) - qifluxtem(k) = tem * (gdq(i,k,2)-gcqibl(i,k)) - - enddo - do k=kbi,kk ! loop from cloud base to cloud top + kbi = kb(i) ! cloud base index + do k=kbi,kk ! loop from cloud base to cloud top km1 = k - 1 rhs_h = zero rhs_q = zero @@ -1144,132 +991,215 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! GDwM = half * (GDw(I,K) + GDw(I,KM1 )) GDlM = half * (GDQ(I,K,3) + GDQ(I,KM1,3)) GDiM = half * (GDQ(I,K,2) + GDQ(I,KM1,2)) - mflx_e = gcym(i,k) * cbmfl ! mass flux at level k for cloud ctp + do n = ntrq,NTR + GDtrM(n) = half * (GDQ(I,K,n) + GDQ(I,KM1,n)) ! as computed in cumup + enddo + mflx_e = gcym(i,k,ctp) * cbmfl ! mass flux at level k for cloud ctp ! this is the computation of lamda for a cloud type, and then updraft area fraction ! (sigmai for a single cloud type) -! gdtvm = gdtm(i,k) * (1 + epsvt * gdqm) -! gdrhom = gdpm(i,k) / (rair * gdtvm) ! gas law -! gdrhom = gdpm(i,k) / (rair * gdtm(i,k)*(one+epsvt*gdqm)) ! gas law -! lamdai = mflx_e / (gdrhom*wcv(i,k)) lamdai = mflx_e * rair * gdtm(i,k)*(one+epsvt*gdqm) & / (gdpm(i,k)*wcv(i,k)) lamdaprod(i,k) = lamdaprod(i,k) * (one+lamdai) - vverti(i,k,ctp) = wcv(i,k) - sigmai(i,k,ctp) = lamdai / lamdaprod(i,k) - sigma(i,k) = sigma(i,k) + sigmai(i,k,ctp) -! fsigma = 1.0 ! no aw effect, comment following lines to undo AW -! fsigma = (one - sigmai(i,k,ctp)*sigmai(i,k,ctp)) - fsigma = one - sigma(i,k) -! fsigma = (one - sigmai(i,k,ctp)) * (one - sigmai(i,k,ctp)) + +! vverti(i,k,ctp) = wcv(i,k) +! sigmai(i,k,ctp) = lamdai / lamdaprod(i,k) +! sigma(i,k) = max(zero, min(one, sigma(i,k) + sigmai(i,k,ctp))) + + sigmai = lamdai / lamdaprod(i,k) + sigma(i,k) = max(zero, min(one, sigma(i,k) + sigmai)) + vverti(i,k,ctp) = sigmai * wcv(i,k) + + if (flx_form) then + +! fsigma = 1.0 ! no aw effect, comment following lines to undo AW + fsigma = one - sigma(i,k) ! compute tendencies based on mass flux, and tendencies based on condensation ! fsigma is the AW reduction of flux tendencies - if(k > kbi) then ! uncomment for test + if(k == kbi) then + do l=2,kbi ! compute eddy fluxes below cloud base + tem = - fsigma * gcym(i,l,ctp) * cbmfl + +! first get environment variables at layer interface +! l1 = l - 1 +! GDQM = half * (GDQ(I,l,1) + GDQ(I,l1,1)) +! GDlM = half * (GDQ(I,l,3) + GDQ(I,l1,3)) +! GDiM = half * (GDQ(I,l,2) + GDQ(I,l1,2)) +!! GDwM = half * (GDw(I,l) + GDw(I,l1)) +! do n = ntrq,NTR +! GDtrM(n) = half * (GDQ(I,l,n) + GDQ(I,l1,n)) ! as computed in cumup +! enddo + +! flux = mass flux * (updraft variable minus environment variable) +!centered differences +! sfluxtem(l) = tem * (gdtm(i,l)-gctbl(i,l)) +! qvfluxtem(l) = tem * (gdqm-gcqbl(i,l)) +! qlfluxtem(l) = tem * (gdlm-gcqlbl(i,l)) +! qifluxtem(l) = tem * (gdim-gcqibl(i,l)) +! do n = ntrq,NTR +! trfluxtem(l,n) = tem * (gdtrm(n)-gctrbl(i,l,n)) +! enddo + +!upstream - This better matches what the original CS tendencies do + sfluxtem(l) = tem * (gdt(i,l)+gocp*(gdz(i,l)-gdzm(i,l))-gctbl(i,l)) + qvfluxtem(l) = tem * (gdq(i,l,1)-gcqbl(i,l)) + qlfluxtem(l) = tem * (gdq(i,l,3)-gcqlbl(i,l)) + qifluxtem(l) = tem * (gdq(i,l,2)-gcqibl(i,l)) + do n = ntrq,NTR + trfluxtem(l,n) = tem * (gdq(i,l,n)-gctrbl(i,l,n)) + enddo + + enddo + else ! flux = mass flux * (updraft variable minus environment variable) - tem = - fsigma * mflx_e + tem = - fsigma * mflx_e !centered -! sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) -! qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) -! qlfluxtem(k) = tem * (gdlm-gclm(i,k)) -! qifluxtem(k) = tem * (gdim-gcim(i,k)) +! sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) +! qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) +! qlfluxtem(k) = tem * (gdlm-gclm(i,k)) +! qifluxtem(k) = tem * (gdim-gcim(i,k)) +! do n = ntrq,NTR +! trfluxtem(k,n) = tem * (gdtrm(n)-gctrm(i,k,n)) +! enddo !upstream - This better matches what the original CS tendencies do - if(k < kk) then - sfluxtem(k) = tem * (gdt(i,k)+gocp*gdz(i,k)-gctm(i,k)) - qvfluxtem(k) = tem * (gdq(i,k,1)-gcqm(i,k)) - qlfluxtem(k) = tem * (gdq(i,k,3)-gclm(i,k)) - qifluxtem(k) = tem * (gdq(i,k,2)-gcim(i,k)) - else + if(k < kk) then + sfluxtem(k) = tem * (gdt(i,k)+gocp*gdz(i,k)-gctm(i,k)) + qvfluxtem(k) = tem * (gdq(i,k,1)-gcqm(i,k)) + qlfluxtem(k) = tem * (gdq(i,k,3)-gclm(i,k)) + qifluxtem(k) = tem * (gdq(i,k,2)-gcim(i,k)) + do n = ntrq,NTR + trfluxtem(k,n) = tem * (gdq(i,k,n)-gctrm(i,k,n)) + enddo + else ! centered at top of cloud - sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) - qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) - qlfluxtem(k) = tem * (gdlm-gclm(i,k)) - qifluxtem(k) = tem * (gdim-gcim(i,k)) - endif + sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) + qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) + qlfluxtem(k) = tem * (gdlm-gclm(i,k)) + qifluxtem(k) = tem * (gdim-gcim(i,k)) + do n = ntrq,NTR + trfluxtem(k,n) = tem * (gdtrm(n)-gctrm(i,k,n)) + enddo + endif + ! the condensation terms - these come from the MSE and condensed water budgets for ! an entraining updraft -! if(k > kb(i)) then ! comment for test -! if(k <= kk) then ! Moorthi -! if(k < kt(i,ctp)) then +! if(k > kb(i)) then ! comment for test +! if(k <= kk) then ! Moorthi +! if(k < kt(i,ctp)) then ! rhs_h = cbmfl*(gcym(i,k)*gchm(i,k) - (gcym(i,km1)*gchm(i,km1) & -! + GDH(I,Km1 )*(gcym(i,k)-gcym(i,km1))) ) -! rhs_q = cbmfl*(gcym(i,k)*(gcwm(i,k)-gcqm(i,k)) & -! - (gcym(i,km1)*(gcwm(i,km1)-gcqm(i,km1)) & -! + (GDw( I,Km1 )-gdq(i,km1,1))*(gcym(i,k)-gcym(i,km1))) ) - tem = cbmfl * (one - sigma(i,k)) - tem1 = gcym(i,k) * (one - sigma(i,k)) - tem2 = gcym(i,km1) * (one - sigma(i,km1)) - rhs_h = cbmfl * (tem1*gchm(i,k) - (tem2*gchm(i,km1) & +! + GDH(I,Km1 )*(gcym(i,k)-gcym(i,km1))) ) +! rhs_q = cbmfl*(gcym(i,k)*(gcwm(i,k)-gcqm(i,k)) & +! - (gcym(i,km1)*(gcwm(i,km1)-gcqm(i,km1)) & +! + (GDw( I,Km1 )-gdq(i,km1,1))*(gcym(i,k)-gcym(i,km1))) ) +! tem = cbmfl * (one - sigma(i,k)) + tem = cbmfl * (one - 0.5*(sigma(i,k)+sigma(i,km1))) + tem1 = gcym(i,k,ctp) * (one - sigma(i,k)) + tem2 = gcym(i,km1,ctp) * (one - sigma(i,km1)) + rhs_h = cbmfl * (tem1*gchm(i,k) - (tem2*gchm(i,km1) & + GDH(I,Km1)*(tem1-tem2)) ) - rhs_q = cbmfl * (tem1*(gcwm(i,k)-gcqm(i,k)) & - - (tem2*(gcwm(i,km1)-gcqm(i,km1)) & - + (GDw(I,Km1)-gdq(i,km1,1))*(tem1-tem2)) ) - -! ELSE -! rhs_h = cbmfl*(gcht(i,ctp) - (gcym(i,k-1)*gchm(i,k-1) + GDH( I,K-1 )*(gcyt(i,ctp)-gcym(i,k-1))) ) -! rhs_q = cbmfl*((gcwt(i)-gcqt(i,ctp)) - (gcym(i,k-1)*(gcwm(i,k-1)-gcqm(i,k-1)) + (GDw( I,K-1 )-gdq(i,k-1,1))*(gcyt(i,ctp)-gcym(i,k-1))) ) -! endif - -! - dqcondtem(i,km1) = -rhs_q ! condensation -! dqprectem(i,km1) = cbmfl * (GPRCIZ(i,k) + GSNWIZ(i,k)) - dqprectem(i,km1) = tem * (GPRCIZ(i,k) + GSNWIZ(i,k)) ! total precip production -! dfrzprectem(i,km1) = cbmfl * GSNWIZ(i,k) - dfrzprectem(i,km1) = tem * GSNWIZ(i,k) ! production of frozen precip - dtfrztem(i,km1) = rhs_h*oneocp ! heating due to freezing + rhs_q = cbmfl * (tem1*(gcwm(i,k)-gcqm(i,k)) & + - (tem2*(gcwm(i,km1)-gcqm(i,km1)) & + + (GDw(I,Km1)-gdq(i,km1,1))*(tem1-tem2)) ) + +! ELSE +! rhs_h = cbmfl*(gcht(i,ctp) - (gcym(i,k-1)*gchm(i,k-1) + GDH( I,K-1 )*(gcyt(i,ctp)-gcym(i,k-1))) ) +! rhs_q = cbmfl*((gcwt(i)-gcqt(i,ctp)) - (gcym(i,k-1)*(gcwm(i,k-1)-gcqm(i,k-1)) + (GDw( I,K-1 )-gdq(i,k-1,1))*(gcyt(i,ctp)-gcym(i,k-1))) ) +! endif + +! + dqcondtem(i,km1) = -rhs_q ! condensation +! dqprectem(i,km1) = cbmfl * (GPRCIZ(i,k) + GSNWIZ(i,k)) + dqprectem(i,km1) = tem * (GPRCIZ(i,k) + GSNWIZ(i,k)) ! total precip production +! dfrzprectem(i,km1) = cbmfl * GSNWIZ(i,k) + dfrzprectem(i,km1) = tem * GSNWIZ(i,k) ! production of frozen precip + dtfrztem(i,km1) = rhs_h*oneocp ! heating due to freezing ! total temperature tendency due to in cloud microphysics - dtcondtem(i,km1) = - elocp * dqcondtem(i,km1) + dtfrztem(i,km1) + dtcondtem(i,km1) = - elocp * dqcondtem(i,km1) + dtfrztem(i,km1) - endif ! if(k > kbi) then - enddo ! end of k=kbi,kk loop + endif ! if(k > kbi) then + endif ! if (flx_form) + enddo ! end of k=kbi,kk loop - endif ! end of if(cbmfl > zero) + endif ! end of if(cbmfl > zero) ! get tendencies by difference of fluxes, sum over cloud type - do k = 1,kk - delpinv = grav / delp(I,k) -! cloud microphysical tendencies for single cloud type - dtcondtem(i,k) = dtcondtem(i,k) * delpinv - dqcondtem(i,k) = dqcondtem(i,k) * delpinv - dqprectem(i,k) = dqprectem(i,k) * delpinv - dtfrztem(i,k) = dtfrztem(i,k) * delpinv -! sum cloud microphysical tendencies over all cloud types - condtermt(i,k) = condtermt(i,k) + dtcondtem(i,k) - condtermq(i,k) = condtermq(i,k) + dqcondtem(i,k) - prectermq(i,k) = prectermq(i,k) + dqprectem(i,k) - prectermfrz(i,k) = prectermfrz(i,k) + dfrzprectem(i,k) - frzterm(i,k) = frzterm(i,k) + dtfrztem(i,k) + if (flx_form) then + do k = 1,kk + delpinv = delpi(i,k) +! sum single cloud microphysical tendencies over all cloud types + condtermt(i,k) = condtermt(i,k) + dtcondtem(i,k) * delpinv + condtermq(i,k) = condtermq(i,k) + dqcondtem(i,k) * delpinv + prectermq(i,k) = prectermq(i,k) + dqprectem(i,k) * delpinv + prectermfrz(i,k) = prectermfrz(i,k) + dfrzprectem(i,k) * delpinv + frzterm(i,k) = frzterm(i,k) + dtfrztem(i,k) * delpinv ! flux tendencies - compute the vertical flux divergence - sfluxterm(i,k) = sfluxterm(i,k) - (sfluxtem(k+1) - sfluxtem(k)) * delpinv - qvfluxterm(i,k) = qvfluxterm(i,k) - (qvfluxtem(k+1) - qvfluxtem(k)) * delpinv - qlfluxterm(i,k) = qlfluxterm(i,k) - (qlfluxtem(k+1) - qlfluxtem(k)) * delpinv - qifluxterm(i,k) = qifluxterm(i,k) - (qifluxtem(k+1) - qifluxtem(k)) * delpinv - - enddo + sfluxterm(i,k) = sfluxterm(i,k) - (sfluxtem(k+1) - sfluxtem(k)) * delpinv + qvfluxterm(i,k) = qvfluxterm(i,k) - (qvfluxtem(k+1) - qvfluxtem(k)) * delpinv + qlfluxterm(i,k) = qlfluxterm(i,k) - (qlfluxtem(k+1) - qlfluxtem(k)) * delpinv + qifluxterm(i,k) = qifluxterm(i,k) - (qifluxtem(k+1) - qifluxtem(k)) * delpinv + do n = ntrq,ntr + trfluxterm(i,k,n) = trfluxterm(i,k,n) - (trfluxtem(k+1,n) - trfluxtem(k,n)) * delpinv + enddo + enddo + endif ! if (flx_form) enddo ! end of i loop +! + do i=ists,iens + if (cbmfx(i,ctp) > zero) then + tem = one - sigma(i,kt(i,ctp)) + gcyt(i,ctp) = tem * gcyt(i,ctp) + gtprt(i,ctp) = tem * gtprt(i,ctp) + gclt(i,ctp) = tem * gclt(i,ctp) + gcht(i,ctp) = tem * gcht(i,ctp) + gcqt(i,ctp) = tem * gcqt(i,ctp) + gcit(i,ctp) = tem * gcit(i,ctp) + do n = ntrq,ntr + gctrt(i,n,ctp) = tem * gctrt(i,n,ctp) + enddo + gcut(i,ctp) = tem * gcut(i,ctp) + gcvt(i,ctp) = tem * gcvt(i,ctp) + do k=1,kmax + kk = kb(i) + if (k < kk) then + tem = one - sigma(i,kk) + tem1 = tem + else + tem = one - sigma(i,k) + tem1 = one - 0.5*(sigma(i,k)+sigma(i,k-1)) + endif + gcym(i,k,ctp) = tem * gcym(i,k,ctp) + gprciz(i,k) = tem1 * gprciz(i,k) + gsnwiz(i,k) = tem1 * gsnwiz(i,k) + gclz(i,k) = tem1 * gclz(i,k) + gciz(i,k) = tem1 * gciz(i,k) + enddo + endif + enddo - endif ! end of do_aw if !DDsigma - end sigma computation for AW +! + endif ! end of do_aw if !DDsigma - end sigma computation for AW ! ! Cloud Mass Flux & Precip. - CALL CUMFLX(IM , IJSDIM, KMAX , & !DD dimensions - GMFX0 , GPRCI , GSNWI , & ! output - QLIQ , QICE , GTPRC0, & ! output - CBMFX(1,CTP) , GCYM , GPRCIZ , GSNWIZ , & ! input - GTPRT(1,CTP) , GCLZ , GCIZ , & ! input - KB , KT(1,CTP) , KTMX(CTP) , & ! input - ISTS , IENS, sigma ) ! input - - ENDDO ! end of cloud type ctp loop + CALL CUMFLX(IM , IJSDIM, KMAX , & !DD dimensions + GMFX0 , GPRCI , GSNWI , CMDET, & ! output + QLIQ , QICE , GTPRC0, & ! output + CBMFX(1,CTP) , GCYM(1,1,ctp), GPRCIZ , GSNWIZ , & ! input + GTPRT(1,CTP) , GCLZ , GCIZ , GCYT(1,ctp),& ! input + KB , KT(1,CTP) , KTMX(CTP) , & ! input + ISTS , IENS ) ! input + + ENDDO ! end of cloud type ctp loop ! do k=1,kmax @@ -1286,7 +1216,6 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions CUMCLW(I,K) = QLIQ(I,K) + QICE(I,K) IF (CUMCLW(I,K) > zero) THEN FLIQC(I,K) = QLIQ(I,K) / CUMCLW(I,K) - FLIQOU(I,K) = FLIQC(I,K) ENDIF ENDDO ENDDO @@ -1298,21 +1227,20 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions GMFLX , KTMXT , ISTS , IENS ) ! input ! ! Cloud Detrainment Heating - CALL CUMDET(im , IJSDIM, KMAX , NTR , & !DD dimensions - CMDET , & ! output -! CMDET , GTLDET, GTIDET, & ! output - GTT , GTQ , GTCFRC, GTU , GTV , & ! modified -! GTQI , & ! modified - GDH , GDQ , GDCFRC, GDU , GDV , & ! input - CBMFX , GCYT , DELP , GCHT , GCQT , & ! input - GCLT , GCIT , GCUT , GCVT , GDQ(1,1,iti), & ! input - KT , ISTS , IENS, nctp, sigmai ) ! input - -! if (lprnt) write(0,*)' after cumdet gtqi=',gtq(ipr,:,2) + if (.not. do_aw .or. .not. flx_form) then + CALL CUMDET(im , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions + GTT , GTQ , GTCFRC, GTU , GTV , & ! modified + GDH , GDQ , GDCFRC, GDU , GDV , & ! input + CBMFX , GCYT , DELPI , GCHT , GCQT , & ! input + GCLT , GCIT , GCUT , GCVT , GDQ(1,1,iti),& ! input + gctrt , & + KT , ISTS , IENS, nctp ) ! input + endif !for now area fraction of the downdraft is zero, it will be computed ! within cumdwn and applied there ! Get AW downdraft eddy flux and microphysical tendencies out of downdraft code. + do k=1,kmax do i=ists,iens sigmad(i,k) = zero @@ -1320,31 +1248,93 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo ! cumulus downdraft - Melt & Freeze & Evaporation - CALL CUMDWN(IM , IJSDIM, KMAX , NTR , & ! DD dimensions + CALL CUMDWN(IM , IJSDIM, KMAX , NTR , ntrq , & ! DD dimensions GTT , GTQ , GTU , GTV , & ! modified GMFLX , & ! modified updraft+downdraft flux -! GTQI , GMFLX , & ! modified GPRCP , GSNWP , GTEVP , GMDD , & ! output GPRCI , GSNWI , & ! input GDH , GDW , GDQ , GDQ(1,1,iti) , & ! input GDQS , GDS , GDHS , GDT , & ! input GDU , GDV , GDZ , & ! input - GDZM , GCYM , FDQS , DELP , & ! input - sigmad, do_aw , do_awdd, & ! DDsigma input + GDZM , FDQS , DELP , DELPI , & ! input + sigmad, do_aw , do_awdd, flx_form, & ! DDsigma input dtmelt, dtevap, dtsubl, & ! DDsigma input dtdwn , dqvdwn, dqldwn, dqidwn, & ! DDsigma input + dtrdwn, & KB , KTMXT , ISTS , IENS ) ! input -! if (lprnt) write(0,*)' after cumdwn gtqi=',gtq(ipr,:,2) ! here we substitute the AW tendencies into tendencies to be passed out ! if (do_aw) then - do k=1,kmax - do i=ists,iens - sigma(i,k) = sigma(i,k) + sigmad(i,k) - enddo - enddo +! do k=1,kmax +! do i=ists,iens +! sigma(i,k) = sigma(i,k) + sigmad(i,k) +! enddo +! enddo -! AW lump all heating together, compute qv term + if (.not. do_aw .or. .not. flx_form) then +! Cloud Subsidence Heating +! -----------------------= + CALL CUMSBH(IM , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions + GTT , GTQ , & ! modified + GTU , GTV , & ! modified + GDH , GDQ , GDQ(1,1,iti) , & ! input + GDU , GDV , & ! input + DELPI , GMFLX , GMFX0 , & ! input + KTMXT , CPRES , kb, ISTS , IENS ) ! input + else + CALL CUMSBW(IM , IJSDIM, KMAX , & !DD dimensions + GTU , GTV , & ! modified + GDU , GDV , & ! input + DELPI , GMFLX , GMFX0 , & ! input + KTMXT , CPRES , kb, ISTS , IENS ) ! input + + endif +! +! for now the following routines appear to be of no consequence to AW - DD +! + if (.not. do_aw .or. .not. flx_form) then +! Tracer Updraft properties +! ------------- + CALL CUMUPR(im , IJSDIM, KMAX , NTR , & !DD dimensions + GTQ , GPRCC , & ! modified + GDQ , CBMFX , & ! input + GCYM , GCYT , GCQT , GCLT , GCIT , & ! input + GTPRT , GTEVP , GTPRC0, & ! input + KB , KBMX , KT , KTMX , KTMXT , & ! input + DELPI , OTSPT1, ISTS , IENS, & ! input + fscav , fswtr, nctp) +! +! Tracer Change due to Downdraft +! --------------- + CALL CUMDNR(im ,IJSDIM , KMAX , NTR , & !DD dimensions + GTQ , & ! modified + GDQ , GMDD , DELPI , & ! input + KTMXT , OTSPT1, ISTS , IENS ) ! input +!! +!! Tracer change due to Subsidence +!! --------------- +!! This will be done by cumsbh, now DD 20170907 +! CALL CUMSBR(im , IJSDIM, KMAX , NTR , & !DD dimensions +! GTQ , & ! modified +! GDQ , DELPI , & ! input +! GMFLX , KTMXT , OTSPT2, & ! input +! ISTS , IENS ) ! input + + endif + +! if this tracer not advected zero it out + DO n = ntrq,NTR + if (.not. OTSPT2(n)) then + DO K=1,KMAX + DO I=ISTS,IENS + gtq(i,k,n) = 0.0 + ENDDO + ENDDO + endif + ENDDO + + if(do_aw .and. flx_form) then ! compute AW tendencies + ! AW lump all heating together, compute qv term do k=1,kmax do i=ists,iens dqevap(i,k) = - dtevap(i,k)*cpoel - dtsubl(i,k)*cpoesub @@ -1352,89 +1342,65 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions dtsubl(i,k) = zero enddo enddo + do i=1,ijsdim + moistening_aw(i) = zero + enddo + tem2 = one / delta + DO K=1,KMAX + DO I=ISTS,IENS + tem = frzterm(i,k)*cpoEMELT - prectermfrz(i,k) + gtt(i,k) = dtdwn(i,k) + sfluxterm(i,k) + condtermt(i,k) & + + dtmelt(i,k) + dtevap(i,k) + gtq(i,k,1) = dqvdwn(i,k) + qvfluxterm(i,k) + condtermq(i,k) & + + dqevap(i,k) + gtq(i,k,itl) = dqldwn(i,k) + qlfluxterm(i,k) - condtermq(i,k) & + - prectermq(i,k) - tem + gtq(i,k,iti) = dqidwn(i,k) + qifluxterm(i,k) + tem -! do i=1,ijsdim -! moistening_aw(i) = zero -! enddo -! DO K = 1, KMAX -! DO I = ISTS, IENS -! tem = frzterm(i,k)*cpoEMELT - prectermfrz(i,k) -! gtt(i,k) = dtdwn(i,k) + sfluxterm(i,k) + condtermt(i,k) & -! + dtmelt(i,k) + dtevap(i,k) -! gtq(i,k,1) = dqvdwn(i,k) + qvfluxterm(i,k) + condtermq(i,k) & -! + dqevap(i,k) -! gtq(i,k,itl) = dqldwn(i,k) + qlfluxterm(i,k) - condtermq(i,k) & -! - prectermq(i,k) - tem -! gtq(i,k,iti) = dqidwn(i,k) + qifluxterm(i,k) + tem ! detrainment terms get zeroed ! gtldet(i,k) = zero ! gtidet(i,k) = zero -! column-integrated total water tendency - used to impose water conservation -! moistening_aw(i) = moistening_aw(i) & -! + (gtq(i,k,1)+gtq(i,k,itl)+gtq(i,k,iti)) * delp(i,k)*gravi -! ENDDO -! ENDDO -! -! This code ensures conservation of water. In fact, no adjustment of the precip -! is occuring now which is a good sign! DD -! DO I=ISTS,IENS -! if(gprcp(i,1)+gsnwp(i,1) > 1.e-12_r8) then -! moistening_aw(i) = - moistening_aw(i) / (gprcp(i,1)+gsnwp(i,1)) -! endif -! if (abs(1.0-moistening_aw(i)) > 0.3 .and. gprcp(i,1) > 0.0) & -! write(1000+mype,*)' moistening_aw=', & -! moistening_aw(i),' i=',i,' xlon=',xlon(i),' xlat=',xlat(i),' kdt=',kdt& -! , ' gprcp=',gprcp(i,1:5) -! ENDDO -! write(1000+mype,*)' moistening_aw=',moistening_aw -! do k=1,kmax -! DO I = ISTS, IENS -! gprcp(i,k) = gprcp(i,k) * moistening_aw(i) -! gsnwp(i,k) = gsnwp(i,k) * moistening_aw(i) -! ENDDO -! enddo -! else + tem1 = - gdq(i,k,itl)*tem2 + if (gtq(i,k,itl) < tem1) then + tem3 = gtq(i,k,itl) - tem1 + gtq(i,k,1) = gtq(i,k,1) + tem3 + gtq(i,k,itl) = tem1 + gtt(i,k) = gtt(i,k) - elocp*tem3 + endif + tem1 = - gdq(i,k,iti)*tem2 + if (gtq(i,k,iti) < tem1) then + tem3 = gtq(i,k,iti) - tem1 + gtq(i,k,1) = gtq(i,k,1) + tem3 + gtq(i,k,iti) = tem1 + gtt(i,k) = gtt(i,k) - esubocp*tem3 + endif + tem1 = - gdq(i,k,1)*tem2 + if (gtq(i,k,1) < tem1) then + gtt(i,k) = gtt(i,k) + elocp*(gtq(i,k,1)-tem1) + gtq(i,k,1) = tem1 + endif + +! column-integrated total water tendency - to be used to impose water conservation + moistening_aw(i) = moistening_aw(i) & + + (gtq(i,k,1)+gtq(i,k,itl)+gtq(i,k,iti)) * delp(i,k) * gravi + ENDDO + ENDDO -! Cloud Subsidence Heating - CALL CUMSBH(IM , IJSDIM, KMAX , NTR , & !DD dimensions - GTT , GTQ , & ! modified -! GTT , GTQ , GTQI , & ! modified - GTU , GTV , & ! modified - GDH , GDQ , GDQ(1,1,iti) , & ! input - GDU , GDV , & ! input - DELP , GMFLX , GMFX0 , & ! input - KTMXT , CPRES , ISTS , IENS ) ! input +! replace tracer tendency only if to be advected. + DO n = ntrq,NTR + if (OTSPT2(n)) then + DO K=1,KMAX + DO I=ISTS,IENS + gtq(i,k,n) = dtrdwn(i,k,n) + trfluxterm(i,k,n) + ENDDO + ENDDO + endif + ENDDO -! if (lprnt) write(0,*)' after cumsbh gtqi=',gtq(ipr,:,2) -! endif -! -! for now the following routines appear to be of no consequence to AW - DD -! -! Tracer Updraft - CALL CUMUPR(im , IJSDIM, KMAX , NTR , & !DD dimensions - GTQ , GPRCC , & ! modified - GDQ , CBMFX , ELAM , GDZ , GDZM , & ! input - GCYM , GCYT , GCQT , GCLT , GCIT , & ! input - GTPRT , GTEVP , GTPRC0, & ! input - KB , KBMX , KT , KTMX , KTMXT , & ! input - DELP , OTSPT1, ISTS , IENS, & ! input - fscav, fswtr, nctp) -! -! Tracer Downdraft - CALL CUMDNR(im ,IJSDIM , KMAX , NTR , & !DD dimensions - GTQ , & ! modified - GDQ , GMDD , DELP , & ! input - KTMXT , OTSPT1, ISTS , IENS ) ! input -! -! Tracer Subsidence - CALL CUMSBR(im , IJSDIM,KMAX , NTR , & !DD dimensions - GTQ , & ! modified - GDQ , DELP , & ! input - GMFLX , KTMXT , OTSPT2, & ! input - ISTS , IENS ) ! input + endif ! if (do_aw) -! if (lprnt) write(0,*)' after cumsbr gtqi=',gtq(ipr,:,2) +!!!! this section may need adjustment for cloud ice and water with flux_form ! ! do k=1,kmax ! do i=ISTS,IENS @@ -1447,6 +1413,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions GTQ , & ! modified GDQ , DELP , DELTA , KTMXT , IMFXR, & ! input ISTS , IENS ) ! input + ! ! do k=1,kmax ! do i=ISTS,IENS @@ -1460,6 +1427,8 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! GDQ(1,1,ITL), DELP, DELTA, KTMXT, IMFXR(ITL), & ! input ! ISTS , IENS ) ! input ! +!!!!! end fixer section + DO K=1,KMAX DO I=ISTS, IENS ! GTLDET(I,k) = GTQL(I,k) - GTQ(I,k,ITL) - GTIDET(I,k) @@ -1485,67 +1454,7 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ENDDO ENDDO - -! here we substitute the AW tendencies into tendencies to be passed out - if(do_aw) then - do i=1,ijsdim - moistening_aw(i) = zero - enddo - tem2 = one / delta - DO K=1,KMAX - DO I=ISTS,IENS - tem = frzterm(i,k)*cpoEMELT - prectermfrz(i,k) - gtt(i,k) = dtdwn(i,k) + sfluxterm(i,k) + condtermt(i,k) & - + dtmelt(i,k) + dtevap(i,k) - gtq(i,k,1) = dqvdwn(i,k) + qvfluxterm(i,k) + condtermq(i,k) & - + dqevap(i,k) - gtq(i,k,itl) = dqldwn(i,k) + qlfluxterm(i,k) - condtermq(i,k) & - - prectermq(i,k) - tem - gtq(i,k,iti) = dqidwn(i,k) + qifluxterm(i,k) + tem -! detrainment terms get zeroed -! gtldet(i,k) = zero -! gtidet(i,k) = zero - tem1 = - gdq(i,k,itl)*tem2 - if (gtq(i,k,itl) < tem1) then - tem3 = gtq(i,k,itl) - tem1 - gtq(i,k,1) = gtq(i,k,1) + tem3 - gtq(i,k,itl) = tem1 - gtt(i,k) = gtt(i,k) - elocp*tem3 - endif - tem1 = - gdq(i,k,iti)*tem2 - if (gtq(i,k,iti) < tem1) then - tem3 = gtq(i,k,iti) - tem1 - gtq(i,k,1) = gtq(i,k,1) + tem3 - gtq(i,k,iti) = tem1 - gtt(i,k) = gtt(i,k) - esubocp*tem3 - endif -! tem1 = - gdq(i,k,1)*tem2 -! if (gtq(i,k,1) < tem1) then -! gtt(i,k) = gtt(i,k) + elocp*(gtq(i,k,1)-tem1) -! gtq(i,k,1) = tem1 -! endif - -! column-integrated total water tendency - to be used to impose water conservation - moistening_aw(i) = moistening_aw(i) & - + (gtq(i,k,1)+gtq(i,k,itl)+gtq(i,k,iti)) * delp(i,k)/grav - ENDDO - ENDDO - endif - -! if (lprnt) then -! write(0,*)' after doaw dqvdwn=',dqvdwn(ipr,:) -! write(0,*)' after doaw qvfluxterm=',qvfluxterm(ipr,:) -! write(0,*)' after doaw dqevap=',dqevap(ipr,:) -! write(0,*)' after doaw condtermq=',condtermq(ipr,:) -! write(0,*)' after doaw dqidwn=',dqidwn(ipr,:) -! write(0,*)' after doaw qifluxterm=',qifluxterm(ipr,:) -! write(0,*)' after doaw prectermfrz=',prectermfrz(ipr,:) -! write(0,*)' after doaw frzterm=',frzterm(ipr,:) -! write(0,*)' after doaw gtqv=',gtq(ipr,:,1) -! write(0,*)' after doaw gtqi=',gtq(ipr,:,2) -! write(0,*)' after doaw gtql=',gtq(ipr,:,3) -! endif ! DO I=ISTS,IENS HBGT(I) = HBGT(I) - EMELT*GSNWC(I) @@ -1573,35 +1482,22 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions ! ! This code ensures conservation of water. In fact, no adjustment of the precip ! is occuring now which is a good sign! DD - if(do_aw .and. adjustp) then + if(do_aw .and. flx_form .and. adjustp) then DO I = ISTS, IENS if(gprcp(i,1)+gsnwp(i,1) > 1.e-12_r8) then moistening_aw(i) = - moistening_aw(i) / (gprcp(i,1)+gsnwp(i,1)) + else + moistening_aw(i) = 1.0 endif ENDDO do k=1,kmax DO I = ISTS, IENS - gprcp(i,k) = gprcp(i,k) * moistening_aw(i) - gsnwp(i,k) = gsnwp(i,k) * moistening_aw(i) + gprcp(i,k) = max(0.0, gprcp(i,k) * moistening_aw(i)) + gsnwp(i,k) = max(0.0, gsnwp(i,k) * moistening_aw(i)) ENDDO enddo -! if (lprnt) then -! write(1000+mype,*)' moistening_aw=',moistening_aw(1:ijsdim) -! write(1000+mype,*)' gprcp=',gprcp(1:ijsdim,1) -! endif - endif - - -! commnting out becasue these are not used -! DO K=1,KMAX -! kp1 = min(k+1,kmax) -! DO I=ISTS,IENS -! GPRCPF(I,K) = half * (GPRCP(I,K) + GPRCP(I,KP1)) -! GSNWPF(I,K) = half * (GSNWP(I,K) + GSNWP(I,KP1)) -! ENDDO -! ENDDO ! do i=ISTS,IENS GPRCC(I,1) = GPRCP(I,1) @@ -1613,49 +1509,19 @@ SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions enddo enddo ! - -!COSP -!necessary? -! DO K=1,KMAX -! DO I=ISTS,IENS -! QLIQC(I,K) = QLIQ(I,K) -! QICEC(I,K) = QICE(I,K) -! ENDDO -! ENDDO -! -! IF ( OOUT1 .OR. OOUT2 ) THEN - DO I=ISTS,IENS - CAPE(i) = zero - CIN(i) = zero - JBUOY(i) = 0 - enddo - DO K=2,KMAX - DO I=ISTS,IENS - IF (K >= KB(I)) THEN - BUOY = (GDH(I,1)-GDHS(I,K)) / ((one+ELOCP*FDQS(I,K)) * CP*GDT(I,K)) - ELSE - BUOY = (GDS(I,1)-GDS(I,K)) / (CP*GDT(I,K)) - END IF - DELZ = GDZM(I,K+1) - GDZM(I,K) - IF (BUOY > zero .AND. JBUOY(I) /= 0) THEN - CAPE(I) = CAPE(I) + BUOY*GRAV*DELZ - JBUOY(I) = 2 - ELSEIF (BUOY < zero .AND. JBUOY(I) /= 2) THEN - CIN(I) = CIN(I) - BUOY*GRAV*DELZ - JBUOY(I) = 1 - ENDIF - ENDDO - ENDDO - DO I=ISTS,IENS - IF (JBUOY(I) /= 2) CIN(I) = -999.D0 - ENDDO - !DD provide GFS with a separate downdraft mass flux DO K=1,KMAX DO I=ISTS,IENS GMFX1(I,K) = GMFX0(I,K) - GMFLX(I,K) ENDDO ENDDO +! + if (do_aw .and. flx_form) then + deallocate(sfluxterm, qvfluxterm, qlfluxterm, qifluxterm,& + condtermt, condtermq, frzterm, prectermq, & + prectermfrz, dtdwn, dqvdwn, dqldwn, & + dqidwn, trfluxterm, dtrdwn) + endif ! END SUBROUTINE CS_CUMLUS @@ -1663,16 +1529,22 @@ END SUBROUTINE CS_CUMLUS SUBROUTINE CUMBAS & !! cloud base ( IJSDIM, KMAX , & !DD dimensions KB , GCYM , KBMX , & ! output + ntr , ntrq , & GCHB , GCWB , GCUB , GCVB , & ! output - GCIB , & ! output + GCIB , gctrb, & ! output GDH , GDW , GDHS , GDQS , & ! input GDQI , GDU , GDV , GDZM , & ! input GDPM , FDQS , GAM , & ! input - ISTS , IENS , gctbl, gcqbl ,gdq, gcwbl, gcqlbl, gcqibl ) ! input !DDsigmadiag add updraft profiles below cloud base + lprnt, ipr, & + ISTS , IENS , gctbl, gcqbl ,gdq, & + gcwbl, gcqlbl, gcqibl, gctrbl ) ! input !DDsigmadiag add updraft profiles below cloud base ! ! IMPLICIT NONE - INTEGER, INTENT(IN) :: IJSDIM, KMAX ! DD, for GFS, pass in + integer, parameter :: crtrh=0.70 + INTEGER, INTENT(IN) :: IJSDIM, KMAX , ntr, ntrq ! DD, for GFS, pass in + integer ipr + logical lprnt ! ! [OUTPUT] INTEGER KB (IJSDIM) ! cloud base @@ -1683,15 +1555,17 @@ SUBROUTINE CUMBAS & !! cloud base REAL(r8) GCUB (IJSDIM) ! cloud base U REAL(r8) GCVB (IJSDIM) ! cloud base V REAL(r8) GCIB (IJSDIM) ! cloud base ice + REAL(r8) GCtrB (IJSDIM,ntrq:ntr) ! cloud base tracer !DDsigma added to arglist for AW, subcloud updraft profiles: temperature, water vapor ! total water, cloud water, and cloud ice respectively - REAL(r8), dimension(ijsdim,kmax) :: gctbl, gcqbl, gcwbl, gcqlbl, gcqibl !DDsigmadiag + REAL(r8), dimension(ijsdim,kmax) :: gctbl, gcqbl, gcwbl, gcqlbl, gcqibl !DDsigmadiag + REAL(r8), dimension(ijsdim,kmax,ntrq:ntr) :: gctrbl !DDsigmadiag ! ! [INPUT] REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy REAL(r8) GDW (IJSDIM, KMAX) ! total water - REAL(r8) GDq (IJSDIM, KMAX) ! water vapor !DDsigmadiag + REAL(r8) GDq (IJSDIM, KMAX, ntr) ! water vapor and tracer REAL(r8) GDHS (IJSDIM, KMAX) ! saturate MSE REAL(r8) GDQS (IJSDIM, KMAX) ! saturate humidity REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice @@ -1706,10 +1580,11 @@ SUBROUTINE CUMBAS & !! cloud base ! [INTERNAL WORK] REAL(r8) CBASE (IJSDIM) ! one over cloud base height ! REAL(r8) CBASEP(IJSDIM) ! cloud base pressure - REAL(r8) DELZ, QSL, GAMX, wrk - REAL(r8), dimension(ijsdim,kmax) :: gchbl !DDsigmadiag - real(r8), dimension(ijsdim) :: gcqb - INTEGER I, K, kp1 + REAL(r8) DELZ, GAMX, wrk +! REAL(r8) DELZ, QSL, GAMX, wrk +! REAL(r8), dimension(ijsdim,kmax) :: gchbl !DDsigmadiag + real(r8), dimension(ijsdim) :: gcqb, tx1, spbl, qsl + INTEGER I, K, kp1, n ! ! [INTERNAL PARM] INTEGER :: KMAXM1 @@ -1721,7 +1596,8 @@ SUBROUTINE CUMBAS & !! cloud base KMAXM1 = KMAX-1 KLCLB = 1 ! LCL base level KCB = 0 ! fix cloud bottom - KBMAX = KMAXM1 ! cloud base max +! KBMAX = KMAXM1 ! cloud base max + KBMAX = KMAX/2 ! cloud base max KBOFS = 0 ! cloud base offset ! do k=1,kmax @@ -1736,24 +1612,71 @@ SUBROUTINE CUMBAS & !! cloud base ENDDO ELSE DO I=ISTS,IENS - KB(I) = KBMAX +! KB(I) = KBMAX + KB(I) = -1 + tx1(i) = one / gdpm(i,1) ENDDO - DO K=KBMAX-1,KLCLB+1,-1 + DO K=KLCLB+1,KBMAX-1 DO I=ISTS,IENS - GAMX = FDQS(I,K) / (one+GAM(I,K)) * oneocp - QSL = GDQS(I,K) + GAMX * (GDH(I,KLCLB)-GDHS(I,K)) - IF (GDW(I,KLCLB) >= QSL) THEN + GAMX = FDQS(I,K) / (one+GAM(I,K)) * oneocp + QSL(i) = GDQS(I,K) + GAMX * (GDH(I,KLCLB)-GDHS(I,K)) + spbl(i) = one - gdpm(i,k) * tx1(i) + IF (GDW(I,KLCLB) >= QSL(i) .and. kb(i) < 0 & + .and. spbl(i) >= spblcrit) THEN +! .and. spbl(i) >= spblcrit .and. spbl(i) < spblcrit*10.0) THEN KB(I) = K + KBOFS ENDIF ENDDO ENDDO + DO K=KLCLB+1,KBMAX-1 + DO I=ISTS,IENS + spbl(i) = one - gdpm(i,k) * tx1(i) + IF (kb(i) > k .and. spbl(i) > spblcrit*5.0) THEN + KB(I) = K + ENDIF + ENDDO + ENDDO +! DO K=KBMAX-1,KLCLB+1,-1 +! DO I=ISTS,IENS +! GAMX = FDQS(I,K) / (one+GAM(I,K)) * oneocp +! QSL(i) = GDQS(I,K) + GAMX * (GDH(I,KLCLB)-GDHS(I,K)) +! spbl(i) = one - gdpm(i,k) * tx1(i) +! IF (GDW(I,KLCLB) >= QSL(i) .and. spbl(i) >= spblcrit & +! .and. spbl(i) < spblcrit*6.0) THEN +! .and. spbl(i) < spblcrit*8.0) THEN +! KB(I) = K + KBOFS +! ENDIF +! ENDDO +! if(lprnt) write(0,*)' k=',k,' gdh1=',gdh(ipr,klclb),' gdhs=',gdhs(ipr,k),' kb=',kb(ipr) & +! ,' GDQS=',GDQS(ipr,k),' GDW=',GDW(ipr,KLCLB),' gdpm=',gdpm(ipr,k),' spbl=',spbl(ipr),' qsl=',qsl(ipr) +! ENDDO ENDIF +! + do i=ists,iens + tx1(i) = zero + qsl(i) = zero + enddo + do k=1,kbmax + do i=ists,iens + if (k < kb(i)) then + tx1(i) = tx1(i) + gdw(i,k) * (GDZM(i,k+1)-GDZM(i,k)) + qsl(i) = qsl(i) + gdqs(i,k) * (GDZM(i,k+1)-GDZM(i,k)) + endif + enddo + enddo + do i=ists,iens + if (qsl(i) > zero) tx1(i) = tx1(i) / qsl(i) + if (tx1(i) < crtrh) kb(i) = -1 + enddo + ! KBMX = 1 DO I=ISTS,IENS KBMX = MAX(KBMX, KB(I)) - CBASE (I) = one / (GDZM(I,KB(I)) - GDZM(I,1)) -! CBASEP(I) = GDPM(I,KB(I)) + if (kb(i) > 0) then + CBASE (I) = one / (GDZM(I,KB(I)) - GDZM(I,1)) +! CBASEP(I) = GDPM(I,KB(I)) + endif ENDDO ! DO K=1,KBMX @@ -1772,9 +1695,14 @@ SUBROUTINE CUMBAS & !! cloud base GCIB(I) = zero GCQB(I) = zero ENDDO + do n = ntrq,ntr + DO I=ISTS,IENS + GCtrB(I,n) = zero + enddo + enddo do k=1,kmax do i=ists,iens - GChbl(i,k) = zero +! GChbl(i,k) = zero gcqbl(i,k) = zero gcqlbl(i,k) = zero gcqibl(i,k) = zero @@ -1782,6 +1710,13 @@ SUBROUTINE CUMBAS & !! cloud base gcwbl(i,k) = zero enddo enddo +! do n=ntrq,ntr +! do k=1,kmax +! do i=ists,iens +! gtrqbl(i,k,n) = zero +! enddo +! enddo +! enddo ! DO K=1,KBMX kp1 = min(k+1, kmax) @@ -1793,137 +1728,146 @@ SUBROUTINE CUMBAS & !! cloud base GCUB(I) = GCUB(I) + DELZ * GDU (I,K) GCVB(I) = GCVB(I) + DELZ * GDV (I,K) GCIB(I) = GCIB(I) + DELZ * GDQI(I,K) - GCqB(I) = GCqB(I) + DELZ * GDQ (I,K) + GCqB(I) = GCqB(I) + DELZ * GDQ (I,K,1) +! do n = ntrq,ntr +! GCtrB(I,n) = GCtrB(I,n) + DELZ * GDQ (I,K,n) +! enddo ! get subcloud profiles to pass out and do AW eddy flux tendencies ! removing the normalized mass flux weighting wrk = one / gcym(i,kp1) - gchbl(i,kp1) = gchb(i) * wrk +! gchbl(i,kp1) = gchb(i) * wrk gcqbl(i,kp1) = gcqb(i) * wrk gcqibl(i,kp1) = gcib(i) * wrk gcwbl(i,kp1) = gcwb(i) * wrk gcqlbl(i,kp1) = gcwbl(i,kp1) - (gcqibl(i,kp1)+gcqbl(i,kp1)) - gctbl(i,kp1) = (gchbl(i,kp1) - grav*gdzm(i,kp1) - el*gcqbl(i,kp1)) * oneocp +! gctbl(i,kp1) = (gchbl(i,kp1) - grav*gdzm(i,kp1) - el*gcqbl(i,kp1)) * oneocp + gctbl(i,kp1) = (gchb(i)*wrk - grav*gdzm(i,kp1) - el*gcqbl(i,kp1)) * oneocp +! tracers + do n=ntrq,ntr + GCtrB(I,n) = GCtrB(I,n) + DELZ * GDQ (I,K,n) + GCtrBl(I,kp1,n) = gctrb(i,n) * wrk + enddo ENDIF ENDDO ENDDO ! END SUBROUTINE CUMBAS !*********************************************************************** - SUBROUTINE CUMUP & !! in-cloud properties - ( IJSDIM, KMAX , NTR , & !DD dimensions - ACWF , ELAM , & ! output - GCLZ , GCIZ , GPRCIZ, GSNWIZ, & ! output - GCYT , GCHT , GCQT , & ! output - GCLT , GCIT , GTPRT , & ! output - GCUT , GCVT , & ! output - KT , KTMX , & ! output - GCYM , & ! modified - wcv , & ! !DDsigma new output - GCHB , GCWB , GCUB , GCVB , & ! input !DDsigmadiag - GCIB , & ! input - GDU , GDV , GDH , GDW , & ! input - GDHS , GDQS , GDT , GDTM , & ! input - GDQ , GDQI , GDZ , GDZM , & ! input - GDPM , FDQS , GAM , GDZTR , & ! input - CPRES , WCB , & ! input -! CPRES , WCB , ERMR , & ! input - KB , CTP , ISTS , IENS, & ! input - gctm , gcqm, gcwm, gchm, gcwt, gclm, gcim, & - cbmfx , dtcond, dqcond, dtfrz ) !DDsigmadiag + SUBROUTINE CUMUP & !! in-cloud properties + ( IJSDIM, KMAX , NTR , ntrq , & !DD dimensions + ACWF , & ! output + GCLZ , GCIZ , GPRCIZ, GSNWIZ, & ! output + GCYT , GCHT , GCQT , & ! output + GCLT , GCIT , GTPRT , & ! output + GCUT , GCVT , gctrt , & ! output + KT , KTMX , & ! output + GCYM , & ! modified + wcv , & ! !DDsigma new output + GCHB , GCWB , GCUB , GCVB , & ! input !DDsigmadiag + GCIB , gctrb , & ! input + GDU , GDV , GDH , GDW , & ! input + GDHS , GDQS , GDT , GDTM , & ! input + GDQ , GDQI , GDZ , GDZM , & ! input + GDPM , FDQS , GAM , GDZTR , & ! input + CPRES , WCB , & ! input +! CPRES , WCB , ERMR , & ! input + KB , CTP , ISTS , IENS, & ! input + gctm , gcqm , gcwm , gchm, gcwt,& + gclm, gcim , gctrm , lprnt, ipr ) ! !DD AW the above line of arguments were previously local, and often scalars. ! Dimensions were added to them to save profiles for each grid point. ! IMPLICIT NONE - INTEGER, INTENT(IN) :: IJSDIM, KMAX, NTR ! DD, for GFS, pass in + INTEGER, INTENT(IN) :: IJSDIM, KMAX, NTR, ipr , ntrq ! DD, for GFS, pass in + logical :: lprnt ! ! [OUTPUT] - REAL(r8) ACWF (IJSDIM) ! cloud work function - REAL(r8) ELAM (IJSDIM, KMAX) ! entrainment (rate*massflux) - REAL(r8) GCLZ (IJSDIM, KMAX) ! cloud liquid water*eta - REAL(r8) GCIZ (IJSDIM, KMAX) ! cloud ice*eta - REAL(r8) GPRCIZ(IJSDIM, KMAX) ! rain generation*eta - REAL(r8) GSNWIZ(IJSDIM, KMAX) ! snow generation*eta - REAL(r8) GCYT (IJSDIM) ! norm. mass flux @top - REAL(r8) GCHT (IJSDIM) ! cloud top MSE*eta - REAL(r8) GCQT (IJSDIM) ! cloud top moisture*eta - REAL(r8) GCLT (IJSDIM) ! cloud top liquid water*eta - REAL(r8) GCIT (IJSDIM) ! cloud top ice*eta - REAL(r8) GTPRT (IJSDIM) ! cloud top (rain+snow)*eta - REAL(r8) GCUT (IJSDIM) ! cloud top u*eta - REAL(r8) GCVT (IJSDIM) ! cloud top v*eta - REAL(r8) GCwT (IJSDIM) ! cloud top v*eta - INTEGER KT (IJSDIM) ! cloud top - INTEGER KTMX ! max of cloud top - REAL(r8) WCV (IJSDIM, KMAX) ! updraft velocity (half lev) !DD sigma make output + REAL(r8) ACWF (IJSDIM) ! cloud work function + REAL(r8) GCLZ (IJSDIM, KMAX) ! cloud liquid water*eta + REAL(r8) GCIZ (IJSDIM, KMAX) ! cloud ice*eta + REAL(r8) GPRCIZ(IJSDIM, KMAX) ! rain generation*eta + REAL(r8) GSNWIZ(IJSDIM, KMAX) ! snow generation*eta + REAL(r8) GCYT (IJSDIM) ! norm. mass flux @top + REAL(r8) GCHT (IJSDIM) ! cloud top MSE*eta + REAL(r8) GCQT (IJSDIM) ! cloud top moisture*eta + REAL(r8) GCLT (IJSDIM) ! cloud top liquid water*eta + REAL(r8) GCIT (IJSDIM) ! cloud top ice*eta + REAL(r8) GCtrT (IJSDIM, ntrq:ntr) ! cloud top tracer*eta + REAL(r8) GTPRT (IJSDIM) ! cloud top (rain+snow)*eta + REAL(r8) GCUT (IJSDIM) ! cloud top u*eta + REAL(r8) GCVT (IJSDIM) ! cloud top v*eta + REAL(r8) GCwT (IJSDIM) ! cloud top v*eta + INTEGER KT (IJSDIM) ! cloud top + INTEGER KTMX ! max of cloud top + REAL(r8) WCV (IJSDIM, KMAX) ! updraft velocity (half lev) !DD sigma make output ! ! [MODIFIED] - REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux + REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux ! ! [INPUT] - REAL(r8) GCHB (IJSDIM) ! MSE at cloud base - REAL(r8) GCWB (IJSDIM) ! total water @cloud base - REAL(r8) GCUB (IJSDIM) ! U at cloud base - REAL(r8) GCVB (IJSDIM) ! V at cloud base - REAL(r8) GCIB (IJSDIM) ! cloud ice at cloud base - REAL(r8) GDU (IJSDIM, KMAX) ! U - REAL(r8) GDV (IJSDIM, KMAX) ! V - REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy - REAL(r8) GDW (IJSDIM, KMAX) ! total water - REAL(r8) GDHS (IJSDIM, KMAX) ! saturation MSE - REAL(r8) GDQS (IJSDIM, KMAX) ! saturation q - REAL(r8) GDT (IJSDIM, KMAX) ! T - REAL(r8) GDTM (IJSDIM, KMAX+1) ! T (half lev) - REAL(r8) GDQ (IJSDIM, KMAX, NTR)! q !!DDsigmadiag - REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice - REAL(r8) GDZ (IJSDIM, KMAX) ! z - REAL(r8) GDZM (IJSDIM, KMAX+1) ! z (half lev) - REAL(r8) GDPM (IJSDIM, KMAX+1) ! p (half lev) + REAL(r8) GCHB (IJSDIM) ! cloud base Moist Static Energy + REAL(r8) GCWB (IJSDIM) ! cloud base total water + REAL(r8) GCUB (IJSDIM) ! cloud base U + REAL(r8) GCVB (IJSDIM) ! cloud base V + REAL(r8) GCIB (IJSDIM) ! cloud base ice + REAL(r8) GCtrB (IJSDIM,ntrq:ntr) ! cloud base tracers + REAL(r8) GDU (IJSDIM, KMAX) ! U + REAL(r8) GDV (IJSDIM, KMAX) ! V + REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy + REAL(r8) GDW (IJSDIM, KMAX) ! total water + REAL(r8) GDHS (IJSDIM, KMAX) ! saturation MSE + REAL(r8) GDQS (IJSDIM, KMAX) ! saturation q + REAL(r8) GDT (IJSDIM, KMAX) ! T + REAL(r8) GDTM (IJSDIM, KMAX+1) ! T (half lev) + REAL(r8) GDQ (IJSDIM, KMAX, NTR) ! q !!DDsigmadiag + REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice + REAL(r8) GDZ (IJSDIM, KMAX) ! z + REAL(r8) GDZM (IJSDIM, KMAX+1) ! z (half lev) + REAL(r8) GDPM (IJSDIM, KMAX+1) ! p (half lev) REAL(r8) FDQS (IJSDIM, KMAX) REAL(r8) GAM (IJSDIM, KMAX) - REAL(r8) GDZTR (IJSDIM) ! tropopause height - REAL(r8) CPRES ! pres. fac. for cum. fric. - REAL(r8) WCB(ijsdim) ! updraft velocity**2 @base -! REAL(r8) ERMR ! entrainment rate (ASMODE) + REAL(r8) GDZTR (IJSDIM) ! tropopause height + REAL(r8) CPRES ! pres. fac. for cum. fric. + REAL(r8) WCB(ijsdim) ! cloud base updraft velocity**2 +! REAL(r8) ERMR ! entrainment rate (ASMODE) INTEGER KB (IJSDIM) INTEGER CTP, ISTS, IENS ! ! [INTERNAL WORK] - REAL(r8) myGCHt ! cloud top h *eta (half lev) - REAL(r8) GCHMZ (IJSDIM, KMAX) ! cloud h *eta (half lev) - REAL(r8) GCWMZ (IJSDIM, KMAX) ! cloud Qt*eta (half lev) - REAL(r8) GCqMZ (IJSDIM, KMAX) ! cloud qv*eta (half lev) - REAL(r8) GCUMZ (IJSDIM, KMAX) ! cloud U *eta (half lev) - REAL(r8) GCVMZ (IJSDIM, KMAX) ! cloud V *eta (half lev) - REAL(r8) GCIMZ (IJSDIM, KMAX) ! cloud Qi*eta (half lev) - REAL(r8) GTPRMZ(IJSDIM, KMAX) ! rain+snow *eta (half lev) + REAL(r8) myGCHt ! cloud top h *eta (half lev) + REAL(r8) GCHMZ (IJSDIM, KMAX) ! cloud h *eta (half lev) + REAL(r8) GCWMZ (IJSDIM, KMAX) ! cloud Qt*eta (half lev) + REAL(r8) GCqMZ (IJSDIM, KMAX) ! cloud qv*eta (half lev) + REAL(r8) GCUMZ (IJSDIM, KMAX) ! cloud U *eta (half lev) + REAL(r8) GCVMZ (IJSDIM, KMAX) ! cloud V *eta (half lev) + REAL(r8) GCIMZ (IJSDIM, KMAX) ! cloud Qi*eta (half lev) + REAL(r8) GCtrMZ(IJSDIM, KMAX,ntrq:ntr)! cloud tracer*eta (half lev) + REAL(r8) GTPRMZ(IJSDIM, KMAX) ! rain+snow *eta (half lev) ! REAL(r8) BUOY (IJSDIM, KMAX) ! buoyancy - REAL(r8) BUOYM (IJSDIM, KMAX) ! buoyancy (half lev) - REAL(r8) WCM (IJSDIM, KMAX) ! updraft velocity**2 (half lev) + REAL(r8) BUOYM (IJSDIM, KMAX) ! buoyancy (half lev) + REAL(r8) WCM (IJSDIM, KMAX) ! updraft velocity**2 (half lev) !DD sigma make output REAL(r8) WCV ( IJSDIM, KMAX+1 ) !! updraft velocity (half lev) REAL(r8) GCY (IJSDIM, KMAX) ! norm. mass flux REAL(r8) ELAR (IJSDIM, KMAX) ! entrainment rate ! - REAL(r8) GCHM (IJSDIM, KMAX) ! cloud MSE (half lev) - REAL(r8) GCWM (IJSDIM, KMAX) ! cloud Qt (half lev) !DDsigmadiag - REAL(r8) GCTM (IJSDIM, KMAX) ! cloud T (half lev) !DDsigmadiag make output - REAL(r8) GCQM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output - REAL(r8) dtcond(IJSDIM, KMAX) ! in cloud condensation heating DDsigmadiag make output - REAL(r8) dqcond(IJSDIM, KMAX) ! in cloud condensation water vapor tendency !DDsigmadiag make output - REAL(r8) dtfrz (IJSDIM, KMAX) ! in cloud temperature tendency due to freezing !DDsigmadiag make output - REAL(r8) cbmfx (IJSDIM) ! cloud base mass flux !DDsigmadiag make output - REAL(r8) GCLM (IJSDIM, KMAX) ! cloud liquid ( half lev) - REAL(r8) GCIM (IJSDIM, KMAX) ! cloud ice (half lev) - REAL(r8) GCUM (IJSDIM, KMAX) ! cloud U (half lev) - REAL(r8) GCVM (IJSDIM, KMAX) ! cloud V (half lev) + REAL(r8) GCHM (IJSDIM, KMAX) ! cloud MSE (half lev) + REAL(r8) GCWM (IJSDIM, KMAX) ! cloud Qt (half lev) !DDsigmadiag + REAL(r8) GCTM (IJSDIM, KMAX) ! cloud T (half lev) !DDsigmadiag make output + REAL(r8) GCQM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GCLM (IJSDIM, KMAX) ! cloud liquid ( half lev) + REAL(r8) GCIM (IJSDIM, KMAX) ! cloud ice (half lev) + REAL(r8) GCUM (IJSDIM, KMAX) ! cloud U (half lev) + REAL(r8) GCVM (IJSDIM, KMAX) ! cloud V (half lev) + REAL(r8) GCtrM (IJSDIM, KMAX,ntrq:ntr) ! cloud tracer (half lev) ! REAL(r8), dimension(IJSDIM) :: WCM_, ELARM1, GDZMKB - REAL(r8) GDQSM, GDHSM, GDQM, GDSM, GDCM, FDQSM, GCCM, gdtrm, & + REAL(r8) GDQSM, GDHSM, GDQM, GDSM, GDCM, FDQSM, GCCM, & DELZ, ELADZ, DCTM , CPGMI, DELC, FICE, ELARM2,GCCMZ, & PRECR, GTPRIZ, DELZL, GCCT, DCT, WCVX, PRCZH, wrk - INTEGER K, I, kk, km1, kp1 + INTEGER K, I, kk, km1, kp1, n CHARACTER CTNUM*2 ! !DD#ifdef OPT_CUMBGT @@ -1939,27 +1883,21 @@ SUBROUTINE CUMUP & !! in-cloud properties ! ! [INTERNAL PARAM] - REAL(r8), SAVE :: CLMP -!DD REAL(r8) :: PRECZ0 = 1.5e3_r8 ! move to module scope for tuning -!DD REAL(r8) :: PRECZH = 4.e3_r8 ! move to module scope for tuning - REAL(r8) :: ZTREF = 1._r8 + REAL(r8), parameter :: ZTREF = 1._r8, ztrefi = one/ztref, & + ELAMIN = zero, ELAMAX = 4.e-3 ! min and max entrainment rate REAL(r8) :: PB = 1._r8 !m REAL(r8) :: TAUZ = 5.e3_r8 REAL(r8) :: TAUZ = 1.e4_r8 REAL(r8) :: ELMD = 2.4e-3 ! for Neggers and Siebesma (2002) - REAL(r8) :: ELAMIN = zero ! min. of entrainment rate - REAL(r8) :: ELAMAX = 4.e-3 ! max. of entrainment rate !m REAL(r8) :: ELAMAX = 5.e-3 ! max. of entrainment rate REAL(r8) :: WCCRT = zero !m REAL(r8) :: WCCRT = 0.01 REAL(r8) :: TSICE = 268.15_r8 ! compatible with macrop_driver REAL(r8) :: TWICE = 238.15_r8 ! compatible with macrop_driver - REAL(r8) :: EPSln = 1.e-10 +! REAL(r8) :: EPSln = 1.e-10 -! REAL(r8) :: esat, tem - REAL(r8) :: esat, tem, rhs_h, rhs_q - - LOGICAL, SAVE :: OFIRST = .TRUE. + REAL(r8) :: esat, tem +! REAL(r8) :: esat, tem, rhs_h, rhs_q ! ! [INTERNAL FUNC] REAL(r8) FPREC ! precipitation ratio in condensate @@ -1973,11 +1911,6 @@ SUBROUTINE CUMUP & !! in-cloud properties ! ! Note: iteration is not made to diagnose cloud ice for simplicity ! - IF (OFIRST) THEN - CLMP = 2.D0*(one-CLMD)*PA - OFIRST = .FALSE. - ENDIF - do i=ists,iens ACWF (I) = zero GCYT (I) = zero @@ -1992,7 +1925,6 @@ SUBROUTINE CUMUP & !! in-cloud properties enddo do k=1,kmax do i=ists,iens - ELAM (I,k) = unset_r8 GCLZ (I,k) = zero GCIZ (I,k) = zero GPRCIZ(I,k) = zero @@ -2005,10 +1937,6 @@ SUBROUTINE CUMUP & !! in-cloud properties GCUMZ (I,k) = zero GCVMZ (I,k) = zero GTPRMZ(I,k) = zero - - dtcond(i,k) = zero - dqcond(i,k) = zero - dtfrz(i,k) = zero ! BUOY (I,k) = unset_r8 BUOYM (I,k) = unset_r8 @@ -2027,79 +1955,87 @@ SUBROUTINE CUMUP & !! in-cloud properties GCVM (I,k) = unset_r8 enddo enddo +! tracers + do n=ntrq,ntr + do i=ists,iens + GCtrT (I,n) = zero + enddo + do k=1,kmax + do i=ists,iens + GCTRM (I,k,n) = unset_r8 + enddo + enddo + enddo -!#ifdef SYS_SX - DO K=1,KMAX - DO I=ISTS, IENS - IF (K > KB(I)) THEN - GCYM(I,K) = zero - ENDIF - ENDDO - ENDDO -!#else -! DO I=ISTS,IENS -! GCYM(I,KB(I)+1:KMAX) = zero -! ENDDO -!#endif DO I=ISTS,IENS - GDZMKB(I) = GDZM(I,KB(I)) ! cloud base height + if (kb(i) > 0) then + GDZMKB(I) = GDZM(I,KB(I)) ! cloud base height + endif ENDDO ! ! < cloud base properties > ! DO I=ISTS,IENS K = KB(I) - GCHM(I,K) = GCHB(I) - GCWM(I,K) = GCWB(I) - WCM (I,K) = WCB(i) - GCUM(I,K) = GCUB(I) - GCVM(I,K) = GCVB(I) -! - esat = min(gdpm(i,k), fpvs(gdtm(i,k))) - GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 1.0) - gdsm = CP*GDTM(I,K) + GRAV*GDZMKB(I) ! dse - GDHSM = gdsm + EL*GDQSM ! saturated mse -! FDQSM = FDQSAT(GDTM(I,K), GDQSM) - tem = one / GDTM(I,K) - FDQSM = GDQSM * tem * (fact1 + fact2*tem) -! - tem = one / (CP+EL*FDQSM) - DCTM = (GCHB(I) - GDHSM) * tem - GCQM(I,K) = min(GDQSM + FDQSM*DCTM, GCWM(I,K)) - GCCM = MAX(GCWM(I,K)-GCQM(I,K), zero) -! GCTM(I,K) = GDT(I,K) + DCTM ! old - GCTM(I,K) = (GCHB(I) - gdsm - el*gcqm(i,k)) * oneocp + dctm ! new -! - GCIM(I,K) = FRICE(GCTM(I,K)) * GCCM ! cloud base ice - GCLM(I,K) = MAX(GCCM-GCIM(I,K), zero) ! cloud base liquid - GCHM(I,K) = GCHM(I,K) + EMELT * (GCIM(I,K)-GCIB(I)) - DCTM = (GCHM(I,K) - GDHSM) * tem -! GCTM(I,K) = dctm + GDT(I,K) + gocp*gdzm(i,k) !DD old AW convert to DSE - GCTM(I,K) = dctm + (GCHB(I) - el*gcqm(i,k)) * oneocp ! new, make dse -! - GDQM = half * (GDQ(I,K,1) + GDQ(I,K-1,1)) - GDCM = half * (GDQ(I,K,ITL) + GDQI(I,K) & - + GDQ(I,K-1,ITL) + GDQI(I,K-1)) + if (k > 0) then + GCHM(I,K) = GCHB(I) + GCWM(I,K) = GCWB(I) + WCM (I,K) = WCB(i) + GCUM(I,K) = GCUB(I) + GCVM(I,K) = GCVB(I) + do n = ntrq,ntr + GCtrM(I,K,n) = GCtrB(I,n) + enddo +! + esat = min(gdpm(i,k), fpvs(gdtm(i,k))) + GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 1.0) + gdsm = CP*GDTM(I,K) + GRAV*GDZMKB(I) ! dse + GDHSM = gdsm + EL*GDQSM ! saturated mse +! FDQSM = FDQSAT(GDTM(I,K), GDQSM) + tem = one / GDTM(I,K) + FDQSM = GDQSM * tem * (fact1 + fact2*tem) ! calculate d(qs)/dT +! + tem = one / (CP+EL*FDQSM) + DCTM = (GCHB(I) - GDHSM) * tem + GCQM(I,K) = min(GDQSM + FDQSM*DCTM, GCWM(I,K)) + GCCM = MAX(GCWM(I,K)-GCQM(I,K), zero) +! GCTM(I,K) = GDT(I,K) + DCTM ! old + GCTM(I,K) = (GCHB(I) - gdsm - el*gcqm(i,k)) * oneocp + dctm ! new +! + GCIM(I,K) = FRICE(GCTM(I,K)) * GCCM ! cloud base ice + GCLM(I,K) = MAX(GCCM-GCIM(I,K), zero) ! cloud base liquid + GCHM(I,K) = GCHM(I,K) + EMELT * (GCIM(I,K)-GCIB(I)) + DCTM = (GCHM(I,K) - GDHSM) * tem +! GCTM(I,K) = dctm + GDT(I,K) + gocp*gdzm(i,k) !DD old AW convert to DSE + GCTM(I,K) = dctm + (GCHB(I) - el*gcqm(i,k)) * oneocp ! new, make dse +! + GDQM = half * (GDQ(I,K,1) + GDQ(I,K-1,1)) + GDCM = half * (GDQ(I,K,ITL) + GDQI(I,K) & + + GDQ(I,K-1,ITL) + GDQI(I,K-1)) ! - BUOYM(I,K) = (DCTM/GDTM(I,K) + EPSVT*(GCQM(I,K)-GDQM) - GCCM + GDCM )*GRAV + BUOYM(I,K) = (DCTM/GDTM(I,K) + EPSVT*(GCQM(I,K)-GDQM) - GCCM + GDCM )*GRAV ! !DD#ifdef OPT_ASMODE !DD ELARM1(I) = ERMR !DD#elif defined OPT_NS02 !DD ELARM1(I) = ELMD / SQRT(WCM(I,K)) !DD#else - ELARM1(I) = CLMD*PA*BUOYM(I,K)/WCM(I,K) + ELARM1(I) = CLMD*PA*BUOYM(I,K)/WCM(I,K) !DD#endif - ELARM1(I) = MIN(MAX(ELARM1(I), ELAMIN), ELAMAX) -! - GCHMZ (I,K) = GCHM(I,K) - GCWMZ (I,K) = GCWM(I,K) - GCqMZ (I,K) = GCqM(I,K) - GCUMZ (I,K) = GCUM(I,K) - GCVMZ (I,K) = GCVM(I,K) - GCIMZ (I,K) = GCIM(I,K) - WCM_(I) = WCM(I,K) + ELARM1(I) = MIN(MAX(ELARM1(I), ELAMIN), ELAMAX) +! + GCHMZ (I,K) = GCHM(I,K) + GCWMZ (I,K) = GCWM(I,K) + GCqMZ (I,K) = GCqM(I,K) + GCUMZ (I,K) = GCUM(I,K) + GCVMZ (I,K) = GCVM(I,K) + GCIMZ (I,K) = GCIM(I,K) + WCM_(I) = WCM(I,K) + do n = ntrq,ntr + GCtrMZ (I,K,n) = GCtrM(I,K,n) + enddo + endif ENDDO ! ! < in-cloud properties > @@ -2107,7 +2043,7 @@ SUBROUTINE CUMUP & !! in-cloud properties DO K=3,KMAX km1 = k - 1 DO I=ISTS,IENS - IF (K > KB(I) .AND. WCM_(I) > WCCRT) THEN + IF (kb(i) > 0 .and. K > KB(I) .AND. WCM_(I) > WCCRT) THEN WCV(I,KM1) = SQRT(MAX(WCM_(I), zero)) DELZ = GDZM(I,K) - GDZM(I,KM1) GCYM(I,K) = GCYM(I,KM1) * EXP(ELARM1(I)*DELZ) @@ -2121,10 +2057,10 @@ SUBROUTINE CUMUP & !! in-cloud properties GDHSM = CP*GDTM(I,K ) + GRAV*GDZM(I,K) + EL*GDQSM ! FDQSM = FDQSAT(GDTM(I,K), GDQSM) tem = one / GDTM(I,K) - FDQSM = GDQSM * tem * (fact1 + fact2*tem) + FDQSM = GDQSM * tem * (fact1 + fact2*tem) ! calculate d(qs)/dT CPGMI = one / (CP + EL*FDQSM) - PRCZH = PRECZH * MIN(GDZTR(I)/ZTREF, one) + PRCZH = PRECZH * MIN(GDZTR(I)*ZTREFI, one) PRECR = FPREC(GDZM(I,K)-GDZMKB(I), PRCZH ) ! wrk = one / GCYM(I,K) @@ -2139,7 +2075,7 @@ SUBROUTINE CUMUP & !! in-cloud properties GCQMZ(i,k) = GCQMZ(i,k) + DELC ! FICE = FRICE(GDTM(I,K)+DCTM ) - GCIMZ(I,K) = FICE*GCCMZ + GCIMZ(I,K) = FICE * GCCMZ GSNWIZ(I,KM1) = FICE * (GTPRMZ(I,K)-GTPRMZ(I,KM1)) GCHMZ(I,K) = GCHMZ(I,K) + EMELT * (GCIMZ(I,K) + GSNWIZ(I,KM1) & - GCIMZ(I,KM1) - GDQI(I,KM1)*ELADZ) @@ -2186,12 +2122,14 @@ SUBROUTINE CUMUP & !! in-cloud properties ELAR(I,KM1) = half * (ELARM1(I) + ELARM2) GCYM(I,K) = GCYM(I,KM1) * EXP(ELAR(I,KM1)*DELZ) ELADZ = GCYM(I,K) - GCYM(I,KM1) - ELAM(I,KM1) = ELADZ / DELZ ! GCHMZ(I,K) = GCHMZ(I,KM1) + GDH(I,KM1)*ELADZ GCWMZ(I,K) = GCWMZ(I,KM1) + GDW(I,KM1)*ELADZ GCUMZ(I,K) = GCUMZ(I,KM1) + GDU(I,KM1)*ELADZ GCVMZ(I,K) = GCVMZ(I,KM1) + GDV(I,KM1)*ELADZ + do n = ntrq,ntr + GCtrMZ(I,K,n) = GCtrMZ(I,KM1,n) + GDq(I,KM1,n)*ELADZ + enddo ! wrk = one / GCYM(I,K) DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI @@ -2212,6 +2150,7 @@ SUBROUTINE CUMUP & !! in-cloud properties GCLM(I,K) = MAX(GCCM-GCIM(I,K), zero) GTPRIZ = GTPRMZ(I,K) - GTPRMZ(I,KM1) GSNWIZ(I,KM1) = FICE*GTPRIZ + GPRCIZ(I,KM1) = (one-FICE )*GTPRIZ GCHMZ(I,K) = GCHMZ(I,K) + EMELT*(GCIMZ(I,K) + GSNWIZ(I,KM1) & - GCIMZ(I,KM1) - GDQI(I,KM1)*ELADZ ) @@ -2223,6 +2162,9 @@ SUBROUTINE CUMUP & !! in-cloud properties GCWM(I,K) = GCWMZ(I,K)*wrk GCUM(I,K) = GCUMZ(I,K)*wrk GCVM(I,K) = GCVMZ(I,K)*wrk + do n = ntrq,ntr + GCtrM(I,K,n) = GCtrMZ(I,K,n)*wrk + enddo DELZL = GDZ(I,KM1)-GDZM(I,KM1) GCY (I,KM1) = GCYM(I,KM1) * EXP(ELAR(I,KM1)*DELZL) GCLZ(I,KM1) = half * (GCLM(I,K) + GCLM(I,KM1)) * GCY(I,KM1) @@ -2234,14 +2176,6 @@ SUBROUTINE CUMUP & !! in-cloud properties ELARM1(I) = ELARM2 WCM_(I) = WCM(I,K) - rhs_h = cbmfx(i)*(gchmz(i,k) - (gchmz(i,km1) + GDH(I,KM1)*ELADZ)) - rhs_q = cbmfx(i)*(gcwmz(i,k)-gcqmz(i,k) & - - (gcwmz(i,km1)-gcqmz(i,km1) & - + (GDw(I,KM1)-gdq(i,km1,1))*ELADZ)) - dqcond(i,km1) = -rhs_q - dtfrz(i,km1) = rhs_h*oneocp - dtcond(i,km1) = -ELocp*DQCOND(i,km1) - ENDIF ! IF (K > KB(I) .AND. WCM_(I) > WCCRT) THEN ENDDO ENDDO @@ -2253,10 +2187,12 @@ SUBROUTINE CUMUP & !! in-cloud properties enddo DO K=KMAX,2,-1 DO I=ISTS,IENS - IF (K > KB(I) .AND. KT(I) == -1 & - .AND. BUOYM(I,K) > zero .AND. WCM(I,K) > WCCRT) THEN - KT(I) = K - ENDIF + if (kb(i) > 0) then + IF (K > KB(I) .AND. KT(I) == -1 & + .AND. BUOYM(I,K) > zero .AND. WCM(I,K) > WCCRT) THEN + KT(I) = K + ENDIF + endif ENDDO ENDDO ! @@ -2277,12 +2213,9 @@ SUBROUTINE CUMUP & !! in-cloud properties GCIZ (I,K) = zero GPRCIZ(I,K) = zero GSNWIZ(I,K) = zero - dtcond(i,k) = 0.0 - dqcond(i,k) = 0.0 - dtfrz(i,k) = 0.0 enddo ELSE - do k=kb(i)+1,kmax + do k=1,kmax GCYM(I,K) = zero enddo do k=1,kmax @@ -2290,9 +2223,6 @@ SUBROUTINE CUMUP & !! in-cloud properties GCIZ (I,k) = zero GPRCIZ(I,k) = zero GSNWIZ(I,k) = zero - dtcond(i,k) = 0.0 - dqcond(i,k) = 0.0 - dtfrz(i,k) = 0.0 enddo ENDIF ENDDO @@ -2300,23 +2230,25 @@ SUBROUTINE CUMUP & !! in-cloud properties ! < cloud top properties > ! DO I=ISTS,IENS - IF (KT(I) > 0) THEN + IF (kb(i) > 0 .and. KT(I) > 0) THEN K = KT(I) kp1 = k + 1 GCYT(I) = GCY(I,K) ELADZ = GCYT(I) - GCYM(I,K) - ELAM(I,K) = ELADZ / (GDZ(I,K)-GDZM(I,K)) ! GCHT(I) = GCHMZ(I,K) + GDH(I,K)*ELADZ GCWT(i) = GCWMZ(I,K) + GDW(I,K)*ELADZ GCUT(I) = GCUMZ(I,K) + GDU(I,K)*ELADZ GCVT(I) = GCVMZ(I,K) + GDV(I,K)*ELADZ + do n = ntrq,NTR + GCtrT(I,n) = GCtrMZ(I,K,n) + GDq(I,K,n)*ELADZ + enddo ! DCT = (GCHT(I)/GCYT(I) - GDHS(I,K)) & / (CP*(one + GAM(I,K))) GCQT(I) = (GDQS(I,K) + FDQS(I,K)*DCT) * GCYT(I) GCQT(I) = MIN(GCQT(I), GCWT(i)) - PRCZH = PRECZH * MIN(GDZTR(I)/ZTREF, one) + PRCZH = PRECZH * MIN(GDZTR(I)*ZTREFI, one) GTPRT(I) = FPREC(GDZ(I,K)-GDZMKB(I), PRCZH) * (GCWT(i)-GCQT(I)) GTPRT(I) = MAX(GTPRT(I), GTPRMZ(I,K)) GCCT = GCWT(i) - GCQT(I) - GTPRT(I) @@ -2335,6 +2267,9 @@ SUBROUTINE CUMUP & !! in-cloud properties ! GCUT(I) = GCUT(I)*(one-CPRES) + GCY(I,K)*GDU(I,K)*CPRES GCVT(I) = GCVT(I)*(one-CPRES) + GCY(I,K)*GDV(I,K)*CPRES + do n = ntrq,NTR + GCtrT(I,n) = GCtrT(I,n)*(one-CPRES) + GCY(I,K)*GDq(I,K,n)*CPRES + enddo GCLZ(I,K) = GCLT(I) GCIZ(I,K) = GCIT(I) @@ -2347,14 +2282,10 @@ SUBROUTINE CUMUP & !! in-cloud properties gcqm(i,kp1) = gcqt(i)*wrk ! check this - oct17 2016 gcim(i,kp1) = gcit(i)*wrk gclm(i,kp1) = gclt(i)*wrk + do n = ntrq,NTR + gctrm(i,kp1,n) = gctrt(i,n)*wrk + enddo ! - rhs_q = cbmfx(i)*( gcwt(i)-gcqt(i) - (gcwmz(i,k)-gcqmz(i,k) & - + (GDw(I,K)-gdq(i,k,1))*ELADZ) ) - dqcond(i,k) = -rhs_q - rhs_h = cbmfx(i)*(gcht(i) - (gchmz(i,k) + GDH(I,K)*ELADZ)) - - dtfrz(i,k) = rhs_h * oneocp - dtcond(i,k) = -ELocp*DQCOND(i,k) ENDIF ENDDO ! @@ -2423,7 +2354,7 @@ SUBROUTINE CUMUP & !! in-cloud properties ! END SUBROUTINE CUMUP !*********************************************************************** - SUBROUTINE CUMBMX & !! cloud base mass flux + SUBROUTINE CUMBMX & !! cloud base mass flux ( IJSDIM, KMAX , & !DD dimensions CBMFX , & ! modified ACWF , GCYT , GDZM , & ! input @@ -2462,11 +2393,12 @@ SUBROUTINE CUMBMX & !! cloud base mass flux REAL(r8) :: RHMCRT = zero ! critical val. of RH@ all could ! REAL(r8) :: RHMCRT = 0.5_r8 ! critical val. of RH@ all could REAL(r8) :: ALP1 = zero - REAL(r8) :: TAUD = 1.e3_r8 +! REAL(r8) :: TAUD = 1.e3_r8 + REAL(r8) :: TAUD = 6.e2_r8 REAL(r8) :: ZFMAX = 3.5e3_r8 REAL(r8) :: ZDFMAX = 5.e2_r8 ! REAL(r8) :: FMAXP = 2._r8 - REAL(r8) :: EPSln = 1.e-10_r8 +! REAL(r8) :: EPSln = 1.e-10_r8 ! do i=ists,iens qx(i) = zero @@ -2475,7 +2407,7 @@ SUBROUTINE CUMBMX & !! cloud base mass flux ! DO K=1,KTMX DO I=ISTS,IENS - IF (K >= KB(I) .AND. K <= KT(I)) THEN + IF (kb(i) > 0 .and. K >= KB(I) .AND. K <= KT(I)) THEN QX (I) = QX (I) + GDW (I,K) * DELP(I,K) QSX(I) = QSX(I) + GDQS(I,K) * DELP(I,K) ENDIF @@ -2487,7 +2419,8 @@ SUBROUTINE CUMBMX & !! cloud base mass flux ! wrk = one + delt/(taud+taud) DO I=ISTS,IENS - IF (KT(I) > KB(I) .AND. RHM(I) >= RHMCRT) THEN + cbmfx(i) = max(cbmfx(i), zero) + IF (kb(i) > 0 .and. KT(I) > KB(I) .AND. RHM(I) >= RHMCRT) THEN ALP = ALP0 + ALP1 * (GDZM(I,KT(I))-GDZM(I,KB(I))) FMAX1 = (one - TANH((GDZM(I,1)-ZFMAX)/ZDFMAX)) * half ! FMAX1 = FMAX * FMAX1**FMAXP @@ -2505,12 +2438,12 @@ END SUBROUTINE CUMBMX !*********************************************************************** SUBROUTINE CUMFLX & !! cloud mass flux ( IM , IJSDIM, KMAX , & !DD dimensions - GMFLX , GPRCI , GSNWI , & ! output + GMFLX , GPRCI , GSNWI , CMDET, & ! output QLIQ , QICE , GTPRC0, & ! output CBMFX , GCYM , GPRCIZ, GSNWIZ, & ! input - GTPRT , GCLZ , GCIZ , & ! input + GTPRT , GCLZ , GCIZ , GCYT, & ! input KB , KT , KTMX , & ! input - ISTS , IENS , sigma ) ! input + ISTS , IENS ) ! input ! IMPLICIT NONE @@ -2518,6 +2451,7 @@ SUBROUTINE CUMFLX & !! cloud mass flux ! ! [OUTPUT] REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux + REAL(r8) CMDET (IJSDIM, KMAX) !! detrainment mass flux REAL(r8) GPRCI (IJSDIM, KMAX) !! rainfall generation REAL(r8) GSNWI (IJSDIM, KMAX) !! snowfall generation REAL(r8) QLIQ (IJSDIM, KMAX) !! cloud liquid @@ -2527,76 +2461,50 @@ SUBROUTINE CUMFLX & !! cloud mass flux ! [INPUT] REAL(r8) CBMFX (IJSDIM) !! cloud base mass flux REAL(r8) GCYM (IJSDIM, KMAX) !! normalized mass flux - REAL(r8) sigma (IJSDIM, KMAX) !! AW sigma + REAL(r8) GCYT (IJSDIM) !! detraining mass flux REAL(r8) GPRCIZ(IJSDIM, KMAX) !! precipitation/M REAL(r8) GSNWIZ(IJSDIM, KMAX) !! snowfall/M REAL(r8) GTPRT (IJSDIM) !! rain+snow @top REAL(r8) GCLZ (IJSDIM, KMAX) !! cloud liquid/M REAL(r8) GCIZ (IJSDIM, KMAX) !! cloud ice/M - real(r8) tem INTEGER KB (IJSDIM) !! cloud base INTEGER KT (IJSDIM) !! cloud top INTEGER KTMX !! max of cloud top - INTEGER ISTS, IENS -! -! [INTERNAL WORK] - INTEGER I, K -! -!M DO K=1,KTMX -!M DO I=ISTS,IENS -!M GMFLX(I,K) = GMFLX(I,K) + GCYM(I,K)*CBMFX(I) -!M ENDDO -!M ENDDO + INTEGER ISTS, IENS, I, K ! DO K=1,KTMX DO I=ISTS,IENS - tem = CBMFX(I) * (one - sigma(i,k)) - GMFLX(I,K) = GMFLX(I,K) + tem * GCYM(I,K) - GPRCI(I,K) = GPRCI(I,K) + tem * GPRCIZ(I,K) - GSNWI(I,K) = GSNWI(I,K) + tem * GSNWIZ(I,K) - QLIQ(I,K) = QLIQ (I,K) + tem * GCLZ(I,K) - QICE(I,K) = QICE (I,K) + tem * GCIZ(I,K) - -! GMFLX(I,K) = GMFLX(I,K) + GCYM(I,K) * CBMFX(I) -! GPRCI(I,K) = GPRCI(I,K) + GPRCIZ(I,K) * CBMFX(I) -! GSNWI(I,K) = GSNWI(I,K) + GSNWIZ(I,K) * CBMFX(I) -! QLIQ(I,K) = QLIQ (I,K) + GCLZ(I,K) * CBMFX(I) -! QICE(I,K) = QICE (I,K) + GCIZ(I,K) * CBMFX(I) + if (kb(i) > 0) then + GMFLX(I,K) = GMFLX(I,K) + CBMFX(I) * GCYM(I,K) + GPRCI(I,K) = GPRCI(I,K) + CBMFX(I) * GPRCIZ(I,K) + GSNWI(I,K) = GSNWI(I,K) + CBMFX(I) * GSNWIZ(I,K) + QLIQ(I,K) = QLIQ (I,K) + CBMFX(I) * GCLZ(I,K) + QICE(I,K) = QICE (I,K) + CBMFX(I) * GCIZ(I,K) + endif ENDDO ENDDO ! DO I= ISTS,IENS - GTPRC0(I) = GTPRC0(I) + GTPRT(I) * CBMFX(I) + if (kb(i) > 0 .and. kt(i) > 0) then + GTPRC0(I) = GTPRC0(I) + CBMFX(I) * GTPRT(I) + CMDET(I,KT(I)) = CMDET(I,KT(I)) + CBMFX(I) * GCYT(I) + endif ENDDO -! -!M DO K = 1, KTMX -!M DO I = ISTS, IENS -!M QLIQ(I,K) = QLIQ(I,K) + GCLZ(I,K)*CBMFX(I) -!M QICE(I,K) = QICE(I,K) + GCIZ(I,K)*CBMFX(I) -!M ENDDO -!M ENDDO ! END SUBROUTINE CUMFLX !*********************************************************************** SUBROUTINE CUMDET & !! detrainment - ( im , IJSDIM, KMAX , NTR , & !DD dimensions - CMDET , & ! output -! CMDET , GTLDET, GTIDET, & ! output + ( im , IJSDIM, KMAX , NTR , ntrq , & !DD dimensions GTT , GTQ , GTCFRC, GTU , GTV , & ! modified -! GTQI , & ! modified GDH , GDQ , GDCFRC, GDU , GDV , & ! input - CBMFX , GCYT , DELP , GCHT , GCQT , & ! input + CBMFX , GCYT , DELPI , GCHT , GCQT , & ! input GCLT , GCIT , GCUT , GCVT , GDQI , & ! input - KT , ISTS , IENS , nctp , sigi ) ! input + gctrt, & + KT , ISTS , IENS , nctp ) ! input ! IMPLICIT NONE - INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, nctp !! DD, for GFS, pass in -! -! [OUTPUT] - REAL(r8) CMDET (IJSDIM, KMAX) !! detrainment mass flux -! REAL(r8) GTLDET(IJSDIM, KMAX) !! cloud liquid tendency by detrainment -! REAL(r8) GTIDET(IJSDIM, KMAX) !! cloud ice tendency by detrainment + INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, nctp, ntrq !! DD, for GFS, pass in ! ! [MODIFY] REAL(r8) GTT (IJSDIM, KMAX) !! temperature tendency @@ -2604,103 +2512,77 @@ SUBROUTINE CUMDET & !! detrainment REAL(r8) GTCFRC(IJSDIM, KMAX) !! cloud fraction tendency REAL(r8) GTU (IJSDIM, KMAX) !! u tendency REAL(r8) GTV (IJSDIM, KMAX) !! v tendency -! REAL(r8) GTQI (IJSDIM, KMAX) !! cloud ice tendency ! ! [INPUT] - REAL(r8) GDH (IJSDIM, KMAX) !! moist static energy + REAL(r8) GDH (IJSDIM, KMAX) !! moist static energy REAL(r8) GDQ (IJSDIM, KMAX, NTR) !! humidity qv - REAL(r8) GDCFRC(IJSDIM, KMAX) !! cloud fraction + REAL(r8) GDCFRC(IJSDIM, KMAX) !! cloud fraction REAL(r8) GDU (IJSDIM, KMAX) REAL(r8) GDV (IJSDIM, KMAX) - REAL(r8) DELP (IJSDIM, KMAX) - REAL(r8) CBMFX (IM, NCTP) !! cloud base mass flux - REAL(r8) GCYT (IJSDIM, NCTP) !! detraining mass flux - REAL(r8) GCHT (IJSDIM, NCTP) !! detraining MSE - REAL(r8) GCQT (IJSDIM, NCTP) !! detraining qv - REAL(r8) GCLT (IJSDIM, NCTP) !! detraining ql - REAL(r8) GCIT (IJSDIM, NCTP) !! detraining qi - REAL(r8) GCUT (IJSDIM, NCTP) !! detraining u - REAL(r8) GCVT (IJSDIM, NCTP) !! detraining v - REAL(r8) GDQI (IJSDIM, KMAX) !! cloud ice - REAL(r8) sigi (IJSDIM, KMAX,nctp) !! cloud fraction - INTEGER KT (IJSDIM, NCTP) !! cloud top + REAL(r8) DELPI (IJSDIM, KMAX) + REAL(r8) CBMFX (IM, NCTP) !! cloud base mass flux + REAL(r8) GCYT (IJSDIM, NCTP) !! detraining mass flux + REAL(r8) GCHT (IJSDIM, NCTP) !! detraining MSE + REAL(r8) GCQT (IJSDIM, NCTP) !! detraining qv + REAL(r8) GCLT (IJSDIM, NCTP) !! detraining ql + REAL(r8) GCIT (IJSDIM, NCTP) !! detraining qi + REAL(r8) GCtrT (IJSDIM, ntrq:ntr, NCTP)!! detraining tracer + REAL(r8) GCUT (IJSDIM, NCTP) !! detraining u + REAL(r8) GCVT (IJSDIM, NCTP) !! detraining v + REAL(r8) GDQI (IJSDIM, KMAX) !! cloud ice + INTEGER KT (IJSDIM, NCTP) !! cloud top INTEGER ISTS, IENS ! ! [INTERNAL WORK] - REAL(r8) sigma(ijsdim) - REAL(r8) GTHCI, GTQVCI, GTQLCI, GTQICI, GTXCI, tem -!M REAL(r8) GTCCI -!M REAL(r8) GTUCI, GTVCI - INTEGER I, K, CTP, kk -! + REAL(r8) GTHCI, GTQVCI, GTXCI + integer I, K, CTP, kk,n ! -!PARALLEL_FORBID - do k=1,kmax - DO I=ISTS,IENS - CMDET (I,k) = zero -! GTLDET(I,k) = zero -! GTIDET(I,k) = zero - enddo - enddo - do i=ists,iens - sigma(i) = zero - enddo - -!PARALLEL_FORBID DO CTP=1,NCTP DO I=ISTS,IENS K = KT(I,CTP) IF (K > 0) THEN - sigma(i) = sigma(i) + sigi(i,k,ctp) - tem = CBMFX(I,CTP) * (one - sigma(i)) - GTXCI = GRAV/DELP(I,K)*tem + GTXCI = DELPI(I,K)*CBMFX(I,CTP) GTHCI = GTXCI * (GCHT(I,CTP) - GCYT(I,CTP)*GDH(I,K)) GTQVCI = GTXCI * (GCQT(I,CTP) - GCYT(I,CTP)*GDQ(I,K,1)) - GTQLCI = GTXCI * (GCLT(I,CTP) - GCYT(I,CTP)*GDQ(I,K,ITL)) - GTQICI = GTXCI * (GCIT(I,CTP) - GCYT(I,CTP)*GDQI(I,K)) ! - GTQ(I,K,1) = GTQ(I,K,1) + GTQVCI - GTT(I,K) = GTT(I,K) + (GTHCI - EL*GTQVCI) * oneocp + GTQ(I,K,1) = GTQ(I,K,1) + GTQVCI + GTT(I,K) = GTT(I,K) + (GTHCI - EL*GTQVCI) * oneocp ! ql tendency by detrainment is treated by stratiform scheme - GTQ(I,K,ITL) = GTQ(I,K,ITL) + GTQLCI -! GTLDET(I,K) = GTLDET(I,K) + GTQLCI + GTQ(I,K,ITL) = GTQ(I,K,ITL) + GTXCI * (GCLT(I,CTP) - GCYT(I,CTP)*GDQ(I,K,ITL)) ! qi tendency by detrainment is treated by stratiform scheme -! GTQI (I,K) = GTQI(I,K) + GTQICI -! GTIDET(I,K) = GTIDET(I,K) + GTQICI - GTQ(I,K,ITI) = GTQ(I,K,ITI) + GTQICI + GTQ(I,K,ITI) = GTQ(I,K,ITI) + GTXCI * (GCIT(I,CTP) - GCYT(I,CTP)*GDQI(I,K)) + do n = ntrq,NTR + GTQ(I,K,n) = GTQ(I,K,n) + GTXCI * (GCtrT(I,n,CTP) - GCYT(I,CTP)*GDQ(I,K,n)) + enddo GTCFRC(I,K) = GTCFRC(I,K) + GTXCI * (GCYT(I,CTP) - GCYT(I,CTP)*GDCFRC(I,K)) GTU(I,K) = GTU(I,K) + GTXCI * (GCUT(I,CTP) - GCYT(I,CTP)*GDU(I,K)) GTV(I,K) = GTV(I,K) + GTXCI * (GCVT(I,CTP) - GCYT(I,CTP)*GDV(I,K)) -! - CMDET(I,K ) = CMDET(I,K) + GCYT(I,CTP) * tem ENDIF ENDDO ENDDO ! END SUBROUTINE CUMDET !*********************************************************************** - SUBROUTINE CUMSBH & !! adiabat. descent - ( IM , IJSDIM, KMAX , NTR ,& !DD dimensions - GTT , GTQ , & ! modified -! GTT , GTQ , GTQI , & ! modified - GTU , GTV , & ! modified - GDH , GDQ , GDQI , & ! input - GDU , GDV , & ! input - DELP , GMFLX , GMFX0 , & ! input - KTMX , CPRES , ISTS , IENS ) ! input + SUBROUTINE CUMSBH & !! adiabat. descent + ( IM , IJSDIM, KMAX , NTR, ntrq, & !DD dimensions + GTT , GTQ , & ! modified + GTU , GTV , & ! modified + GDH , GDQ , GDQI , & ! input + GDU , GDV , & ! input + DELPI , GMFLX , GMFX0 , & ! input + KTMX , CPRES , KB, ISTS , IENS ) ! input ! ! IMPLICIT NONE - INTEGER, INTENT(IN) :: IJSDIM, IM, KMAX, NTR !! DD, for GFS, pass in + INTEGER, INTENT(IN) :: IJSDIM, IM, KMAX, NTR, ntrq !! DD, for GFS, pass in ! ! [MODIFY] REAL(r8) GTT (IJSDIM, KMAX) !! Temperature tendency REAL(r8) GTQ (IJSDIM, KMAX, NTR) !! Moisture etc tendency -! REAL(r8) GTQI (IJSDIM, KMAX) REAL(r8) GTU (IJSDIM, KMAX) !! u tendency REAL(r8) GTV (IJSDIM, KMAX) !! v tendency ! @@ -2710,23 +2592,23 @@ SUBROUTINE CUMSBH & !! adiabat. descent REAL(r8) GDQI (IJSDIM, KMAX) REAL(r8) GDU (IJSDIM, KMAX) REAL(r8) GDV (IJSDIM, KMAX) - REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) DELPI (IJSDIM, KMAX) REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux (updraft+downdraft) REAL(r8) GMFX0 (IJSDIM, KMAX) !! mass flux (updraft only) + INTEGER KB(IJSDIM) !! cloud base index - negative means no convection INTEGER KTMX REAL(r8) CPRES !! pressure factor for cumulus friction INTEGER ISTS, IENS ! ! [INTERNAL WORK] - INTEGER I, K, KM, KP REAL(r8) SBH0, SBQ0, SBL0, SBI0, SBC0, SBS0, & SBH1, SBQ1, SBL1, SBI1, SBC1, SBS1, FX1, & SBU0, SBV0, SBU1, SBV1, GTHCI, GTQVCI, & GTQLCI, GTQICI, GTM2CI, GTM3CI, wrk, wrk1 -!M REAL(r8) GTUCI, GTVCI, wrk, wrk1 REAL(r8) FX(ISTS:IENS) REAL(r8), dimension(IJSDIM, KMAX) :: GTLSBH, GTISBH + integer :: I, K, KM, KP, n ! ! FX = zero @@ -2741,103 +2623,169 @@ SUBROUTINE CUMSBH & !! adiabat. descent KM = MAX(K-1, 1) KP = MIN(K+1, KMAX) DO I=ISTS,IENS - SBH0 = GMFLX(I,KP) * (GDH(I,KP)-GDH(I,K)) - SBQ0 = GMFLX(I,KP) * (GDQ(I,KP,1)-GDQ(I,K,1)) - SBL0 = GMFLX(I,KP) * (GDQ(I,KP,ITL )-GDQ(I,K,ITL)) - SBI0 = GMFLX(I,KP) * (GDQI(I,KP)-GDQI(I,K)) - SBU0 = GMFLX(I,KP) * (GDU(I,KP)-GDU(I,K)) & - - GMFX0(I,KP) * (GDU(I,KP)-GDU(I,K))*CPRES - SBV0 = GMFLX(I,KP) * (GDV(I,KP)-GDV(I,K)) & - - GMFX0(I,KP) * (GDV(I,KP)-GDV(I,K))*CPRES -! - SBH1 = GMFLX(I,K) * (GDH(I,K)-GDH(I,KM)) - SBQ1 = GMFLX(I,K) * (GDQ(I,K,1)-GDQ(I,KM,1)) - SBL1 = GMFLX(I,K) * (GDQ(I,K,ITL)-GDQ(I,KM,ITL)) - SBI1 = GMFLX(I,K) * (GDQI(I,K)-GDQI(I,KM)) - SBU1 = GMFLX(I,K) * (GDU(I,K)-GDU(I,KM)) & - - GMFX0(I,K) * (GDU(I,K)-GDU(I,KM))*CPRES - SBV1 = GMFLX(I,K) * (GDV(I,K)-GDV(I,KM)) & - - GMFX0(I,K) * (GDV(I,K)-GDV(I,KM))*CPRES -! -!#ifndef SYS_SX /* original */ - IF (GMFLX(I,K) > GMFLX(I,KP)) THEN - FX1 = half - ELSE - FX1 = zero - ENDIF -!#else /* optimized for NEC SX series */ -! FX1 = 0.25D0 - SIGN(0.25D0,GMFLX(I,K+1)-GMFLX(I,K)) !! 0.5 or 0. -!#endif -! - wrk = GRAV / DELP(I,K) - wrk1 = one - FX(I) - GTHCI = wrk * (wrk1*SBH0 + FX1 *SBH1) - GTQVCI = wrk * (wrk1*SBQ0 + FX1 *SBQ1) - GTQLCI = wrk * (wrk1*SBL0 + FX1 *SBL1) - GTQICI = wrk * (wrk1*SBI0 + FX1 *SBI1) -!M GTUCI = wrk * (wrk1*SBU0 + FX1 *SBU1) -!M GTVCI = wrk * (wrk1*SBV0 + FX1 *SBV1) -! - GTT (I,K ) = GTT(I,K) + (GTHCI-EL*GTQVCI)*oneocp - GTQ (I,K,1 ) = GTQ(I,K,1) + GTQVCI - GTQ (I,K,ITL) = GTQ(I,K,ITL) + GTQLCI - GTQ (I,K,ITI) = GTQ(I,K,ITI) + GTQICI -! GTQI(I,K) = GTQI(I,K) + GTQICI -!M GTU (I,K) = GTU(I,K) + GTUCI -!M GTV (I,K) = GTV(I,K) + GTVCI - GTU (I,K) = GTU(I,K) + wrk * (wrk1*SBU0 + FX1*SBU1) - GTV (I,K) = GTV(I,K) + wrk * (wrk1*SBV0 + FX1*SBV1) - - GTLSBH(I,K) = GTQLCI - GTISBH(I,K) = GTQICI -! -! SBC0 = GMFLX(I,K+1) * (GDQ(I,KP,IMU2)-GDQ(I,K,IMU2)) -! SBS0 = GMFLX(I,K+1) * (GDQ(I,KP,IMU3)-GDQ(I,K,IMU3)) -! SBC1 = GMFLX(I,K) * (GDQ(I,K,IMU2)-GDQ(I,KM,IMU2)) -! SBS1 = GMFLX(I,K) * (GDQ(I,K,IMU3)-GDQ(I,KM,IMU3)) -! GTM2CI = GRAV/DELP(I,K) -! & *(( one-FX(I))*SBC0 + FX1 *SBC1) -! GTM3CI = GRAV/DELP(I,K) -! & *((one-FX(I))*SBS0 + FX1 *SBS1) -! GTQ(I,K,IMU2) = GTQ(I,K,IMU2) + GTM2CI -! GTQ(I,K,IMU3) = GTQ(I,K,IMU3) + GTM3CI -! - FX(I) = FX1 + if (kb(i) > 0) then + SBH0 = GMFLX(I,KP) * (GDH(I,KP)-GDH(I,K)) + SBQ0 = GMFLX(I,KP) * (GDQ(I,KP,1)-GDQ(I,K,1)) + SBL0 = GMFLX(I,KP) * (GDQ(I,KP,ITL )-GDQ(I,K,ITL)) + SBI0 = GMFLX(I,KP) * (GDQI(I,KP)-GDQI(I,K)) + SBU0 = GMFLX(I,KP) * (GDU(I,KP)-GDU(I,K)) & + - GMFX0(I,KP) * (GDU(I,KP)-GDU(I,K))*CPRES + SBV0 = GMFLX(I,KP) * (GDV(I,KP)-GDV(I,K)) & + - GMFX0(I,KP) * (GDV(I,KP)-GDV(I,K))*CPRES +! + SBH1 = GMFLX(I,K) * (GDH(I,K)-GDH(I,KM)) + SBQ1 = GMFLX(I,K) * (GDQ(I,K,1)-GDQ(I,KM,1)) + SBL1 = GMFLX(I,K) * (GDQ(I,K,ITL)-GDQ(I,KM,ITL)) + SBI1 = GMFLX(I,K) * (GDQI(I,K)-GDQI(I,KM)) + SBU1 = GMFLX(I,K) * (GDU(I,K)-GDU(I,KM)) & + - GMFX0(I,K) * (GDU(I,K)-GDU(I,KM))*CPRES + SBV1 = GMFLX(I,K) * (GDV(I,K)-GDV(I,KM)) & + - GMFX0(I,K) * (GDV(I,K)-GDV(I,KM))*CPRES +! + IF (GMFLX(I,K) > GMFLX(I,KP)) THEN + FX1 = half + ELSE + FX1 = zero + ENDIF +! + wrk = DELPI(I,K) + wrk1 = one - FX(I) + GTHCI = wrk * (wrk1*SBH0 + FX1 *SBH1) + GTQVCI = wrk * (wrk1*SBQ0 + FX1 *SBQ1) + GTQLCI = wrk * (wrk1*SBL0 + FX1 *SBL1) + GTQICI = wrk * (wrk1*SBI0 + FX1 *SBI1) +! + GTT (I,K ) = GTT(I,K) + (GTHCI-EL*GTQVCI)*oneocp + GTQ (I,K,1 ) = GTQ(I,K,1) + GTQVCI + GTQ (I,K,ITL) = GTQ(I,K,ITL) + GTQLCI + GTQ (I,K,ITI) = GTQ(I,K,ITI) + GTQICI + GTU (I,K) = GTU(I,K) + wrk * (wrk1*SBU0 + FX1*SBU1) + GTV (I,K) = GTV(I,K) + wrk * (wrk1*SBV0 + FX1*SBV1) + DO n = ntrq, ntr + GTQ (I,K,n) = GTQ(I,K,n) + wrk & + * ( wrk1 * (GMFLX(I,KP) * (GDQ(I,KP,n)-GDQ(I,K ,n))) & + + FX1 * (GMFLX(I,K ) * (GDQ(I,K ,n)-GDQ(I,KM,n))) ) + ENDDO + + GTLSBH(I,K) = GTQLCI + GTISBH(I,K) = GTQICI +! +! SBC0 = GMFLX(I,K+1) * (GDQ(I,KP,IMU2)-GDQ(I,K,IMU2)) +! SBS0 = GMFLX(I,K+1) * (GDQ(I,KP,IMU3)-GDQ(I,K,IMU3)) +! SBC1 = GMFLX(I,K) * (GDQ(I,K,IMU2)-GDQ(I,KM,IMU2)) +! SBS1 = GMFLX(I,K) * (GDQ(I,K,IMU3)-GDQ(I,KM,IMU3)) +! GTM2CI = DELPI(I,K) * (( one-FX(I))*SBC0 + FX1 *SBC1) +! GTM3CI = DELPI(I,K) * ((one-FX(I))*SBS0 + FX1 *SBS1) +! GTQ(I,K,IMU2) = GTQ(I,K,IMU2) + GTM2CI +! GTQ(I,K,IMU3) = GTQ(I,K,IMU3) + GTM3CI +! + FX(I) = FX1 + endif enddo enddo ! END SUBROUTINE CUMSBH !*********************************************************************** ! +!*********************************************************************** + SUBROUTINE CUMSBW & !! adiabat. descent + ( IM , IJSDIM, KMAX , & !DD dimensions + GTU , GTV , & ! modified + GDU , GDV , & ! input + DELPI , GMFLX , GMFX0 , & ! input + KTMX , CPRES , KB, ISTS , IENS ) ! input +! +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IJSDIM, IM, KMAX!! DD, for GFS, pass in +! +! [MODIFY] + REAL(r8) GTU (IJSDIM, KMAX) !! u tendency + REAL(r8) GTV (IJSDIM, KMAX) !! v tendency +! +! [INPUT] + REAL(r8) GDU (IJSDIM, KMAX) + REAL(r8) GDV (IJSDIM, KMAX) + REAL(r8) DELPI (IJSDIM, KMAX) + REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux (updraft+downdraft) + REAL(r8) GMFX0 (IJSDIM, KMAX) !! mass flux (updraft only) + INTEGER KB(IJSDIM) !! cloud base index - negative means no convection + INTEGER KTMX, ISTS, IENS + REAL(r8) CPRES !! pressure factor for cumulus friction +! +! [INTERNAL WORK] + REAL(r8) FX1, SBU0, SBV0, SBU1, SBV1, wrk, wrk1 + REAL(r8) FX(ISTS:IENS) + + integer :: I, K, KM, KP +! +! + FX = zero +! + DO K=KTMX,1,-1 + KM = MAX(K-1, 1) + KP = MIN(K+1, KMAX) + DO I=ISTS,IENS + if (kb(i) > 0) then + SBU0 = GMFLX(I,KP) * (GDU(I,KP)-GDU(I,K)) & + - GMFX0(I,KP) * (GDU(I,KP)-GDU(I,K))*CPRES + SBV0 = GMFLX(I,KP) * (GDV(I,KP)-GDV(I,K)) & + - GMFX0(I,KP) * (GDV(I,KP)-GDV(I,K))*CPRES +! + SBU1 = GMFLX(I,K) * (GDU(I,K)-GDU(I,KM)) & + - GMFX0(I,K) * (GDU(I,K)-GDU(I,KM))*CPRES + SBV1 = GMFLX(I,K) * (GDV(I,K)-GDV(I,KM)) & + - GMFX0(I,K) * (GDV(I,K)-GDV(I,KM))*CPRES +! + IF (GMFLX(I,K) > GMFLX(I,KP)) THEN + FX1 = half + ELSE + FX1 = zero + ENDIF +! + wrk = DELPI(I,K) + wrk1 = one - FX(I) +! + GTU(I,K) = GTU(I,K) + wrk * (wrk1*SBU0 + FX1*SBU1) + GTV(I,K) = GTV(I,K) + wrk * (wrk1*SBV0 + FX1*SBV1) +! + FX(I) = FX1 + endif + enddo + enddo +! + END SUBROUTINE CUMSBW +!*********************************************************************** SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation - ( IM , IJSDIM, KMAX , NTR , & !DD dimensions - GTT , GTQ , GTU , GTV , & ! modified - GMFLX , & ! modified -! GTQI , GMFLX , & ! modified - GPRCP , GSNWP , GTEVP , GMDD , & ! output - GPRCI , GSNWI , & ! input - GDH , GDW , GDQ , GDQI , & ! input - GDQS , GDS , GDHS , GDT , & ! input - GDU , GDV , GDZ , & ! input - GDZM , GCYM , FDQS , DELP , & ! input - sigmad, do_aw , do_awdd , & !DDsigma input - gtmelt, gtevap, gtsubl, & !DDsigma input - dtdwn , dqvdwn, dqldwn, dqidwn, & !DDsigma input - KB , KTMX , ISTS , IENS ) ! input + ( IM , IJSDIM, KMAX , NTR , ntrq, & !DD dimensions + GTT , GTQ , GTU , GTV , & ! modified + GMFLX , & ! modified + GPRCP , GSNWP , GTEVP , GMDD , & ! output + GPRCI , GSNWI , & ! input + GDH , GDW , GDQ , GDQI , & ! input + GDQS , GDS , GDHS , GDT , & ! input + GDU , GDV , GDZ , & ! input + GDZM , FDQS , DELP , & ! input + DELPI , & + sigmad, do_aw , do_awdd, flx_form, & !DDsigma input + gtmelt, gtevap, gtsubl, & !DDsigma input + dtdwn , dqvdwn, dqldwn, dqidwn, & !DDsigma input + dtrdwn, & + KB , KTMX , ISTS , IENS ) ! input ! ! DD AW : modify to get eddy fluxes and microphysical tendencies for AW ! IMPLICIT NONE - INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR ! DD, for GFS, pass in - logical, intent(in) :: do_aw, do_awdd + INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR, ntrq ! DD, for GFS, pass in + logical, intent(in) :: do_aw, do_awdd, flx_form ! ! [MODIFY] REAL(r8) GTT (IJSDIM, KMAX) ! Temperature tendency REAL(r8) GTQ (IJSDIM, KMAX, NTR) ! Moisture etc tendency REAL(r8) GTU (IJSDIM, KMAX) ! u tendency REAL(r8) GTV (IJSDIM, KMAX) ! v tendency -! REAL(r8) GTQI (IJSDIM, KMAX) ! cloud ice tendency REAL(r8) GMFLX (IJSDIM, KMAX) ! mass flux ! ! [OUTPUT] @@ -2855,69 +2803,71 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation REAL(r8) dqvdwn (IJSDIM, KMAX) ! qv tendency downdraft detrainment REAL(r8) dqldwn (IJSDIM, KMAX) ! ql tendency downdraft detrainment REAL(r8) dqidwn (IJSDIM, KMAX) ! qi tendency downdraft detrainment + REAL(r8) dtrdwn (IJSDIM, KMAX, ntrq:ntr) ! tracer tendency downdraft detrainment ! AW downdraft area fraction (assumed zero for now) - REAL(r8) sigmad (IM,KMAX) !DDsigma cloud downdraft area fraction + REAL(r8) sigmad (IJSDIM,KMAX) !DDsigma cloud downdraft area fraction ! [INPUT] - REAL(r8) GPRCI (IJSDIM, KMAX) ! rainfall generation - REAL(r8) GSNWI (IJSDIM, KMAX) ! snowfall generation - REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy - REAL(r8) GDW (IJSDIM, KMAX) ! total water - REAL(r8) GDQ (IJSDIM, KMAX, NTR)! humidity etc - REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice - REAL(r8) GDQS (IJSDIM, KMAX) ! saturate humidity - REAL(r8) GDS (IJSDIM, KMAX) ! dry static energy - REAL(r8) GDHS (IJSDIM, KMAX) ! saturate moist static energy - REAL(r8) GDT (IJSDIM, KMAX) ! air temperature T - REAL(r8) GDU (IJSDIM, KMAX) ! u-velocity - REAL(r8) GDV (IJSDIM, KMAX) ! v-velocity - REAL(r8) GDZ (IJSDIM, KMAX) ! altitude - REAL(r8) GDZM (IJSDIM, KMAX+1) ! altitude (half lev) - REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux + REAL(r8) GPRCI (IJSDIM, KMAX) ! rainfall generation + REAL(r8) GSNWI (IJSDIM, KMAX) ! snowfall generation + REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy + REAL(r8) GDW (IJSDIM, KMAX) ! total water + REAL(r8) GDQ (IJSDIM, KMAX, NTR) ! humidity etc + REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice + REAL(r8) GDQS (IJSDIM, KMAX) ! saturate humidity + REAL(r8) GDS (IJSDIM, KMAX) ! dry static energy + REAL(r8) GDHS (IJSDIM, KMAX) ! saturate moist static energy + REAL(r8) GDT (IJSDIM, KMAX) ! air temperature T + REAL(r8) GDU (IJSDIM, KMAX) ! u-velocity + REAL(r8) GDV (IJSDIM, KMAX) ! v-velocity + REAL(r8) GDZ (IJSDIM, KMAX) ! altitude + REAL(r8) GDZM (IJSDIM, KMAX+1) ! altitude (half lev) REAL(r8) FDQS (IJSDIM, KMAX) REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) DELPI (IJSDIM, KMAX) INTEGER KB (IJSDIM) INTEGER KTMX, ISTS, IENS ! ! [INTERNAL WORK] ! Note: Some variables have 3-dimensions for the purpose of budget check. - REAL(r8) EVAPD (IJSDIM, KMAX) ! evap. in downdraft - REAL(r8) SUBLD (IJSDIM, KMAX) ! subl. in downdraft - REAL(r8) EVAPE (IJSDIM, KMAX) ! evap. in environment - REAL(r8) SUBLE (IJSDIM, KMAX) ! subl. in environment - REAL(r8) EVAPX (IJSDIM, KMAX) ! evap. env. to DD - REAL(r8) SUBLX (IJSDIM, KMAX) ! subl. env. to DD - REAL(r8) GMDDE (IJSDIM, KMAX) ! downdraft entrainment - REAL(r8) SNMLT (IJSDIM, KMAX) ! melt - freeze - REAL(r8) GCHDD (IJSDIM, KMAX) ! MSE detrainment - REAL(r8) GCWDD (IJSDIM, KMAX) ! water detrainment - REAL(r8) GTTEV (IJSDIM, KMAX) ! T tendency by evaporation - REAL(r8) GTQEV (IJSDIM, KMAX) ! q tendency by evaporation - REAL(r8) GCHD (ISTS:IENS) ! downdraft MSE - REAL(r8) GCWD (ISTS:IENS) ! downdraft q + REAL(r8) EVAPD (IJSDIM, KMAX) ! evap. in downdraft + REAL(r8) SUBLD (IJSDIM, KMAX) ! subl. in downdraft + REAL(r8) EVAPE (IJSDIM, KMAX) ! evap. in environment + REAL(r8) SUBLE (IJSDIM, KMAX) ! subl. in environment + REAL(r8) EVAPX (IJSDIM, KMAX) ! evap. env. to DD + REAL(r8) SUBLX (IJSDIM, KMAX) ! subl. env. to DD + REAL(r8) GMDDE (IJSDIM, KMAX) ! downdraft entrainment + REAL(r8) SNMLT (IJSDIM, KMAX) ! melt - freeze + REAL(r8) GCHDD (IJSDIM, KMAX) ! MSE detrainment + REAL(r8) GCWDD (IJSDIM, KMAX) ! water detrainment + REAL(r8) GTTEV (IJSDIM, KMAX) ! T tendency by evaporation + REAL(r8) GTQEV (IJSDIM, KMAX) ! q tendency by evaporation + REAL(r8) GCHD (ISTS:IENS) ! downdraft MSE + REAL(r8) GCWD (ISTS:IENS) ! downdraft q ! profiles of downdraft variables for AW flux tendencies - REAL(r8) GCdseD(ISTS:IENS, KMAX) ! downdraft dse - REAL(r8) GCqvD (ISTS:IENS, KMAX) ! downdraft qv - REAL(r8) GCqlD (ISTS:IENS, KMAX) ! downdraft ql - REAL(r8) GCqiD (ISTS:IENS, KMAX) ! downdraft qi - - REAL(r8) GCUD (ISTS:IENS) ! downdraft u - REAL(r8) GCVD (ISTS:IENS) ! downdraft v + REAL(r8) GCdseD(ISTS:IENS, KMAX) ! downdraft dse + REAL(r8) GCqvD (ISTS:IENS, KMAX) ! downdraft qv +! REAL(r8) GCqlD (ISTS:IENS, KMAX) ! downdraft ql +! REAL(r8) GCqiD (ISTS:IENS, KMAX) ! downdraft qi + REAL(r8) GCtrD (ISTS:IENS, ntrq:ntr) ! downdraft tracer + + REAL(r8) GCUD (ISTS:IENS) ! downdraft u + REAL(r8) GCVD (ISTS:IENS) ! downdraft v REAL(r8) FSNOW (ISTS:IENS) REAL(r8) GMDDD (ISTS:IENS) - REAL(r8) GDTW, GCHX, GCTX, GCQSX, GTPRP, EVSU, GTEVE, LVIC, & - DQW, DTW, GDQW, DZ, GCSD, FDET, GDHI, GMDDX, & - GMDDMX, GCHDX, GCWDX, GCUDD, GCVDD, GTHCI, GTQVCI, & - GTQLCI, GTQICI, wrk, wrk1, wrk2, wrk3, wrk4, & - WMX, HMX, DDWMX, DDHMX, dp_above, dp_below, fsigma, & - fmelt, fevp + REAL(r8) GDTW, GCHX, GCTX, GCQSX, GTPRP, EVSU, GTEVE, LVIC, & + DQW, DTW, GDQW, DZ, GCSD, FDET, GDHI, GMDDX, & + GMDDMX, GCHDX, GCWDX, GCUDD, GCVDD, GTHCI, GTQVCI, & + wrk, wrk1, wrk2, wrk3, wrk4, tx1, & + WMX, HMX, DDWMX, DDHMX, dp_above, dp_below, fsigma, & + fmelt, fevp, wrkn, gctrdd(ntrq:ntr) !M REAL(r8) GTHCI, GTQVCI, GTQLCI, GTQICI, GTUCI, GTVCI !DD#ifdef OPT_CUMBGT ! Water, energy, downdraft water and downdraft energy budgets - REAL(r8), dimension(ISTS:IENS) :: WBGT, HBGT, DDWBGT, DDHBGT, tx1 - integer ij, i, k, kp1 + REAL(r8), dimension(ISTS:IENS) :: WBGT, HBGT, DDWBGT, DDHBGT + integer ij, i, k, kp1, n !DD#endif ! ! [INTERNAL PARM] @@ -2925,8 +2875,10 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation REAL(r8), parameter :: FTMLT = 4._r8 ! temp. factor for melt REAL(r8), parameter :: GMFLXC = 5.e-2_r8 ! critical mass flux REAL(r8), parameter :: VTERMS = 2._r8 ! terminal velocity of snowflake - REAL(r8), parameter :: MELTAU = 10._r8 ! melting timescale +! REAL(r8), parameter :: MELTAU = 10._r8 ! melting timescale + REAL(r8), parameter :: MELTAU = 20._r8 ! melting timescale ! Moorthi june 30, 2017 ! +! REAL(r8), parameter :: EVAPR = 0.4_r8 ! evaporation factor ! Moorthi June 28, 2017 REAL(r8), parameter :: EVAPR = 0.3_r8 ! evaporation factor ! REAL(r8), parameter :: EVAPR = 0._r8 ! evaporation factor REAL(r8), parameter :: REVPDD = 1._r8 ! max rate of DD to evapolation @@ -2934,6 +2886,7 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation ! REAL(r8), parameter :: RDDR = 0._r8 ! DD rate (T0 R0 W0)^-1 REAL(r8), parameter :: RDDMX = 0.5_r8 ! norm. flux of downdraft REAL(r8), parameter :: VTERM = 5._r8 ! term. vel. of precip. +! REAL(r8), parameter :: VTERM = 4._r8 ! term. vel. of precip. ! Moorthi June 28, 2017 REAL(r8), parameter :: EVATAU = 2._r8 ! evaporation/sublimation timescale REAL(r8), parameter :: ZDMIN = 5.e2_r8 ! min altitude of downdraft detrainment real(r8), parameter :: evapovtrm=EVAPR/VTERM @@ -2965,22 +2918,33 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation GTQEV (I,k) = zero GCdseD(I,k) = zero GCqvD (I,k) = zero - GCqlD (I,k) = zero - GCqiD (I,k) = zero +! GCqlD (I,k) = zero +! GCqiD (I,k) = zero gtevap(I,k) = zero gtmelt(I,k) = zero gtsubl(I,k) = zero enddo enddo ! testing on oct 17 2016 - if (do_aw) then + if (do_aw .and. flx_form) then if (.not. do_awdd) then do k=1,kmax do i=ists,iens - dtdwn (i,k) = gtt(i,k) - dqvdwn(i,k) = gtq(i,k,1) - dqldwn(i,k) = gtq(i,k,itl) - dqidwn(i,k) = gtq(i,k,iti) + if (kb(i) > 0) then + dtdwn (i,k) = gtt(i,k) + dqvdwn(i,k) = gtq(i,k,1) + dqldwn(i,k) = gtq(i,k,itl) + dqidwn(i,k) = gtq(i,k,iti) + endif + enddo + enddo + do n=ntrq,ntr + do k=1,kmax + do i=ists,iens + if (kb(i) > 0) then + dtrdwn(i,k,n) = gtq(i,k,n) + endif + enddo enddo enddo else @@ -2992,6 +2956,13 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation dqidwn(I,k) = zero enddo enddo + do n=ntrq,ntr + do k=1,kmax + do i=ists,iens + dtrdwn(i,k,n) = zero + enddo + enddo + enddo endif endif ! @@ -3001,6 +2972,11 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation GCUD(I) = zero GCVD(I) = zero enddo + do n=ntrq,ntr + do i=ists,iens + GCtrD (I,n) = zero + enddo + enddo ! DO K=KTMX,1,-1 ! loop A kp1 = min(k+1,kmax) @@ -3008,212 +2984,238 @@ SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation ! < precipitation melt & freeze > ! DO I=ISTS,IENS - GTPRP = GPRCP(I,KP1) + GSNWP(I,KP1) - IF (GTPRP > zero) THEN - FSNOW(I) = GSNWP(I,KP1) / GTPRP - ELSE - FSNOW(I) = zero - ENDIF - LVIC = ELocp + EMELTocp*FSNOW(I) - GDTW = GDT(I,K) - LVIC*(GDQS(I,K) - GDQ(I,K,1)) & + if (kb(i) > 0) then + GTPRP = GPRCP(I,KP1) + GSNWP(I,KP1) + IF (GTPRP > zero) THEN + FSNOW(I) = GSNWP(I,KP1) / GTPRP + ELSE + FSNOW(I) = zero + ENDIF + LVIC = ELocp + EMELTocp*FSNOW(I) + GDTW = GDT(I,K) - LVIC*(GDQS(I,K) - GDQ(I,K,1)) & / (one + LVIC*FDQS(I,K)) - IF (GDTW < TWSNOW) THEN - GSNWP(I,K) = GSNWP(I,KP1) + GPRCI(I,K) + GSNWI(I,K) - GTTEV(I,K) = EMELToCP*GPRCI(I,K) * GRAV/DELP(I,K) - SNMLT(I,K) = -GPRCI(I,K) - ELSE - DZ = GDZM(I,KP1) - GDZM(I,K) - FMELT = (one + FTMLT*(GDTW - TWSNOW)) & - * (one - TANH(GMFLX(I,KP1)/GMFLXC)) & - * (one - TANH(VTERMS*MELTAU/DZ)) - SNMLT(I,K) = GSNWP(I,KP1)*max(min(FMELT, one), zero) - GSNWP(I,K) = GSNWP(I,KP1)+GSNWI(I,K) - SNMLT(I,K) - GPRCP(I,K) = GPRCP(I,KP1)+GPRCI(I,K) + SNMLT(I,K) - GTTEV(I,K) = -EMELToCP*SNMLT(I,K) * GRAV/DELP(I,K) - ENDIF + IF (GDTW < TWSNOW) THEN + GSNWP(I,K) = GSNWP(I,KP1) + GPRCI(I,K) + GSNWI(I,K) + GTTEV(I,K) = EMELToCP * GPRCI(I,K) * DELPI(I,K) + SNMLT(I,K) = -GPRCI(I,K) + ELSE + DZ = GDZM(I,KP1) - GDZM(I,K) + FMELT = (one + FTMLT*(GDTW - TWSNOW)) & + * (one - TANH(GMFLX(I,KP1)/GMFLXC)) & + * (one - TANH(VTERMS*MELTAU/DZ)) + SNMLT(I,K) = GSNWP(I,KP1)*max(min(FMELT, one), zero) + GSNWP(I,K) = GSNWP(I,KP1)+GSNWI(I,K) - SNMLT(I,K) + GPRCP(I,K) = GPRCP(I,KP1)+GPRCI(I,K) + SNMLT(I,K) + GTTEV(I,K) = -EMELToCP * SNMLT(I,K) * DELPI(I,K) + ENDIF !DD heating rate due to precip melting for AW - gtmelt(i,k) = gtmelt(i,k) + GTTEV(I,K) + gtmelt(i,k) = gtmelt(i,k) + GTTEV(I,K) + endif ENDDO ! ! < downdraft > ! DO I=ISTS,IENS ! loop B - wrk = grav / delp(i,k) - wrk1 = oneocp * wrk - DZ = GDZM(I,KP1) - GDZM(I,K) - FEVP = (one - TANH(EVATAU*VTERM/DZ)) - IF (GMDD(I,KP1) > zero) THEN - GCHX = GCHD(I) / GMDD(I,KP1) - GCTX = GDT(I,K) + (GCHX-GDHS(I,K)) / (CP+EL*FDQS(I,K)) - GCQSX = GDQS(I,K) + FDQS(I,K) * (GCTX - GDT(I,K)) - GCQSX = GCQSX*GMDD(I,KP1) - EVSU = MAX(GCQSX-GCWD(I), zero) * FEVP - GTPRP = GPRCP(I,K) + GSNWP(I,K) - IF (GTPRP > zero) THEN - FSNOW(I) = GSNWP(I,K) / GTPRP - ELSE - FSNOW(I) = zero - ENDIF - EVAPD(I,K) = min(EVSU*(one-FSNOW(I)), GPRCP(I,K)) - SUBLD(I,K) = min(EVSU*FSNOW(I), GSNWP(I,K)) - GPRCP(I,K) = GPRCP(I,K) - EVAPD(I,K) - GSNWP(I,K) = GSNWP(I,K) - SUBLD(I,K) + if (kb(i) > 0) then + wrk = delpi(i,k) + wrk1 = oneocp * wrk + DZ = GDZM(I,KP1) - GDZM(I,K) + FEVP = (one - TANH(EVATAU*VTERM/DZ)) + IF (GMDD(I,KP1) > zero) THEN + GCHX = GCHD(I) / GMDD(I,KP1) + GCTX = GDT(I,K) + (GCHX-GDHS(I,K)) / (CP+EL*FDQS(I,K)) + GCQSX = GDQS(I,K) + FDQS(I,K) * (GCTX - GDT(I,K)) + GCQSX = GCQSX*GMDD(I,KP1) + EVSU = MAX(GCQSX-GCWD(I), zero) * FEVP + GTPRP = GPRCP(I,K) + GSNWP(I,K) + IF (GTPRP > zero) THEN + FSNOW(I) = GSNWP(I,K) / GTPRP + ELSE + FSNOW(I) = zero + ENDIF + EVAPD(I,K) = min(EVSU*(one-FSNOW(I)), GPRCP(I,K)) + SUBLD(I,K) = min(EVSU*FSNOW(I), GSNWP(I,K)) + GPRCP(I,K) = GPRCP(I,K) - EVAPD(I,K) + GSNWP(I,K) = GSNWP(I,K) - SUBLD(I,K) ! temperature tendencies due to evaporation and sublimation of precip ! This is within downdraft - gtevap(i,k) = gtevap(i,k) - elocp * evapd(i,k) * wrk - gtsubl(i,k) = gtsubl(i,k) - esubocp * subld(i,k) * wrk - GCWD(I) = GCWD(I) + EVAPD(I,K) + SUBLD(I,K) - GCHD(I) = GCHD(I) - EMELT*SUBLD(I,K) - ENDIF + gtevap(i,k) = gtevap(i,k) - elocp * evapd(i,k) * wrk + gtsubl(i,k) = gtsubl(i,k) - esubocp * subld(i,k) * wrk + GCWD(I) = GCWD(I) + EVAPD(I,K) + SUBLD(I,K) + GCHD(I) = GCHD(I) - EMELT*SUBLD(I,K) + ENDIF - GMDD(I,K) = GMDD(I,KP1) + GMDD(I,K) = GMDD(I,KP1) ! - LVIC = ELocp + EMELTocp*FSNOW(I) - DQW = (GDQS(I,K) - GDW(I,K)) / (one + LVIC*FDQS(I,K)) - DQW = MAX(DQW, zero) - DTW = LVIC*DQW - GDQW = GDW(I,K) + DQW*FEVP + LVIC = ELocp + EMELTocp*FSNOW(I) + DQW = (GDQS(I,K) - GDW(I,K)) / (one + LVIC*FDQS(I,K)) + DQW = MAX(DQW, zero) + DTW = LVIC*DQW + GDQW = GDW(I,K) + DQW*FEVP ! - EVSU = min(one, EVAPOVTRM*DQW*DZ*FEVP) - EVAPE(I,K) = EVSU*GPRCP(I,K) - SUBLE(I,K) = EVSU*GSNWP(I,K) - GTEVP(I,K) = EVAPD(I,K) + SUBLD(I,K) + EVAPE(I,K) + SUBLE(I,K) + EVSU = min(one, EVAPOVTRM*DQW*DZ*FEVP) + EVAPE(I,K) = EVSU*GPRCP(I,K) + SUBLE(I,K) = EVSU*GSNWP(I,K) + GTEVP(I,K) = EVAPD(I,K) + SUBLD(I,K) + EVAPE(I,K) + SUBLE(I,K) ! - GTPRP = GPRCP(I,K) + GSNWP(I,K) - GPRCP(I,K) = GPRCP(I,K) - EVAPE(I,K) - GSNWP(I,K) = GSNWP(I,K) - SUBLE(I,K) + GTPRP = GPRCP(I,K) + GSNWP(I,K) + GPRCP(I,K) = GPRCP(I,K) - EVAPE(I,K) + GSNWP(I,K) = GSNWP(I,K) - SUBLE(I,K) ! additional temperature tendencies due to evaporation and sublimation of precip ! This is outside of downdraft - gtevap(i,k) = gtevap(i,k) - el*evape(i,k) * wrk1 - gtsubl(i,k) = gtsubl(i,k) - (el+emelt)*suble(i,k) * wrk1 -! - GMDDD(I) = zero - IF (GDZ(I,K)-GDZM(I,1) > ZDMIN) THEN - GTEVE = EVAPE(I,K) + SUBLE(I,K) - GMDDMX = REVPDD*GTEVE/MAX(DQW, 1.D-10) - GMDDE(I,K) = RDDR * (DTW*GTPRP*DELP(I,K)) - GMDDE(I,K) = MAX(MIN(GMDDE(I,K), GMDDMX), zero) - GMDDX = GMDD(I,KP1) + GMDDE(I,K) - EVSU = GMDDE(I,K)*DQW*FEVP - IF (GTEVE > zero) THEN - FSNOW(I) = SUBLE(I,K) / GTEVE - ELSE - FSNOW(I) = zero - END IF - EVAPX(I,K) = (one-FSNOW(I)) * EVSU - SUBLX(I,K) = FSNOW(I) * EVSU -! - IF (GMDDX > zero) THEN - GDHI = GDH(I,K) - EMELT*GDQI(I,K) - GCHDX = GCHD(I) + GDHI*GMDDE(I,K) - EMELT*SUBLX(I,K) - GCWDX = GCWD(I) + GDQW*GMDDE(I,K) - GCSD = (GCHDX - EL*GCWDX) / GMDDX - IF (GCSD < GDS(I,K)) THEN - GCHD(I) = GCHDX - GCWD(I) = GCWDX - GCUD(I) = GCUD(I) + GDU(I,K)*GMDDE(I,K) - GCVD(I) = GCVD(I) + GDV(I,K)*GMDDE(I,K) - GMDD(I,K) = GMDDX - EVAPE(I,K) = EVAPE(I,K) - EVAPX(I,K) - SUBLE(I,K) = SUBLE(I,K) - SUBLX(I,K) - EVAPD(I,K) = EVAPD(I,K) + EVAPX(I,K) - SUBLD(I,K) = SUBLD(I,K) + SUBLX(I,K) - GMDDD(I) = zero + gtevap(i,k) = gtevap(i,k) - el*evape(i,k) * wrk1 + gtsubl(i,k) = gtsubl(i,k) - (el+emelt)*suble(i,k) * wrk1 +! + GMDDD(I) = zero + IF (GDZ(I,K)-GDZM(I,1) > ZDMIN) THEN + GTEVE = EVAPE(I,K) + SUBLE(I,K) + GMDDMX = REVPDD*GTEVE/MAX(DQW, 1.D-10) + GMDDE(I,K) = RDDR * (DTW*GTPRP*DELP(I,K)) + GMDDE(I,K) = MAX(MIN(GMDDE(I,K), GMDDMX), zero) + GMDDX = GMDD(I,KP1) + GMDDE(I,K) + EVSU = GMDDE(I,K)*DQW*FEVP + IF (GTEVE > zero) THEN + FSNOW(I) = SUBLE(I,K) / GTEVE ELSE - GMDDE(I,K) = zero - GMDDD(I) = GMDD(I,KP1) + FSNOW(I) = zero + END IF + EVAPX(I,K) = (one-FSNOW(I)) * EVSU + SUBLX(I,K) = FSNOW(I) * EVSU +! + IF (GMDDX > zero) THEN + GDHI = GDH(I,K) - EMELT*GDQI(I,K) + GCHDX = GCHD(I) + GDHI*GMDDE(I,K) - EMELT*SUBLX(I,K) + GCWDX = GCWD(I) + GDQW*GMDDE(I,K) + GCSD = (GCHDX - EL*GCWDX) / GMDDX + IF (GCSD < GDS(I,K)) THEN + GCHD(I) = GCHDX + GCWD(I) = GCWDX + GCUD(I) = GCUD(I) + GDU(I,K)*GMDDE(I,K) + GCVD(I) = GCVD(I) + GDV(I,K)*GMDDE(I,K) + do n = ntrq,ntr + GCtrD(I,n) = GCtrD(I,n) + GDq(I,K,n)*GMDDE(I,K) + enddo + GMDD(I,K) = GMDDX + EVAPE(I,K) = EVAPE(I,K) - EVAPX(I,K) + SUBLE(I,K) = SUBLE(I,K) - SUBLX(I,K) + EVAPD(I,K) = EVAPD(I,K) + EVAPX(I,K) + SUBLD(I,K) = SUBLD(I,K) + SUBLX(I,K) + GMDDD(I) = zero + ELSE + GMDDE(I,K) = zero + GMDDD(I) = GMDD(I,KP1) + ENDIF ENDIF + ELSE + GMDDD(I) = DZ / (GDZM(I,KP1)-GDZM(I,1)) * GMDD(I,KP1) ENDIF - ELSE - GMDDD(I) = DZ / (GDZM(I,KP1)-GDZM(I,1)) * GMDD(I,KP1) - ENDIF ! - GMDDD(I) = MAX(GMDDD(I), GMDD(I,K)-RDDMX*GMFLX(I,K)) -! - IF (GMDDD(I) > zero) THEN - FDET = GMDDD(I)/GMDD(I,K) - GCHDD(I,K) = FDET*GCHD(I) - GCWDD(I,K) = FDET*GCWD(I) - GCUDD = FDET*GCUD(I) - GCVDD = FDET*GCVD(I) -! - GTHCI = wrk * (GCHDD(I,K) - GMDDD(I)*GDH(I,K)) - GTQVCI = wrk * (GCWDD(I,K) - GMDDD(I)*GDQ(I,K,1)) - GTQLCI = -wrk * GMDDD(I)*GDQ(I,K,ITL) - GTQICI = -wrk * GMDDD(I)*GDQI(I,K) -! - GTT (I,K) = GTT(I,K) + (GTHCI - EL*GTQVCI)*oneoCP - GTQ (I,K,1) = GTQ(I,K,1) + GTQVCI - GTQ (I,K,ITL) = GTQ(I,K,ITL) + GTQLCI - GTQ (I,K,ITI) = GTQ(I,K,ITI) + GTQICI -! GTQI(I,K) = GTQI(I,K) + GTQICI - - GTU (I,K) = GTU(I,K) + wrk * (GCUDD - GMDDD(I)*GDU(I,K)) - GTV (I,K) = GTV(I,K) + wrk * (GCVDD - GMDDD(I)*GDV(I,K)) -! - GCHD(I) = GCHD(I) - GCHDD(I,K) - GCWD(I) = GCWD(I) - GCWDD(I,K) - GCUD(I) = GCUD(I) - GCUDD - GCVD(I) = GCVD(I) - GCVDD - GMDD(I,K) = GMDD(I,K) - GMDDD(I) - ENDIF - GCdseD(I,K) = GCHD(I) - el*GCWD(I) - GCqvD (I,K) = GCWD(I) + GMDDD(I) = MAX(GMDDD(I), GMDD(I,K)-RDDMX*GMFLX(I,K)) +! + IF (GMDDD(I) > zero) THEN + FDET = GMDDD(I)/GMDD(I,K) + GCHDD(I,K) = FDET*GCHD(I) + GCWDD(I,K) = FDET*GCWD(I) + GCUDD = FDET*GCUD(I) + GCVDD = FDET*GCVD(I) + do n = ntrq,ntr + GCtrDD(n) = FDET*GCtrD(I,n) + enddo +! + GTHCI = wrk * (GCHDD(I,K) - GMDDD(I)*GDH(I,K)) + GTQVCI = wrk * (GCWDD(I,K) - GMDDD(I)*GDQ(I,K,1)) +! + GTT (I,K) = GTT(I,K) + (GTHCI - EL*GTQVCI)*oneoCP + GTQ (I,K,1) = GTQ(I,K,1) + GTQVCI + GTQ (I,K,ITL) = GTQ(I,K,ITL) - wrk * GMDDD(I)*GDQ(I,K,ITL) + GTQ (I,K,ITI) = GTQ(I,K,ITI) - wrk * GMDDD(I)*GDQI(I,K) + + do n = ntrq,ntr + GTQ (I,K,n) = GTQ(I,K,n) + wrk * (GCtrDD(n) - GMDDD(I)*GDQ(I,K,n)) + GCtrD(I,n) = GCtrD(I,n) - GCtrDD(n) + enddo + + GTU (I,K) = GTU(I,K) + wrk * (GCUDD - GMDDD(I)*GDU(I,K)) + GTV (I,K) = GTV(I,K) + wrk * (GCVDD - GMDDD(I)*GDV(I,K)) +! + GCHD(I) = GCHD(I) - GCHDD(I,K) + GCWD(I) = GCWD(I) - GCWDD(I,K) + GCUD(I) = GCUD(I) - GCUDD + GCVD(I) = GCVD(I) - GCVDD + GMDD(I,K) = GMDD(I,K) - GMDDD(I) + ENDIF + GCdseD(I,K) = GCHD(I) - el*GCWD(I) + GCqvD (I,K) = GCWD(I) + endif ENDDO ! loop B ! ENDDO ! loop A ! - do i=ists,iens - tx1(i) = GRAV / DELP(I,1) - enddo DO K=1,KTMX kp1 = min(k+1,kmax) DO I=ISTS,IENS - wrk = tx1(i) - tx1(i) = GRAV / DELP(I,kp1) - - GTTEV(I,K) = GTTEV(I,K) - wrk & - * (ELocp*EVAPE(I,K)+(ELocp+EMELTocp)*SUBLE(I,K)) - GTT(I,K) = GTT(I,K) + GTTEV(I,K) + if (kb(i) > 0) then + wrk = DELPI(I,k) + tx1 = DELPI(I,kp1) + + GTTEV(I,K) = GTTEV(I,K) - wrk & + * (ELocp*EVAPE(I,K)+(ELocp+EMELTocp)*SUBLE(I,K)) + GTT(I,K) = GTT(I,K) + GTTEV(I,K) ! - GTQEV(I,K) = GTQEV(I,K) + (EVAPE(I,K)+SUBLE(I,K)) * wrk - GTQ(I,K,1) = GTQ(I,K,1) + GTQEV(I,K) + GTQEV(I,K) = GTQEV(I,K) + (EVAPE(I,K)+SUBLE(I,K)) * wrk + GTQ(I,K,1) = GTQ(I,K,1) + GTQEV(I,K) ! - GMFLX(I,K) = GMFLX(I,K) - GMDD(I,K) + GMFLX(I,K) = GMFLX(I,K) - GMDD(I,K) ! AW tendencies due to vertical divergence of eddy fluxes - if (do_awdd .and. k > 1) then - fsigma = one - sigmad(i,kp1) - dp_below = wrk * (one - sigmad(i,k)) - dp_above = tx1(i) * (one - sigmad(i,kp1)) - - wrk1 = gmdd(i,kp1) * (gdt(i,k)+gocp*gdz(i,k)) - gcdsed(i,kp1)*oneocp - wrk2 = gmdd(i,kp1) * gdq(i,k,1) - gcqvd(i,kp1) - wrk3 = gmdd(i,kp1) * gdq(i,k,itl) - wrk4 = gmdd(i,kp1) * gdqi(i,k) - - dtdwn(i,k) = dtdwn(i,k) + dp_below * wrk1 - dqvdwn(i,k) = dqvdwn(i,k) + dp_below * wrk2 - dqldwn(i,k) = dqldwn(i,k) + dp_below * wrk3 ! gcqld=0 - gcqld(i,k)) - dqidwn(i,k) = dqidwn(i,k) + dp_below * wrk4 ! gcqid=0 - gcqid(i,k)) - - dtdwn(i,kp1) = dtdwn(i,kp1) - dp_above * wrk1 - dqvdwn(i,kp1) = dqvdwn(i,kp1) - dp_above * wrk2 - dqldwn(i,kp1) = dqldwn(i,kp1) - dp_above * wrk3 ! gcqld=0 - gcqld(i,k)) - dqidwn(i,kp1) = dqidwn(i,kp1) - dp_above * wrk4 ! gcqid=0 - gcqid(i,k)) - endif + if (do_awdd .and. k > 1 .and. flx_form) then + fsigma = one - sigmad(i,kp1) + dp_below = wrk * (one - sigmad(i,k)) + dp_above = tx1 * (one - sigmad(i,kp1)) + + wrk1 = gmdd(i,kp1) * (gdt(i,k)+gocp*gdz(i,k)) - gcdsed(i,kp1)*oneocp + wrk2 = gmdd(i,kp1) * gdq(i,k,1) - gcqvd(i,kp1) + wrk3 = gmdd(i,kp1) * gdq(i,k,itl) + wrk4 = gmdd(i,kp1) * gdqi(i,k) + + dtdwn(i,k) = dtdwn(i,k) + dp_below * wrk1 + dqvdwn(i,k) = dqvdwn(i,k) + dp_below * wrk2 + dqldwn(i,k) = dqldwn(i,k) + dp_below * wrk3 ! gcqld=0 - gcqld(i,k)) + dqidwn(i,k) = dqidwn(i,k) + dp_below * wrk4 ! gcqid=0 - gcqid(i,k)) + + dtdwn(i,kp1) = dtdwn(i,kp1) - dp_above * wrk1 + dqvdwn(i,kp1) = dqvdwn(i,kp1) - dp_above * wrk2 + dqldwn(i,kp1) = dqldwn(i,kp1) - dp_above * wrk3 ! gcqld=0 - gcqld(i,k)) + dqidwn(i,kp1) = dqidwn(i,kp1) - dp_above * wrk4 ! gcqid=0 - gcqid(i,k)) + do n = ntrq,ntr + wrkn = gmdd(i,kp1) * gdq(i,k,n) + dtrdwn(i,k,n) = dtrdwn(i,k,n) + dp_below * wrkn + dtrdwn(i,kp1,n) = dtrdwn(i,kp1,n) - dp_above * wrkn + enddo + endif + endif ENDDO ! end of i loop ENDDO ! end of k loop ! - if (.not. do_awdd) then + if (.not. do_awdd .and. flx_form) then do k=1,kmax do i=ists,iens - dtdwn(i,k) = gtt(i,k) - dtdwn(i,k) - dqvdwn(i,k) = gtq(i,k,1) - dqvdwn(i,k) - dqldwn(i,k) = gtq(i,k,itl) - dqldwn(i,k) - dqidwn(i,k) = gtq(i,k,iti) - dqidwn(i,k) -!! dqidwn(i,k) = gtqi(i,k) - dqidwn(i,k) + if (kb(i) > 0) then + dtdwn(i,k) = gtt(i,k) - dtdwn(i,k) + dqvdwn(i,k) = gtq(i,k,1) - dqvdwn(i,k) + dqldwn(i,k) = gtq(i,k,itl) - dqldwn(i,k) + dqidwn(i,k) = gtq(i,k,iti) - dqidwn(i,k) + endif + enddo + enddo + do n=ntrq,ntr + do k=1,kmax + do i=ists,iens + if (kb(i) > 0) then + dtrdwn(i,k,n) = gtq(i,k,n) - dtrdwn(i,k,n) + endif + enddo enddo enddo endif @@ -3247,20 +3249,14 @@ SUBROUTINE CUMCLD & !! cloudiness ! [WORK] INTEGER I, K REAL(r8) CUMF, QC, wrk - LOGICAL, SAVE :: OFIRST = .TRUE. ! ! [INTERNAL PARAM] - REAL(r8) :: FACLW = 0.1_r8 ! Mc->CLW - REAL(r8) :: CMFMIN = 2.e-3_r8 ! Mc->cloudiness - REAL(r8) :: CMFMAX = 3.e-1_r8 ! Mc->cloudiness - REAL(r8) :: CLMIN = 1.e-3_r8 ! cloudiness Min. - REAL(r8) :: CLMAX = 0.1_r8 ! cloudiness Max. - REAL(r8), SAVE :: FACLF -! - IF (OFIRST) THEN - FACLF = (CLMAX-CLMIN) / LOG(CMFMAX/CMFMIN) - OFIRST = .FALSE. - END IF + REAL(r8), parameter :: CMFMIN = 2.e-3_r8, &! Mc->cloudiness + CMFMAX = 3.e-1_r8, &! Mc->cloudiness + CLMIN = 1.e-3_r8, &! cloudiness Min. + CLMAX = 0.1_r8, &! cloudiness Max. + FACLW = 0.1_r8, &! Mc->CLW + FACLF = (CLMAX-CLMIN)/LOG(CMFMAX/CMFMIN) ! CUMFRC(ISTS:IENS) = zero DO K=1,KTMX @@ -3295,11 +3291,11 @@ END SUBROUTINE CUMCLD SUBROUTINE CUMUPR & !! Tracer Updraft ( im , IJSDIM, KMAX , NTR , & !DD dimensions GTR , GPRCC , & ! modified - GDR , CBMFX , ELAM , GDZ , GDZM , & ! input + GDR , CBMFX , & ! input GCYM , GCYT , GCQT , GCLT , GCIT , & ! input GTPRT , GTEVP , GTPRC0, & ! input KB , KBMX , KT , KTMX , KTMXT , & ! input - DELP , OTSPT , ISTS , IENS, & ! input + DELPI , OTSPT , ISTS , IENS, & ! input fscav, fswtr, nctp) ! IMPLICIT NONE @@ -3313,10 +3309,7 @@ SUBROUTINE CUMUPR & !! Tracer Updraft ! [INPUT] REAL(r8) GDR (IJSDIM, KMAX, NTR) REAL(r8) CBMFX (IM, NCTP) - REAL(r8) ELAM (IJSDIM, KMAX, NCTP) - REAL(r8) GDZ (IJSDIM, KMAX) - REAL(r8) GDZM (IJSDIM, KMAX+1) - REAL(r8) GCYM (IJSDIM, KMAX) + REAL(r8) GCYM (IJSDIM, KMAX, nctp) REAL(r8) GCYT (IJSDIM, NCTP) REAL(r8) GCQT (IJSDIM, NCTP) REAL(r8) GCLT (IJSDIM, NCTP) @@ -3330,7 +3323,7 @@ SUBROUTINE CUMUPR & !! Tracer Updraft INTEGER KT (IJSDIM, NCTP) INTEGER KTMX (NCTP) INTEGER KTMXT - REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) DELPI (IJSDIM, KMAX) LOGICAL OTSPT (NTR) !! transport with this routine? INTEGER ISTS, IENS ! @@ -3339,15 +3332,9 @@ SUBROUTINE CUMUPR & !! Tracer Updraft REAL(r8) :: GCRTD, SCAV, GCWT, GPRCR, evpf, cbmfxl REAL(r8), dimension(ists:iens) :: GCRB, GCRT, DR, gtprc0i ! REAL(r8), dimension(ists:iens,kmax) :: DGCB, DZ, RDZM, EVPF - REAL(r8), dimension(ists:iens,kmax) :: DZ, RDZM ! REAL(r8), dimension(ists:iens,nctp) :: DZT, RGCWT, MASK1, MASK2 - REAL(r8), dimension(ists:iens,nctp) :: DZT, RGCWT, MASK1 + REAL(r8), dimension(ists:iens,nctp) :: RGCWT, MASK1 ! -! DO K=1,KBMX -! DO I=ISTS,IENS -! DGCB(I,K) = GCYM(I,K+1) - GCYM(I,K) -! ENDDO -! ENDDO do i=ists,iens if (gtprc0(i) > zero) then gtprc0i(i) = one / gtprc0(i) @@ -3355,16 +3342,6 @@ SUBROUTINE CUMUPR & !! Tracer Updraft gtprc0i(i) = zero endif enddo - DO K=1,KTMXT - DO I=ISTS,IENS - DZ (I,K) = GDZM(I,K+1) - GDZM(I,K) - RDZM(I,K) = GRAV / DELP(I,K) -! EVPF(I,K) = zero -! IF (GTPRC0(I) > zero) THEN -! EVPF(I,K) = GTEVP(I,K) / GTPRC0(I) -! ENDIF - ENDDO - ENDDO DO CTP=1,NCTP DO I=ISTS,IENS K = KT(I,CTP) @@ -3376,10 +3353,8 @@ SUBROUTINE CUMUPR & !! Tracer Updraft ENDIF ! MASK1(I,CTP) = zero - DZT (I,CTP) = zero - IF (K > KB(I)) THEN + IF (kb(i) > 0 .and. K > KB(I)) THEN MASK1(I,CTP) = one - DZT (I,CTP) = GDZ(I,K) - GDZM(I,K) ENDIF ! MASK2(I,CTP) = zero ! IF (CBMFX(I,CTP) > zero) then @@ -3391,55 +3366,58 @@ SUBROUTINE CUMUPR & !! Tracer Updraft DO LT=1,NTR ! outermost tracer LT loop ! IF (OTSPT(LT)) THEN - GCRB = zero - DO K=1,KBMX + DO CTP=1,NCTP DO I=ISTS,IENS - IF (K < KB(I)) THEN -! GCRB(I) = GCRB(I) + DGCB(I,K) * GDR(I,K,LT) - GCRB(I) = GCRB(I) + (GCYM(I,K+1)-GCYM(I,K))* GDR(I,K,LT) - ENDIF + GCRB(i) = zero + DR(i) = zero + enddo + DO K=1,KBMX + DO I=ISTS,IENS + IF (kb(i) > 0 .and. K < KB(I)) THEN + GCRB(I) = GCRB(I) + (GCYM(I,K+1,ctp)-GCYM(I,K,ctp))* GDR(I,K,LT) + ENDIF + ENDDO ENDDO - ENDDO ! - DO CTP=1,NCTP - DR = zero DO K=2,KTMX(CTP) DO I=ISTS,IENS - IF (K >= KB(I) .AND. K < KT(I,CTP)) THEN - DR(I) = DR(I) + DZ(I,K) * ELAM(I,K,CTP) * GDR(I,K,LT) + IF (kb(i) > 0 .and. K >= KB(I) .AND. K < KT(I,CTP)) THEN + DR(I) = DR(I) + (GCYM(I,K+1,ctp)-GCYM(I,K,ctp)) * GDR(I,K,LT) ENDIF ENDDO ENDDO ! DO I=ISTS,IENS - K = MAX(KT(I,CTP),1) - DR(I) = DR(I) + DZT(I,CTP) * ELAM(I,K,CTP) * GDR (I,K,LT) & - * MASK1(I,CTP) - GCRT(I) = (GCRB(I) + DR(I)) * MASK1(I,CTP) -! - SCAV = FSCAV(LT)*GTPRT(I,CTP) + FSWTR(LT)*GTPRT(I,CTP)*RGCWT(I,CTP) - SCAV = MIN(SCAV, one) - GCRTD = GCRT(I) * (one - SCAV) - cbmfxl = max(zero, CBMFX(I,CTP)) - GPRCR = SCAV * GCRT(I) * CBMFXl - - GTR(I,K,LT) = GTR(I,K,LT) + RDZM(I,K) * CBMFXl & - * (GCRTD - GCYT(I,CTP) * GDR(I,K,LT)) - GPRCC(I,LT) = GPRCC(I,LT) + GPRCR - -! GPRCR = SCAV * GCRT(I) * CBMFX(I,CTP) -! GTR(I,K,LT) = GTR(I,K,LT) + RDZM(I,K) * CBMFX(I,CTP) & + K = KT(I,CTP) + if (kb(i) > 0 .and. k > kb(i)) then + DR(I) = DR(I) + (GCYT(I,CTP) - GCYM(I,K,ctp)) * GDR (I,K,LT) & + * MASK1(I,CTP) + GCRT(I) = (GCRB(I) + DR(I)) * MASK1(I,CTP) +! + SCAV = FSCAV(LT)*GTPRT(I,CTP) + FSWTR(LT)*GTPRT(I,CTP)*RGCWT(I,CTP) + SCAV = MIN(SCAV, one) + GCRTD = GCRT(I) * (one - SCAV) + cbmfxl = max(zero, CBMFX(I,CTP)) + GPRCR = SCAV * GCRT(I) * CBMFXl + + GTR(I,K,LT) = GTR(I,K,LT) + DELPI(I,K) * CBMFXl & + * (GCRTD - GCYT(I,CTP) * GDR(I,K,LT)) + GPRCC(I,LT) = GPRCC(I,LT) + GPRCR + +! GPRCR = SCAV * GCRT(I) * CBMFX(I,CTP) +! GTR(I,K,LT) = GTR(I,K,LT) + DELPI(I,K) * CBMFX(I,CTP) & ! * (GCRTD - GCYT(I,CTP) * GDR(I,K,LT)) * MASK2(I,CTP) -! GPRCC(I,LT) = GPRCC(I,LT) + GPRCR * MASK2(I,CTP) +! GPRCC(I,LT) = GPRCC(I,LT) + GPRCR * MASK2(I,CTP) + endif ENDDO ENDDO ! DO K=KTMXT,1,-1 DO I=ISTS,IENS evpf = GTEVP(i,k) * gtprc0i(i) - GTR(I,K,LT) = GTR(I,K,LT) + RDZM(I,K) * GPRCC(I,LT) * EVPF + GTR(I,K,LT) = GTR(I,K,LT) + DELPI(I,K) * GPRCC(I,LT) * EVPF GPRCC(I,LT) = GPRCC(I,LT) * (one - EVPF) -! GTR(I,K,LT) = GTR(I,K,LT) + RDZM(I,K) * GPRCC(I,LT) * EVPF(I,K) +! GTR(I,K,LT) = GTR(I,K,LT) + DELPI(I,K) * GPRCC(I,LT) * EVPF(I,K) ! GPRCC(I,LT) = GPRCC(I,LT) * (one - EVPF(I,K)) ENDDO ENDDO @@ -3453,7 +3431,7 @@ END SUBROUTINE CUMUPR SUBROUTINE CUMDNR & !! Tracer Downdraft ( IM , IJSDIM, KMAX , NTR , & !DD dimensions GTR , & ! modified - GDR , GMDD , DELP , & ! input + GDR , GMDD , DELPI , & ! input KTMX , OTSPT , ISTS , IENS ) ! input ! IMPLICIT NONE @@ -3466,7 +3444,7 @@ SUBROUTINE CUMDNR & !! Tracer Downdraft ! [INPUT] REAL(r8) GDR (IJSDIM, KMAX, NTR) REAL(r8) GMDD (IJSDIM, KMAX) ! downdraft mass flux - REAL(r8) DELP (IJSDIM, KMAX ) + REAL(r8) DELPI (IJSDIM, KMAX ) LOGICAL OTSPT (NTR) INTEGER KTMX, ISTS, IENS ! @@ -3488,7 +3466,7 @@ SUBROUTINE CUMDNR & !! Tracer Downdraft ELSEIF (GMDD(I,KP1) > zero) THEN GMDDD = - GMDDE GCRDD = GMDDD/GMDD(I,KP1) * GCRD(I) - GTR(I,K,LT) = GTR(I,K,LT) + GRAV/DELP(I,K) & + GTR(I,K,LT) = GTR(I,K,LT) + DELPI(I,K) & * (GCRDD - GMDDD*GDR(I,K,LT)) GCRD(I) = GCRD(I) - GCRDD ENDIF @@ -3502,7 +3480,7 @@ END SUBROUTINE CUMDNR SUBROUTINE CUMSBR & !! Tracer Subsidence ( IM , IJSDIM, KMAX , NTR , & !DD dimensions GTR , & ! modified - GDR , DELP , & ! input + GDR , DELPI , & ! input GMFLX , KTMX , OTSPT , & ! input ISTS, IENS ) ! input ! @@ -3515,7 +3493,7 @@ SUBROUTINE CUMSBR & !! Tracer Subsidence ! ! [INPUT] REAL(r8) GDR (IJSDIM, KMAX, NTR) !! tracer - REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) DELPI (IJSDIM, KMAX) REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux INTEGER KTMX LOGICAL OTSPT (NTR) !! tracer transport on/off @@ -3542,7 +3520,7 @@ SUBROUTINE CUMSBR & !! Tracer Subsidence ELSE FX1 = zero END IF - GTR(I,K,LT) = GTR(I,K,LT) + GRAV/DELP(I,K) & + GTR(I,K,LT) = GTR(I,K,LT) + DELPI(I,K) & * ((one-FX(I))*SBR0 + FX1*SBR1) FX(I) = FX1 ENDDO @@ -3578,6 +3556,8 @@ SUBROUTINE CUMFXR & ! Tracer mass fixe ! e.g. moisture, liquid cloud, ice cloud, aerosols ! 2: mass fixer is applied, total mass never change through cumulus scheme ! e.g. CO2 + !DD add new CASE + ! 3: just fill holes, no attempt to conserve INTEGER ISTS, IENS ! ! [INTERNAL WORK] @@ -3597,6 +3577,7 @@ SUBROUTINE CUMFXR & ! Tracer mass fixe FWAT = one CASE (2) FWAT = zero + CASE (3) CASE DEFAULT EXIT END SELECT @@ -3604,6 +3585,7 @@ SUBROUTINE CUMFXR & ! Tracer mass fixe DO I=ISTS,IENS TOT0(I) = zero TOT1(I) = zero + TRAT(I) = one enddo ! DO K=KTMX,1,-1 @@ -3618,13 +3600,13 @@ SUBROUTINE CUMFXR & ! Tracer mass fixe ENDDO ENDDO ! + if(imfxr(LT) .ne. 3) then DO I=ISTS,IENS IF (TOT1(I) > zero ) THEN TRAT(I) = MAX(TOT0(I), zero) / TOT1(I) - ELSE - TRAT(I) = one ENDIF ENDDO + endif ! DO K=KTMX,1,-1 DO I=ISTS,IENS @@ -3821,53 +3803,7 @@ SUBROUTINE CUMCHK & ! check range of output va ENDDO ! END SUBROUTINE CUMCHK -!*********************************************************************** - SUBROUTINE TINTP & ! vertical interpolation of temperature - ( IJSDIM, KMAX , & !DD dimensions - GDTM , & ! output - GDT , GDP , GDPM , & ! input - ISTS , IENS ) ! input - - IMPLICIT NONE - INTEGER, INTENT(IN) :: IJSDIM, KMAX ! DD, for GFS, pass in -!* -!* [OUTPUT] - REAL(r8) GDTM (IJSDIM, KMAX+1) ! temperature (half lev) -!* -!* [INPUT] - REAL(r8) GDT (IJSDIM, KMAX) ! temperature (full lev) - REAL(r8) GDP (IJSDIM, KMAX) ! pressure (full lev) - REAL(r8) GDPM (IJSDIM, KMAX+1) ! pressure (half lev) - INTEGER ISTS, IENS ! range of active grids -!* -!* [INTERNAL WORK] -! REAL(r8) FTINT ( KMAX ) ! intrp. coef. -! REAL(r8) FTINTM( KMAX ) ! intrp. coef. - real (r8) :: wrk, wrk1, ftintm - - INTEGER I, K -!* -!* < interp. temp. > -!* - DO K=2,KMAX - DO I=ISTS,IENS - wrk = one / GDP(I,K) - wrk1 = one / LOG(GDP(I,K-1)*wrk) - FTINTM = wrk1 * LOG(GDPM(I,K)*wrk) - GDTM(I,K) = FTINTM *GDT(I,K-1) + (1.0-FTINTM)*GDT(I,K) -! FTINTM( K ) = wrk1 * LOG(GDPM(I,K)*wrk) -! FTINT ( K ) = wrk1 * LOG(GDP(I,K-1)/GDPM(I,K)) -! GDTM( I,K ) = FTINTM(K)*GDT(I,K-1) + FTINT(K)*GDT(I,K) - ENDDO - ENDDO - - DO I = ISTS, IENS - GDTM(I,KMAX+1) = GDT(I,KMAX) - GDTM(I,1 ) = GDT(I,1) - ENDDO - RETURN - END SUBROUTINE TINTP !*********************************************************************** end module cs_conv diff --git a/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 index 63805727b..3a6985aaa 100644 --- a/gfsphysics/physics/gcm_shoc.f90 +++ b/gfsphysics/physics/gcm_shoc.f90 @@ -5,15 +5,21 @@ ! in a single column form suitable for use in a GCM physics package. ! Alex Belochitski, heavily based on the code of Peter Bogenschutz. ! S Moorthi - optimization, cleanup, improve and customize for gsm +! - improved solution for sgs-tke equation +! S Moorthi - 05-11-17 - modified shear production term to eliminate +! spurious tke ove Antarctica. +! S Moorthi - 01-12-17 - added extra pressure dependent tke dissipation at +! pressures below a critical value pcrit +! S Moorthi - 04-12-17 - fixed a bug in the definition of hl on input +! replacing fac_fus by fac_sub subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & prsl, phii, phil, u, v, omega, tabs, & -! qwv, qi, qc, qpi, qpl, cld_sgs, & - qwv, qi, qc, qpi, qpl, rhc, supice, cld_sgs, & - tke, hflx, evap, prnum, tkh, wthv_sec,lprnt,ipr,& - ncpl,ncpi) + qwv, qi, qc, qpi, qpl, rhc, supice, pcrit, & + cld_sgs, tke, hflx, evap, prnum, tkh, & + wthv_sec, lprnt, ipr, ncpl, ncpi) use funcphys , only : fpvsl, fpvsi, fpvs ! saturation vapor pressure for water & ice @@ -36,12 +42,20 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & gocp = ggr/cp, rog = rgas*ggri, sqrt2 = sqrt(2.0), & sqrtpii = 1.0/sqrt(pi+pi), epsterm = rgas/rv, twoby3 = 2.0/3.0, & onebeps = 1.0/epsterm, twoby15 = 2.0 / 15.0, & - onebrvcp= 1.0/(rv*cp), skew_facw=1.2, skew_fact=1.0, & -! onebrvcp= 1.0/(rv*cp), skew_facw=1.2, skew_fact=0.0, & +! onebrvcp= 1.0/(rv*cp), skew_facw=1.2, skew_fact=1.0, & + onebrvcp= 1.0/(rv*cp), skew_facw=1.2, skew_fact=0.0, & +! tkef1=0.5, tkef2=1.0-tkef1, tkhmax=1000.0, cefac=3.0, & tkef1=0.5, tkef2=1.0-tkef1, tkhmax=1000.0, cefac=1.5, & +! tkef1=0.7, tkef2=1.0-tkef1, tkhmax=1000.0, cefac=1.5, & zero=0.0, one=1.0, half=0.5, two=2.0, eps=0.622, & + three=3.0, oneb3=one/three, & + scrit=2.0e-6 + +! scrit=5.0e-8 +! scrit=3.0e-6 +! scrit=1.0e-5 ! scrit=5.0e-6 - scrit=1.0e-5 +! scrit=1.0e-5 ! scrit=1.0e-6 ! skew_facw=1.2, skew_fact=0.5 ! onebeps = 1.0/epsterm, twoby15 = 2.0 / 15.0, skew_facw=1.2 ! orig @@ -59,34 +73,36 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & integer, intent(in) :: nzm ! Number of vertical layers integer, intent(in) :: nz ! Number of layer interfaces (= nzm + 1) real, intent(in) :: dtn ! Physics time step, s + real, intent(in) :: pcrit ! pressure in Pa below which additional tke + ! dissipation is applied real, intent(in) :: hflx(nx) real, intent(in) :: evap(nx) ! The interface is talored to GFS in a sense that input variables are 2D - real, intent(in) :: prsl (ix,ny,nzm) ! mean layer presure - real, intent(in) :: phii (ix,ny,nz ) ! interface geopotential height - real, intent(in) :: phil (ix,ny,nzm) ! layer geopotential height - real, intent(in) :: u (ix,ny,nzm) ! u-wind, m/s - real, intent(in) :: v (ix,ny,nzm) ! v-wind, m/s - real, intent(in) :: omega (ix,ny,nzm) ! omega, Pa/s - real, intent(inout) :: tabs (ix,ny,nzm) ! temperature, K - real, intent(inout) :: qwv (ix,ny,nzm) ! water vapor mixing ratio, kg/kg - real, intent(inout) :: qc (ix,ny,nzm) ! cloud water mixing ratio, kg/kg - real, intent(inout) :: qi (ix,ny,nzm) ! cloud ice mixing ratio, kg/kg + real, intent(in) :: prsl (ix,ny,nzm) ! mean layer presure + real, intent(in) :: phii (ix,ny,nz ) ! interface geopotential height + real, intent(in) :: phil (ix,ny,nzm) ! layer geopotential height + real, intent(in) :: u (ix,ny,nzm) ! u-wind, m/s + real, intent(in) :: v (ix,ny,nzm) ! v-wind, m/s + real, intent(in) :: omega (ix,ny,nzm) ! omega, Pa/s + real, intent(inout) :: tabs (ix,ny,nzm) ! temperature, K + real, intent(inout) :: qwv (ix,ny,nzm) ! water vapor mixing ratio, kg/kg + real, intent(inout) :: qc (ix,ny,nzm) ! cloud water mixing ratio, kg/kg + real, intent(inout) :: qi (ix,ny,nzm) ! cloud ice mixing ratio, kg/kg ! Anning Cheng 03/11/2016 SHOC feedback to number concentration - real, intent(inout) :: ncpl (nx,ny,nzm) ! cloud water number concentration,/m^3 - real, intent(inout) :: ncpi (nx,ny,nzm) ! cloud ice number concentration,/m^3 - real, intent(inout) :: qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg - real, intent(inout) :: qpi (nx,ny,nzm) ! snow mixing ratio, kg/kg - real, intent(inout) :: rhc (nx,ny,nzm) ! critical relative humidity - real, intent(in) :: supice ! ice supersaturation parameter - real, intent(inout) :: cld_sgs(ix,ny,nzm) ! sgs cloud fraction -! real, intent(inout) :: cld_sgs(nx,ny,nzm) ! sgs cloud fraction - real, intent(inout) :: tke (ix,ny,nzm) ! turbulent kinetic energy. m**2/s**2 -! real, intent(inout) :: tk (nx,ny,nzm) ! eddy viscosity - real, intent(inout) :: tkh (ix,ny,nzm) ! eddy diffusivity - real, intent(inout) :: prnum (nx,ny,nzm) ! turbulent Prandtl number + real, intent(inout) :: ncpl (nx,ny,nzm) ! cloud water number concentration,/m^3 + real, intent(inout) :: ncpi (nx,ny,nzm) ! cloud ice number concentration,/m^3 + real, intent(inout) :: qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg + real, intent(inout) :: qpi (nx,ny,nzm) ! snow mixing ratio, kg/kg + real, intent(inout) :: rhc (nx,ny,nzm) ! critical relative humidity + real, intent(in) :: supice ! ice supersaturation parameter + real, intent(inout) :: cld_sgs(ix,ny,nzm) ! sgs cloud fraction +! real, intent(inout) :: cld_sgs(nx,ny,nzm) ! sgs cloud fraction + real, intent(inout) :: tke (ix,ny,nzm) ! turbulent kinetic energy. m**2/s**2 +! real, intent(inout) :: tk (nx,ny,nzm) ! eddy viscosity + real, intent(inout) :: tkh (ix,ny,nzm) ! eddy diffusivity + real, intent(inout) :: prnum (nx,ny,nzm) ! turbulent Prandtl number real, intent(inout) :: wthv_sec (ix,ny,nzm) ! Buoyancy flux, K*m/s ! SHOC tunable parameters @@ -94,20 +110,19 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & real, parameter :: lambda = 0.04 ! real, parameter :: min_tke = 1e-6 ! Minumum TKE value, m**2/s**2 real, parameter :: min_tke = 1e-4 ! Minumum TKE value, m**2/s**2 -! real, parameter :: max_tke = 400.0 ! Maximum TKE value, m**2/s**2 - real, parameter :: max_tke = 225.0 ! Maximum TKE value, m**2/s**2 -! real, parameter :: max_tke = 100.0 ! Maximum TKE value, m**2/s**2 -! real, parameter :: max_tke = 5. ! Maximum TKE value, m**2/s**2 + real, parameter :: max_tke = 100.0 ! Maximum TKE value, m**2/s**2 ! Maximum turbulent eddy length scale, m - real, parameter :: max_eddy_length_scale = 2000. +! real, parameter :: max_eddy_length_scale = 2000. + real, parameter :: max_eddy_length_scale = 1000. ! Maximum "return-to-isotropy" time scale, s real, parameter :: max_eddy_dissipation_time_scale = 2000. real, parameter :: Pr = 1.0 ! Prandtl number ! real, parameter :: Prnum = 1.0 ! Prandtl number ! Constants for the TKE dissipation term based on Deardorff (1980) - real, parameter :: pt19=0.19, pt51=0.51, pt01=0.01 - real, parameter :: Cs = 0.15 +! real, parameter :: pt19=0.19, pt51=0.51, pt01=0.01 + real, parameter :: pt19=0.19, pt51=0.51, pt01=0.01, atmin=0.10, atmax=one-atmin + real, parameter :: Cs = 0.15, epsln=1.0e-6 real, parameter :: Ck = 0.1 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 ! real, parameter :: Ce = Ck**3/(0.7*Cs**4) ! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.2 @@ -195,29 +210,28 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & ! Local variables - real, dimension(nx,ny,nzm) :: tkesbdiss ! real, dimension(nx,ny,nzm) :: tkesbbuoy, tkesbshear, tkesbdiss, tkesbbuoy_debug & ! tkebuoy_sgs, total_water, tscale1_debug, brunt2 - real, dimension(nx,ny,nzm) :: total_water, brunt2, def2, thv - - real, dimension(nx,ny) :: denom, numer, l_inf, cldarr - - real lstarn, depth, omn, betdz, bbb, term, qsatt, dqsat, & - thedz, conv_var, tkes, skew_w, skew_qw, aterm, w1_1, w1_2, w2_1, & - w2_2, w3var, thl1_1, thl1_2, thl2_1, thl2_2, qw1_1, qw1_2, qw2_1, & - qw2_2, ql1, ql2, w_ql1, w_ql2, & - r_qwthl_1, r_wqw_1, r_wthl_1, testvar, s1, s2, std_s1, std_s2, C1, C2, & - thl_first, qw_first, w_first, Tl1_1, Tl1_2, betatest, pval, pkap, & - w2thl, w2qw,w2ql, w2ql_1, w2ql_2, & - thec, thlsec, qwsec, qwthlsec, wqwsec, wthlsec, thestd,dum, & - cqt1, cthl1, cqt2, cthl2, qn1, qn2, qi1, qi2, omn1, omn2, & - basetemp2, beta1, beta2, qs1, qs2, & - esval1_1, esval2_1, esval1_2, esval2_2, om1, om2, & - lstarn1, lstarn2, sqrtw2, sqrtthl, sqrtqt, & - sqrtstd1, sqrtstd2, tsign, tvar, sqrtw2t, wqls, wqis, & - sqrtqw2_1, sqrtqw2_2, sqrtthl2_1, sqrtthl2_2, sm, prespot, & - corrtest1, corrtest2, wrk, wrk1, wrk2, wrk3, onema, pfac, sfac, sfaci + real, dimension(nx,ny,nzm) :: total_water, brunt2, thv, tkesbdiss + real, dimension(nx,ny,nzm) :: def2 + real, dimension(nx,ny) :: denom, numer, l_inf, cldarr, thedz, thedz2 + + real lstarn, depth, omn, betdz, bbb, term, qsatt, dqsat, & + conv_var, tkes, skew_w, skew_qw, aterm, w1_1, w1_2, w2_1, & + w2_2, w3var, thl1_1, thl1_2, thl2_1, thl2_2, qw1_1, qw1_2, qw2_1, & + qw2_2, ql1, ql2, w_ql1, w_ql2, & + r_qwthl_1, r_wqw_1, r_wthl_1, testvar, s1, s2, std_s1, std_s2, C1, C2, & + thl_first, qw_first, w_first, Tl1_1, Tl1_2, betatest, pval, pkap, & + w2thl, w2qw,w2ql, w2ql_1, w2ql_2, & + thec, thlsec, qwsec, qwthlsec, wqwsec, wthlsec, thestd,dum, & + cqt1, cthl1, cqt2, cthl2, qn1, qn2, qi1, qi2, omn1, omn2, & + basetemp2, beta1, beta2, qs1, qs2, & + esval1_1, esval2_1, esval1_2, esval2_2, om1, om2, & + lstarn1, lstarn2, sqrtw2, sqrtthl, sqrtqt, & + sqrtstd1, sqrtstd2, tsign, tvar, sqrtw2t, wqls, wqis, & + sqrtqw2_1, sqrtqw2_2, sqrtthl2_1, sqrtthl2_2, sm, prespot, & + corrtest1, corrtest2, wrk, wrk1, wrk2, wrk3, onema, pfac, sfac, sfaci integer i,j,k,km1,ku,kd,ka,kb @@ -228,14 +242,13 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & do k=1,nz do j=1,ny do i=1,nx - zi(i,j,k) = phii(i,j,k) * ggri + zi(i,j,k) = phii(i,j,k) * ggri enddo enddo enddo ! ! move water from vapor to condensate if the condensate is negative ! - do k=1,nzm do j=1,ny do i=1,nx @@ -279,8 +292,8 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & qcl(i,j,k) = max(qc(i,j,k), zero) qci(i,j,k) = max(qi(i,j,k), zero) ! - qpl(i,j,k) = zero ! comment or remove when using with prognostic rain/snow - qpi(i,j,k) = zero ! comment or remove when using with prognostic rain/snow +! qpl(i,j,k) = zero ! comment or remove when using with prognostic rain/snow +! qpi(i,j,k) = zero ! comment or remove when using with prognostic rain/snow wqp_sec(i,j,k) = zero ! Turbulent flux of precipiation ! total_water(i,j,k) = qcl(i,j,k) + qci(i,j,k) + qv(i,j,k) @@ -294,7 +307,7 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & ! Liquid/ice water static energy - ! Note the the units are degrees K hl(i,j,k) = tabs(i,j,k) + gamaz(i,j,k) - fac_cond*(qcl(i,j,k)+qpl(i,j,k)) & - - fac_fus *(qci(i,j,k)+qpi(i,j,k)) + - fac_sub *(qci(i,j,k)+qpi(i,j,k)) w3(i,j,k) = zero enddo enddo @@ -307,16 +320,16 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & km1 = k - 1 do j=1,ny do i=1,nx - adzi(i,j,k) = (zl(i,j,k) - zl(i,j,km1)) - adzl(i,j,km1) = (zi(i,j,k) - zi(i,j,km1)) + adzi(i,j,k) = zl(i,j,k) - zl(i,j,km1) + adzl(i,j,km1) = zi(i,j,k) - zi(i,j,km1) enddo enddo enddo do j=1,ny do i=1,nx - adzi(i,j,1) = (zl(i,j,1)-zi(i,j,1)) ! unused in the code - adzi(i,j,nz) = adzi(i,j,nzm) ! at the top - probably unused - adzl(i,j,nzm) = adzi(i,j,nzm) + adzi(i,j,1) = (zl(i,j,1)-zi(i,j,1)) ! unused in the code + adzi(i,j,nz) = adzi(i,j,nzm) ! at the top - probably unused + adzl(i,j,nzm) = zi(i,j,nz) - zi(i,j,nzm) ! wthl_sec(i,j,1) = hflx(i) wqw_sec(i,j,1) = evap(i) @@ -337,83 +350,84 @@ subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & ! Note that Eq 6 in BK13 gives a different expression that is dependent on ! vertical gradient of grid scale vertical velocity - do k=1,nzm - ku = k+1 - kd = k-1 - ka = ku - kb = k - if (k == 1) then - kd = k - kb = ka - elseif (k == nzm) then - ku = k - ka = kb - endif - do j=1,ny - do i=1,nx - if (tke(i,j,k) > zero) then - wrk = half*(tkh(i,j,ka)+tkh(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & - * sqrt(tke(i,j,k)) / (zl(i,j,ku) - zl(i,j,kd)) -! / (sqrt(tke(i,j,k)) * (zl(i,j,ku) - zl(i,j,kd))) - w_sec(i,j,k) = max(twoby3 * tke(i,j,k) - twoby15 * wrk, zero) - else - w_sec(i,j,k) = zero - endif - enddo + do k=1,nzm + ku = k+1 + kd = k-1 + ka = ku + kb = k + if (k == 1) then + kd = k + kb = ka + elseif (k == nzm) then + ku = k + ka = kb + endif + do j=1,ny + do i=1,nx + if (tke(i,j,k) > zero) then + wrk = half*(tkh(i,j,ka)+tkh(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & + * sqrt(tke(i,j,k)) / (zl(i,j,ku) - zl(i,j,kd)) +! / (sqrt(tke(i,j,k)) * (zl(i,j,ku) - zl(i,j,kd))) + w_sec(i,j,k) = max(twoby3 * tke(i,j,k) - twoby15 * wrk, zero) + else + w_sec(i,j,k) = zero + endif enddo enddo + enddo - do k=2,nzm + do k=2,nzm - km1 = k-1 - do j=1,ny - do i=1,nx + km1 = k - 1 + do j=1,ny + do i=1,nx ! Use backward difference in the vertical, use averaged values of "return-to-isotropy" ! time scale and diffusion coefficient - wrk1 = one / adzi(i,j,k) ! adzi(k) = (zl(k)-zl(km1)) - wrk3 = max(tkh(i,j,k),pt01) * wrk1 + wrk1 = one / adzi(i,j,k) ! adzi(k) = (zl(k)-zl(km1)) +! wrk3 = max(tkh(i,j,k),pt01) * wrk1 + wrk3 = max(tkh(i,j,k),epsln) * wrk1 - sm = half*(isotropy(i,j,k)+isotropy(i,j,km1))*wrk1*wrk3 ! Tau*Kh/dz^2 + sm = half*(isotropy(i,j,k)+isotropy(i,j,km1))*wrk1*wrk3 ! Tau*Kh/dz^2 ! SGS vertical flux liquid/ice water static energy. Eq 1 in BK13 - wrk1 = hl(i,j,k) - hl(i,j,km1) - wthl_sec(i,j,k) = - wrk3 * wrk1 + wrk1 = hl(i,j,k) - hl(i,j,km1) + wthl_sec(i,j,k) = - wrk3 * wrk1 ! SGS vertical flux of total water. Eq 2 in BK13 - wrk2 = total_water(i,j,k) - total_water(i,j,km1) - wqw_sec(i,j,k) = - wrk3 * wrk2 + wrk2 = total_water(i,j,k) - total_water(i,j,km1) + wqw_sec(i,j,k) = - wrk3 * wrk2 ! Second moment of liquid/ice water static energy. Eq 4 in BK13 - thl_sec(i,j,k) = thl2tune * sm * wrk1 * wrk1 + thl_sec(i,j,k) = thl2tune * sm * wrk1 * wrk1 ! Second moment of total water mixing ratio. Eq 3 in BK13 - qw_sec(i,j,k) = qw2tune * sm * wrk2 * wrk2 + qw_sec(i,j,k) = qw2tune * sm * wrk2 * wrk2 ! Covariance of total water mixing ratio and liquid/ice water static energy. ! Eq 5 in BK13 - qwthl_sec(i,j,k) = qwthl2tune * sm * wrk1 * wrk2 + qwthl_sec(i,j,k) = qwthl2tune * sm * wrk1 * wrk2 - enddo ! i loop - enddo ! j loop - enddo ! k loop + enddo ! i loop + enddo ! j loop + enddo ! k loop ! These would be at the surface - do we need them? - do j=1,ny - do i=1,nx -! wthl_sec(i,j,1) = wthl_sec(i,j,2) -! wqw_sec(i,j,1) = wqw_sec(i,j,2) - thl_sec(i,j,1) = thl_sec(i,j,2) - qw_sec(i,j,1) = qw_sec(i,j,2) - qwthl_sec(i,j,1) = qwthl_sec(i,j,2) - enddo + do j=1,ny + do i=1,nx +! wthl_sec(i,j,1) = wthl_sec(i,j,2) +! wqw_sec(i,j,1) = wqw_sec(i,j,2) + thl_sec(i,j,1) = thl_sec(i,j,2) + qw_sec(i,j,1) = qw_sec(i,j,2) + qwthl_sec(i,j,1) = qwthl_sec(i,j,2) enddo + enddo ! Diagnose the third moment of SGS vertical velocity @@ -435,7 +449,7 @@ subroutine tke_shoc() real grd,betdz,Cek,Cee,lstarn, lstarp, bbb, omn, omp,qsatt,dqsat, smix, & buoy_sgs,ratio,a_prod_sh,a_prod_bu,a_diss,a_prod_bu_debug, buoy_sgs_debug, & tscale1, wrk, wrk1, wtke, wtk2, rdtn - integer i,j,k,ku,kd,itr + integer i,j,k,ku,kd,itr,k1 rdtn = one / dtn @@ -461,12 +475,7 @@ subroutine tke_shoc() ku = k+1 kd = k -! Cek = Ce * 3.5 -! Cek = Ce * 3.0 -! Cek = Ce * 2.0 -! Cek = Ce * 1.5 Cek = Ce * cefac -! Cek = Ces if(k == 1) then ku = 2 @@ -478,7 +487,6 @@ subroutine tke_shoc() Cek = Ces endif - do j=1,ny do i=1,nx grd = adzl(i,j,k) ! adzl(k) = zi(k+1)-zi(k) @@ -488,36 +496,31 @@ subroutine tke_shoc() ! TKE boyancy production term. wthv_sec (buoyancy flux) is calculated in ! assumed_pdf(). The value used here is from the previous time step -! basetemp (300) is virt. temperature. Why is it constant? -! a_prod_bu = (ggr/basetemp)*wthv_sec(i,j,k) -! a_prod_bu = bet(i,j,k)*wthv_sec(i,j,k) a_prod_bu = ggr / thv(i,j,k) * wthv_sec(i,j,k) ! If wthv_sec from subgrid PDF is not available use Brunt-Vaisalla frequency from eddy_length() -! wrk = (half*ck) * (tkh(i,j,ku)+tkh(i,j,kd)) - wrk = half * (tkh(i,j,ku)+tkh(i,j,kd)) !Obtain Brunt-Vaisalla frequency from diagnosed SGS buoyancy flux !Presumably it is more precise than BV freq. calculated in eddy_length()? - buoy_sgs = - a_prod_bu / (wrk + 0.0001) ! tkh is eddy thermal diffussivity -! buoy_sgs = - a_prod_bu / (prnum*wrk + 0.0001) ! tk is eddy viscosity + buoy_sgs = - (a_prod_bu+a_prod_bu) / (tkh(i,j,ku)+tkh(i,j,kd) + 0.0001) ! tkh is eddy thermal diffussivity + !Compute $c_k$ (variable Cee) for the TKE dissipation term following Deardorff (1980) if (buoy_sgs <= zero) then smix = grd else -! smix = min(grd,max(0.1*grd, sqrt(0.76*wrk/sqrt(buoy_sgs+1.e-10)))) -! smix = min(grd,max(0.1*grd, sqrt(0.76*wrk/(Ck*sqrt(buoy_sgs+1.e-10))))) smix = min(grd,max(0.1*grd, 0.76*sqrt(tke(i,j,k)/(buoy_sgs+1.e-10)))) endif ratio = smix/grd - Cee = Cek* (pt19 + pt51*ratio) - wrk = half * wrk * (prnum(i,j,ku) + prnum(i,j,kd)) - a_prod_sh = min(tkhmax,(wrk+0.001))*def2(i,j,k) ! TKE shear production term + Cee = Cek* (pt19 + pt51*ratio) * max(one, sqrt(pcrit/prsl(i,j,k))) + +! TKE shear production term + a_prod_sh = half*(def2(i,j,ku)*tkh(i,j,ku)*prnum(i,j,ku) & + + def2(i,j,kd)*tkh(i,j,kd)*prnum(i,j,kd)) ! smixt (turb. mixing lenght) is calculated in eddy_length() @@ -529,23 +532,29 @@ subroutine tke_shoc() wtke = tke(i,j,k) wtk2 = wtke - wrk = (dtn*Cee)/smixt(i,j,k) +! wrk = (dtn*Cee)/smixt(i,j,k) + wrk = (dtn*Cee) / smixt(i,j,k) wrk1 = wtke + dtn*(a_prod_sh+a_prod_bu) do itr=1,nitr ! iterate for implicit solution wtke = min(max(min_tke, wtke), max_tke) a_diss = wrk*sqrt(wtke) ! Coefficient in the TKE dissipation term - wtke = wrk1 / (1+a_diss) + wtke = wrk1 / (one+a_diss) wtke = tkef1*wtke + tkef2*wtk2 ! tkef1+tkef2 = 1.0 - wtk2 = wtke +! if (lprnt .and. i == ipr .and. k<15) write(0,*)' wtke=',wtke,' wtk2=',wtk2,& +! ' a_diss=',a_diss,' a_prod_sh=',a_prod_sh,' a_prod_bu=',a_prod_bu,& +! ' wrk1=',wrk1,' kdt=',kdt,' itr=',itr,' k=',k + + wtk2 = wtke + enddo tke(i,j,k) = min(max(min_tke, wtke), max_tke) - tscale1 = (dtn+dtn) / a_diss ! See Eq 8 in BK13 + tscale1 = (dtn+dtn) / a_diss ! See Eq 8 in BK13 - a_diss = rdtn*a_diss*tke(i,j,k) ! TKE dissipation term, epsilon + tkesbdiss(i,j,k) = rdtn*a_diss*tke(i,j,k) ! TKE dissipation term, epsilon ! Calculate "return-to-isotropy" eddy dissipation time scale, see Eq. 8 in BK13 @@ -557,10 +566,9 @@ subroutine tke_shoc() tscale1/(one+lambda*buoy_sgs*tscale1*tscale1)) endif - ! TKE budget terms - tkesbdiss(i,j,k) = a_diss +! tkesbdiss(i,j,k) = a_diss ! tkesbshear(i,j,k) = a_prod_sh ! tkesbbuoy(i,j,k) = a_prod_bu ! tkesbbuoy_debug(i,j,k) = a_prod_bu_debug @@ -572,17 +580,15 @@ subroutine tke_shoc() ! wrk = half * ck do k=2,nzm + k1 = k - 1 do j=1,ny do i=1,nx - - wrk1 = wrk / (prnum(i,j,k) + prnum(i,j,k-1)) - - tkh(i,j,k) = wrk1 * (isotropy(i,j,k) + isotropy(i,j,k-1)) & - * (tke(i,j,k) + tke(i,j,k-1)) ! Eddy thermal diffusivity - tkh(i,j,k) = min(tkh(i,j,k),tkhmax) + tkh(i,j,k) = min(tkhmax, wrk * (isotropy(i,j,k) * tke(i,j,k) & + + isotropy(i,j,k1) * tke(i,j,k1))) ! Eddy thermal diffusivity enddo ! i - enddo ! j - enddo ! k + enddo ! j + enddo ! k + end subroutine tke_shoc @@ -591,72 +597,32 @@ subroutine tke_shear_prod(def2) ! Calculate TKE shear production term - real, intent(out):: def2(nx,ny,nzm) + real, intent(out) :: def2(nx,ny,nzm) - real rdzw_up, rdzw_dn, wrku(2), wrkv(2), wrkw(2) - real txd(nx,ny) - integer i,j,k,kb,kc + real rdzw, wrku, wrkv, wrkw + integer i,j,k,k1 -! do k=1,nzm -! do j=1,ny -! do i=1,nx -! def2(i,j,k) = zero -! enddo -! enddo -! enddo - -! Calculate TKE shear production term +! Calculate TKE shear production term at layer interface - do k=1,nzm - - kb = k-1 - kc = k+1 - - if (k == 1) then - - do j=1,ny - do i=1,nx - rdzw_up = one/adzi(i,j,kc) - wrku(1) = (u(i,j,kc)-u(i,j,k))*rdzw_up - wrkv(1) = (v(i,j,kc)-v(i,j,k))*rdzw_up -! wrkw(1) = (w(i,j,kc)-w(i,j,k))*rdzw_up - def2(i,j,1) = wrku(1)*wrku(1) + wrkv(1)*wrkv(1) !+ 2*wrkw(1) * wrkw(1) - txd(i,j) = rdzw_up - enddo - enddo - - elseif (k < nzm ) then - do j=1,ny - do i=1,nx - rdzw_up = one/adzi(i,j,kc) - rdzw_dn = txd(i,j) - wrku(1) = (u(i,j,kc)-u(i,j,k))*rdzw_up - wrku(2) = (u(i,j,k)-u(i,j,kb))*rdzw_dn - wrkv(1) = (v(i,j,kc)-v(i,j,k))*rdzw_up - wrkv(2) = (v(i,j,k)-v(i,j,kb))*rdzw_dn -! wrkw(1) = (w(i,j,kc)-w(i,j,k))*rdzw_up -! wrkw(2) = (w(i,j,k)-w(i,j,kb))*rdzw_dn - - def2(i,j,k) = half * (wrku(1)*wrku(1) + wrku(2)*wrku(2) & - + wrkv(1)*wrkv(1) + wrkv(2)*wrkv(2)) ! & -! + wrkw(1)*wrkw(1) + wrkw(2)*wrkw(2) - txd(i,j) = rdzw_up - enddo - enddo - else - do j=1,ny - do i=1,nx - rdzw_dn = txd(i,j) - wrku(2) = (u(i,j,k)-u(i,j,kb))*rdzw_dn - wrkv(2) = (v(i,j,k)-v(i,j,kb))*rdzw_dn -! wrkw(2) = (w(i,j,k)-w(i,j,kb))*rdzw_dn - def2(i,j,k) = wrku(2)*wrku(2) + wrkv(2)*wrkv(2) !+ 2*wrkw(2) * wrkw(2) - enddo + do k=2,nzm + k1 = k - 1 + do j=1,ny + do i=1,nx + rdzw = one / adzi(i,j,k) + wrku = (u(i,j,k)-u(i,j,k1)) * rdzw + wrkv = (v(i,j,k)-v(i,j,k1)) * rdzw +! wrkw = (w(i,j,k)-w(i,j,k1)) * rdzw + def2(i,j,k) = wrku*wrku + wrkv*wrkv !+ 2*wrkw(1) * wrkw(1) enddo - endif - + enddo enddo ! k loop - + do j=1,ny + do i=1,nx +! def2(i,j,1) = def2(i,j,2) + def2(i,j,1) = (u(i,j,1)*u(i,j,1) + v(i,j,1)*v(i,j,1)) & + / (zl(i,j,1)*zl(i,j,1)) + enddo + enddo end subroutine tke_shear_prod @@ -684,7 +650,8 @@ subroutine eddy_length() do i=1,nx ! Reinitialize the mixing length related arrays to zero - smixt(i,j,k) = one ! shoc_mod module variable smixt +! smixt(i,j,k) = one ! shoc_mod module variable smixt + smixt(i,j,k) = epsln ! shoc_mod module variable smixt brunt(i,j,k) = zero !Eq. 11 in BK13 (Eq. 4.13 in Pete's dissertation) @@ -706,9 +673,9 @@ subroutine eddy_length() do j=1,ny do i=1,nx if (denom(i,j) > zero .and. numer(i,j) > zero) then - l_inf(i,j) = 0.1 * (numer(i,j)/denom(i,j)) + l_inf(i,j) = min(0.1 * (numer(i,j)/denom(i,j)), 100.0) else - l_inf(i,j) = 100. + l_inf(i,j) = 100.0 endif enddo enddo @@ -718,26 +685,25 @@ subroutine eddy_length() kb = k-1 kc = k+1 - + if (k == 1) then + kb = 1 + kc = 2 + thedz(:,:) = adzi(:,:,kc) + elseif (k == nzm) then + kb = nzm-1 + kc = nzm + thedz(:,:) = adzi(:,:,k) + else + thedz(:,:) = adzi(:,:,kc) + adzi(:,:,k) ! = (z(k+1)-z(k-1)) + endif + do j=1,ny do i=1,nx ! vars module variable bet (=ggr/tv0) ; grid module variable adzi - if (k == 1) then - kb = 1 - kc = 2 - thedz = adzi(i,j,kc) - elseif (k == nzm) then - kb = nzm-1 - kc = nzm - thedz = adzi(i,j,k) - else - thedz = (adzi(i,j,kc)+adzi(i,j,k)) ! = (z(k+1)-z(k-1)) - endif - betdz = bet(i,j,k) / thedz + betdz = bet(i,j,k) / thedz(i,j) - tkes = sqrt(tke(i,j,k)) ! Compute local Brunt-Vaisalla frequency @@ -755,12 +721,12 @@ subroutine eddy_length() lstarn = fac_cond + (one-omn)*fac_fus ! Derivative of saturation mixing ratio over water/ice wrt temp. based on relative water phase content - dqsat = omn * dtqsatw(tabs(i,j,k),prsl(i,j,k)) & + dqsat = omn * dtqsatw(tabs(i,j,k),prsl(i,j,k)) & + (one-omn) * dtqsati(tabs(i,j,k),prsl(i,j,k)) ! Saturation mixing ratio over water/ice wrt temp based on relative water phase content - qsatt = omn * qsatw(tabs(i,j,k),prsl(i,j,k)) & + qsatt = omn * qsatw(tabs(i,j,k),prsl(i,j,k)) & + (one-omn) * qsati(tabs(i,j,k),prsl(i,j,k)) ! liquid/ice moist static energy static energy divided by cp? @@ -772,7 +738,7 @@ subroutine eddy_length() brunt(i,j,k) = betdz*(bbb*(hl(i,j,kc)-hl(i,j,kb)) & + (bbb*lstarn - (one+lstarn*dqsat)*tabs(i,j,k)) & - * (total_water(i,j,kc)-total_water(i,j,kb)) & + * (total_water(i,j,kc)-total_water(i,j,kb)) & + (bbb*fac_cond - (one+fac_cond*dqsat)*tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & + (bbb*fac_sub - (one+fac_sub*dqsat)*tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) @@ -882,7 +848,7 @@ subroutine eddy_length() ku = k ! conv_vel2 (Cubed convective velocity scale) is calculated in conv_scale() ! Use the value of conv_vel2 at the top of the cloud. - conv_var = conv_vel2(i,j,k)**(one/3.) + conv_var = conv_vel2(i,j,k)**(oneb3) endif ! Compute the mixing length scale for the cloud layer that we just found @@ -1012,9 +978,9 @@ subroutine canuto() ! Local variables integer i, j, k, kb, kc - real bet2, f0, f1, f2, f3, f4, f5, iso, isosqr, & - omega0, omega1, omega2, X0, Y0, X1, Y1, AA0, AA1, buoy_sgs2, & - thedz, thedz2, cond, wrk, wrk1, wrk2, wrk3, avew + real bet2, f0, f1, f2, f3, f4, f5, iso, isosqr, & + omega0, omega1, omega2, X0, Y0, X1, Y1, AA0, AA1, buoy_sgs2, & + cond, wrk, wrk1, wrk2, wrk3, avew ! ! See Eq. 7 in C01 (B.7 in Pete's dissertation) real, parameter :: c=7.0, a0=0.52/(c*c*(c-2.)), a1=0.87/(c*c), & @@ -1027,30 +993,38 @@ subroutine canuto() kb = k-1 kc = k+1 + + if(k == 1) then + kb = 1 + kc = 2 + do j=1,ny + do i=1,nx + thedz(i,j) = one / adzl(i,j,kc) + thedz2(i,j) = thedz(i,j) + enddo + enddo + elseif(k == nzm) then + kb = nzm-1 + kc = nzm + do j=1,ny + do i=1,nx + thedz(i,j) = one / adzl(i,j,k) + thedz2(i,j) = thedz(i,j) + enddo + enddo + else + do j=1,ny + do i=1,nx + thedz(i,j) = one / adzl(i,j,k) + thedz2(i,j) = one / (adzl(i,j,k)+adzl(i,j,kb)) + enddo + enddo + endif + do j=1,ny do i=1,nx - if(k == 1) then - kb = 1 - kc = 2 - thedz = adzl(i,j,kc) - thedz2 = thedz - elseif(k == nzm) then - kb = nzm-1 - kc = nzm - thedz = adzl(i,j,k) - thedz2 = thedz - else -! thedz = adzl(i,j,k) -! thedz2 = adzl(i,j,kc)+adzl(i,j,k) - thedz = adzl(i,j,k) ! Moorthi jul08 - thedz2 = adzl(i,j,k)+adzl(i,j,kb) ! Moorthi jul08 - endif - - thedz = one / thedz - thedz2 = one / thedz2 - iso = half*(isotropy(i,j,k)+isotropy(i,j,kb)) isosqr = iso*iso ! Two-level average of "return-to-isotropy" time scale squared buoy_sgs2 = isosqr*half*(brunt(i,j,k)+brunt(i,j,kb)) @@ -1063,7 +1037,7 @@ subroutine canuto() avew = half*(w_sec(i,j,k)+w_sec(i,j,kb)) cond = 1.2*sqrt(max(1.0e-20,2.*avew*avew*avew)) wrk1 = bet2*iso - wrk2 = thedz2*wrk1*wrk1*iso + wrk2 = thedz2(i,j)*wrk1*wrk1*iso wrk3 = thl_sec(i,j,kc) - thl_sec(i,j,kb) f0 = wrk2 * wrk1 * wthl_sec(i,j,k) * wrk3 @@ -1073,12 +1047,12 @@ subroutine canuto() f1 = wrk2 * (wrk*wthl_sec(i,j,k) + half*avew*wrk3) wrk1 = bet2*isosqr - f2 = thedz*wrk1*wthl_sec(i,j,k)*(w_sec(i,j,k)-w_sec(i,j,kb)) & - + (thedz2+thedz2)*bet(i,j,k)*isosqr*wrk + f2 = thedz(i,j)*wrk1*wthl_sec(i,j,k)*(w_sec(i,j,k)-w_sec(i,j,kb)) & + + (thedz2(i,j)+thedz2(i,j))*bet(i,j,k)*isosqr*wrk - f3 = thedz2*wrk1*wrk + thedz*bet2*isosqr*(wthl_sec(i,j,k)*(tke(i,j,k)-tke(i,j,kb))) + f3 = thedz2(i,j)*wrk1*wrk + thedz(i,j)*bet2*isosqr*(wthl_sec(i,j,k)*(tke(i,j,k)-tke(i,j,kb))) - wrk1 = thedz*iso*avew + wrk1 = thedz(i,j)*iso*avew f4 = wrk1*(w_sec(i,j,k)-w_sec(i,j,kb) + tke(i,j,k)-tke(i,j,kb)) f5 = wrk1*(w_sec(i,j,k)-w_sec(i,j,kb)) @@ -1148,12 +1122,15 @@ subroutine assumed_pdf() wqlsb(k) = zero wqisb(k) = zero enddo + +! sfac = scrit +! sfaci = one / sfac DO k=1,nzm kd = k ku = k + 1 - if (k == nzm) ku = k +! if (k == nzm) ku = k DO j=1,ny DO i=1,nx @@ -1167,7 +1144,10 @@ subroutine assumed_pdf() pval = prsl(i,j,k) pfac = pval * 1.0e-5 pkap = pfac ** kapa - sfac = scrit * pfac + +! sfac = scrit * sqrt(pfac) +! sfac = scrit + sfac = scrit * pfac * pfac sfaci = one / sfac ! Read in liquid/ice static energy, total water mixing ratio, @@ -1182,12 +1162,21 @@ subroutine assumed_pdf() ! Points to be computed with relation to thermo point ! Read in points that need to be averaged - w3var = half*(w3(i,j,kd)+w3(i,j,ku)) - thlsec = max(zero, half*(thl_sec(i,j,kd)+thl_sec(i,j,ku)) ) - qwsec = max(zero, half*(qw_sec(i,j,kd)+qw_sec(i,j,ku)) ) - qwthlsec = half * (qwthl_sec(i,j,kd) + qwthl_sec(i,j,ku)) - wqwsec = half * (wqw_sec(i,j,kd) + wqw_sec(i,j,ku)) - wthlsec = half * (wthl_sec(i,j,kd) + wthl_sec(i,j,ku)) + if (k < nzm) then + w3var = half*(w3(i,j,kd)+w3(i,j,ku)) + thlsec = max(zero, half*(thl_sec(i,j,kd)+thl_sec(i,j,ku)) ) + qwsec = max(zero, half*(qw_sec(i,j,kd)+qw_sec(i,j,ku)) ) + qwthlsec = half * (qwthl_sec(i,j,kd) + qwthl_sec(i,j,ku)) + wqwsec = half * (wqw_sec(i,j,kd) + wqw_sec(i,j,ku)) + wthlsec = half * (wthl_sec(i,j,kd) + wthl_sec(i,j,ku)) + else ! at the model top assuming zeros + w3var = half*w3(i,j,k) + thlsec = max(zero, half*thl_sec(i,j,k)) + qwsec = max(zero, half*qw_sec(i,j,k)) + qwthlsec = half * qwthl_sec(i,j,k) + wqwsec = half * wqw_sec(i,j,k) + wthlsec = half * wthl_sec(i,j,k) + endif ! w3var = w3(i,j,k) ! thlsec = max(zero,thl_sec(i,j,k)) @@ -1198,19 +1187,19 @@ subroutine assumed_pdf() ! Compute square roots of some variables so we don't have to do it again if (w_sec(i,j,k) > zero) then - sqrtw2 = sqrt(w_sec(i,j,k)) + sqrtw2 = sqrt(w_sec(i,j,k)) else - sqrtw2 = zero + sqrtw2 = zero endif if (thlsec > zero) then - sqrtthl = sqrt(thlsec) + sqrtthl = sqrt(thlsec) else - sqrtthl = zero + sqrtthl = zero endif if (qwsec > zero) then - sqrtqt = sqrt(qwsec) + sqrtqt = sqrt(qwsec) else - sqrtqt = zero + sqrtqt = zero endif @@ -1240,8 +1229,8 @@ subroutine assumed_pdf() ! Compute realtive weight of the first PDF "plume" ! See Eq A4 in Pete's dissertaion - Ensure 0.01 < a < 0.99 - wrk = one - w2_1 - aterm = max(pt01,min(half*(one-Skew_w*sqrt(one/(4.*wrk*wrk*wrk+Skew_w*Skew_w))),0.99)) + wrk = one - w2_1 + aterm = max(atmin,min(half*(one-Skew_w*sqrt(one/(4.*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) onema = one - aterm sqrtw2t = sqrt(wrk) @@ -1274,13 +1263,13 @@ subroutine assumed_pdf() wrk1 = thl1_1 * thl1_1 wrk2 = thl1_2 * thl1_2 - wrk3 = one - aterm*wrk1 - onema*wrk2 + wrk3 = three * (one - aterm*wrk1 - onema*wrk2) wrk4 = -skew_fact*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi ! wrk4 = - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 - wrk = 3. * (thl1_2-thl1_1) + wrk = three * (thl1_2-thl1_1) if (wrk /= zero) then - thl2_1 = thlsec * min(100.,max(zero,( 3.*thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - thl2_2 = thlsec * min(100.,max(zero,(-3.*thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + thl2_1 = thlsec * min(100.,max(zero,( thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + thl2_2 = thlsec * min(100.,max(zero,(-thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 else thl2_1 = zero thl2_2 = zero @@ -1312,25 +1301,25 @@ subroutine assumed_pdf() tsign = abs(qw1_2-qw1_1) - Skew_qw = skew_facw*Skew_w +! Skew_qw = skew_facw*Skew_w -! IF (tsign > 0.4) THEN -! Skew_qw = skew_facw*Skew_w -! ELSE IF (tsign <= 0.2) THEN -! Skew_qw = zero -! ELSE -! Skew_qw = (skew_facw/0.2) * Skew_w * (tsign-0.2) -! ENDIF + IF (tsign > 0.4) THEN + Skew_qw = skew_facw*Skew_w + ELSEIF (tsign <= 0.2) THEN + Skew_qw = zero + ELSE + Skew_qw = (skew_facw/0.2) * Skew_w * (tsign-0.2) + ENDIF wrk1 = qw1_1 * qw1_1 wrk2 = qw1_2 * qw1_2 - wrk3 = one - aterm*wrk1 - onema*wrk2 + wrk3 = three * (one - aterm*wrk1 - onema*wrk2) wrk4 = Skew_qw - aterm*wrk1*qw1_1 - onema*wrk2*qw1_2 - wrk = 3. * (qw1_2-qw1_1) + wrk = three * (qw1_2-qw1_1) if (wrk /= zero) then - qw2_1 = qwsec * min(100.,max(zero,( 3.*qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - qw2_2 = qwsec * min(100.,max(zero,(-3.*qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + qw2_1 = qwsec * min(100.,max(zero,( qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + qw2_2 = qwsec * min(100.,max(zero,(-qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 else qw2_1 = zero qw2_2 = zero @@ -1356,44 +1345,38 @@ subroutine assumed_pdf() IF (testvar == 0) THEN r_qwthl_1 = zero ELSE - r_qwthl_1 = max(-one,min(one,(qwthlsec-aterm*(qw1_1-qw_first)*(thl1_1-thl_first)-onema*(qw1_2-qw_first)*(thl1_2-thl_first))/testvar)) ! A.12 + r_qwthl_1 = max(-one,min(one,(qwthlsec-aterm*(qw1_1-qw_first)*(thl1_1-thl_first) & + -onema*(qw1_2-qw_first)*(thl1_2-thl_first))/testvar)) ! A.12 ENDIF ! BEGIN TO COMPUTE CLOUD PROPERTY STATISTICS - Tl1_1 = thl1_1 - gamaz(i,j,k) + fac_cond*qpl(i,j,k) + fac_sub*qpi(i,j,k) - Tl1_2 = thl1_2 - gamaz(i,j,k) + fac_cond*qpl(i,j,k) + fac_sub*qpi(i,j,k) + wrk1 = gamaz(i,j,k) - fac_cond*qpl(i,j,k) - fac_sub*qpi(i,j,k) + Tl1_1 = thl1_1 - wrk1 + Tl1_2 = thl1_2 - wrk1 ! Now compute qs esval1_1 = zero - esval1_2 = zero esval2_1 = zero - esval2_2 = zero om1 = one - om2 = one eps_ss1 = eps eps_ss2 = eps ! Partition based on temperature for the first plume IF (Tl1_1 >= tbgmax) THEN -! esval1_1 = fpvs(Tl1_1) esval1_1 = fpvsl(Tl1_1) ! esval1_1 = esatw(Tl1_1) lstarn1 = lcond ELSE IF (Tl1_1 < tbgmin) THEN -! esval1_1 = fpvs(Tl1_1) esval1_1 = fpvsi(Tl1_1) ! esval1_1 = esati(Tl1_1) lstarn1 = lsub eps_ss1 = eps * supice ELSE -! esval1_1 = fpvs(Tl1_1) -! esval2_1 = fpvs(Tl1_1) esval1_1 = fpvsl(Tl1_1) esval2_1 = fpvsi(Tl1_1) -! esval2_1 = fpvsi(Tl1_1) ! esval1_1 = esatw(Tl1_1) ! esval2_1 = esati(Tl1_1) om1 = max(zero, min(one, a_bg*(Tl1_1-tbgmin))) @@ -1401,10 +1384,8 @@ subroutine assumed_pdf() eps_ss2 = eps * supice ENDIF - qs1 = om1 * (eps_ss1*esval1_1/max(esval1_1,pval-0.378*esval1_1)) & + qs1 = om1 * (eps_ss1*esval1_1/max(esval1_1,pval-0.378*esval1_1)) & + (one-om1) * (eps_ss2*esval2_1/max(esval2_1,pval-0.378*esval2_1)) -! qs1 = om1 * (eps*esval1_1/max(esval1_1,pval-esval1_1)) & -! + (one-om1) * (eps*esval2_1/max(esval2_1,pval-esval2_1)) ! beta1 = (rgas/rv)*(lstarn1/(rgas*Tl1_1))*(lstarn1/(cp*Tl1_1)) beta1 = (lstarn1*lstarn1*onebrvcp) / (Tl1_1*Tl1_1) ! A.18 @@ -1417,26 +1398,24 @@ subroutine assumed_pdf() beta2 = beta1 ELSE - eps_ss1 = eps - eps_ss2 = eps + esval1_2 = zero + esval2_2 = zero + om2 = one + eps_ss1 = eps + eps_ss2 = eps IF (Tl1_2 < tbgmin) THEN -! esval1_2 = fpvs(Tl1_2) esval1_2 = fpvsi(Tl1_2) ! esval1_2 = esati(Tl1_2) lstarn2 = lsub eps_ss1 = eps * supice ELSE IF (Tl1_2 >= tbgmax) THEN -! esval1_2 = fpvs(Tl1_2) esval1_2 = fpvsl(Tl1_2) ! esval1_2 = esatw(Tl1_2) lstarn2 = lcond ELSE -! esval1_2 = fpvs(Tl1_2) -! esval2_2 = fpvs(Tl1_2) esval1_2 = fpvsl(Tl1_2) esval2_2 = fpvsi(Tl1_2) -! esval2_2 = fpvsi(Tl1_2) ! esval1_2 = esatw(Tl1_2) ! esval2_2 = esati(Tl1_2) om2 = max(zero, min(one, a_bg*(Tl1_2-tbgmin))) @@ -1444,10 +1423,8 @@ subroutine assumed_pdf() eps_ss2 = eps * supice ENDIF - qs2 = om2 * (eps_ss1*esval1_2/max(esval1_2,pval-0.378*esval1_2)) & + qs2 = om2 * (eps_ss1*esval1_2/max(esval1_2,pval-0.378*esval1_2)) & + (one-om2) * (eps_ss2*esval2_2/max(esval2_2,pval-0.378*esval2_2)) -! qs2 = om2 * (eps*esval1_2/max(esval1_2,pval-esval1_2)) & -! + (one-om2) * (eps*esval2_2/max(esval2_2,pval-esval2_2)) ! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 beta2 = (lstarn2*lstarn2*onebrvcp) / (Tl1_2*Tl1_2) ! A.18 @@ -1459,16 +1436,16 @@ subroutine assumed_pdf() ! Now compute cloud stuff - compute s term - cqt1 = one / (one+beta1*qs1) ! A.19 - wrk = qs1 * (one+beta1*qw1_1) * cqt1 - s1 = qw1_1 - wrk ! A.17 - cthl1 = cqt1*wrk*cpolv*beta1*pkap ! A.20 + cqt1 = one / (one+beta1*qs1) ! A.19 + wrk = qs1 * (one+beta1*qw1_1) * cqt1 + s1 = qw1_1 - wrk ! A.17 + cthl1 = cqt1*wrk*cpolv*beta1*pkap ! A.20 wrk1 = cthl1 * cthl1 wrk2 = cqt1 * cqt1 ! std_s1 = sqrt(max(zero,wrk1*thl2_1+wrk2*qw2_1-2.*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) std_s1 = sqrt(max(zero, wrk1*thl2_1+wrk2*qw2_1 & - - two*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) + - two*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) qn1 = zero C1 = zero @@ -1481,7 +1458,7 @@ subroutine assumed_pdf() IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 if (qn1 < sfac) then - c1 = qn1 * sfaci + c1 = min(c1, qn1*sfaci) endif ELSEIF (s1 > zero) THEN C1 = min(one, max(zero,s1*sfaci)) @@ -1519,7 +1496,7 @@ subroutine assumed_pdf() C2 = max(zero, min(one, half*(one+erf(wrk)))) IF (C2 > zero) qn2 = s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk) if (qn2 < sfac) then - c2 = qn2 * sfaci + c2 = min(c2, qn2*sfaci) endif ELSEIF (s2 > zero) THEN C2 = min(one, max(zero,s2*sfaci)) @@ -1561,8 +1538,10 @@ subroutine assumed_pdf() ! Update moisture fields ! Update ncpl and ncpi Anning Cheng 03/11/2016 - ncpl(i,j,k) = diag_ql/max(qc(i,j,k),1.e-10)*ncpl(i,j,k) - ncpi(i,j,k) = (1-diag_qi/max(qi(i,j,k),1.e-10))*ncpi(i,j,k) +! ncpl(i,j,k) = diag_ql/max(qc(i,j,k),1.e-10)*ncpl(i,j,k) +! The following commneted by Moorthi on April 26, 2017 to test blowing up +! ncpl(i,j,k) = (1.0-diag_ql/max(qc(i,j,k),1.e-10)) * ncpl(i,j,k) +! ncpi(i,j,k) = (1.0-diag_qi/max(qi(i,j,k),1.e-10)) * ncpi(i,j,k) qc(i,j,k) = diag_ql qi(i,j,k) = diag_qi qwv(i,j,k) = total_water(i,j,k) - diag_qn @@ -1584,10 +1563,17 @@ subroutine assumed_pdf() bastoeps = onebeps * thv(i,j,k) - wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & - + (fac_cond-bastoeps)*wqls & - + (fac_sub-bastoeps) *wqis & - + ((lstarn1/cp)-thv(i,j,k))*half*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) + if (k < nzm) then + wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & + + (fac_cond-bastoeps)*wqls & + + (fac_sub-bastoeps) *wqis & + + ((lstarn1/cp)-thv(i,j,k))*half*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) + else + wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & + + (fac_cond-bastoeps)*wqls & + + (fac_sub-bastoeps) *wqis & + + ((lstarn1/cp)-thv(i,j,k))*half*wqp_sec(i,j,k) + endif ! wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & ! + (fac_cond-bastoeps)*wqls & diff --git a/gfsphysics/physics/gfdl_cloud_microphys.F90 b/gfsphysics/physics/gfdl_cloud_microphys.F90 index b8782a813..37d8b096c 100644 --- a/gfsphysics/physics/gfdl_cloud_microphys.F90 +++ b/gfsphysics/physics/gfdl_cloud_microphys.F90 @@ -111,20 +111,20 @@ module gfdl_cloud_microphys_mod ! cloud microphysics switchers integer :: icloud_f = 0 ! cloud scheme - integer :: irain_f = 0 ! cloud water to rain auto conversion scheme + integer :: irain_f = 0 ! cloud water to rain auto conversion scheme logical :: de_ice = .false. ! to prevent excessive build - up of cloud ice from external sources logical :: sedi_transport = .true. ! transport of momentum in sedimentation - logical :: do_sedi_w = .false. ! transport of vertical motion in sedimentation - logical :: do_sedi_heat = .true. ! transport of heat in sedimentation - logical :: prog_ccn = .false. ! do prognostic ccn (yi ming's method) - logical :: do_qa = .true. ! do inline cloud fraction - logical :: rad_snow = .true. ! consider snow in cloud fraciton calculation - logical :: rad_graupel = .true. ! consider graupel in cloud fraction calculation - logical :: rad_rain = .true. ! consider rain in cloud fraction calculation - logical :: fix_negative = .false. ! fix negative water species - logical :: do_setup = .true. ! setup constants and parameters - logical :: p_nonhydro = .false. ! perform hydrosatic adjustment on air density + logical :: do_sedi_w = .false. ! transport of vertical motion in sedimentation + logical :: do_sedi_heat = .true. ! transport of heat in sedimentation + logical :: prog_ccn = .false. ! do prognostic ccn (yi ming's method) + logical :: do_qa = .true. ! do inline cloud fraction + logical :: rad_snow = .true. ! consider snow in cloud fraciton calculation + logical :: rad_graupel = .true. ! consider graupel in cloud fraction calculation + logical :: rad_rain = .true. ! consider rain in cloud fraction calculation + logical :: fix_negative = .false. ! fix negative water species + logical :: do_setup = .true. ! setup constants and parameters + logical :: p_nonhydro = .false. ! perform hydrosatic adjustment on air density real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) real, allocatable :: des (:), des2 (:), des3 (:), desw (:) @@ -168,25 +168,25 @@ module gfdl_cloud_microphys_mod ! conversion time scale - real :: tau_r2g = 900. ! rain freezing during fast_sat - real :: tau_smlt = 900. ! snow melting - real :: tau_g2r = 600. ! graupel melting to rain - real :: tau_imlt = 600. ! cloud ice melting - real :: tau_i2s = 1000. ! cloud ice to snow auto - conversion - real :: tau_l2r = 900. ! cloud water to rain auto - conversion - real :: tau_v2l = 150. ! water vapor to cloud water (condensation) - real :: tau_l2v = 300. ! cloud water to water vapor (evaporation) - real :: tau_g2v = 900. ! grapuel sublimation - real :: tau_v2g = 21600. ! grapuel deposition -- make it a slow process + real :: tau_r2g = 900. ! rain freezing during fast_sat + real :: tau_smlt = 900. ! snow melting + real :: tau_g2r = 600. ! graupel melting to rain + real :: tau_imlt = 600. ! cloud ice melting + real :: tau_i2s = 1000. ! cloud ice to snow auto - conversion + real :: tau_l2r = 900. ! cloud water to rain auto - conversion + real :: tau_v2l = 150. ! water vapor to cloud water (condensation) + real :: tau_l2v = 300. ! cloud water to water vapor (evaporation) + real :: tau_g2v = 900. ! grapuel sublimation + real :: tau_v2g = 21600. ! grapuel deposition -- make it a slow process ! horizontal subgrid variability - real :: dw_land = 0.20 ! base value for subgrid deviation / variability over land + real :: dw_land = 0.20 ! base value for subgrid deviation / variability over land real :: dw_ocean = 0.10 ! base value for ocean ! prescribed ccn - real :: ccn_o = 90. ! ccn over ocean (cm^ - 3) + real :: ccn_o = 90. ! ccn over ocean (cm^ - 3) real :: ccn_l = 270. ! ccn over land (cm^ - 3) real :: rthresh = 10.0e-6 ! critical cloud drop radius (micro m) @@ -222,10 +222,10 @@ module gfdl_cloud_microphys_mod ! lfo used * mixing ratio * = 1.e-4 (hail in lfo) real :: qs0_crt = 1.0e-3 ! snow to graupel density threshold (0.6e-3 in purdue lin scheme) - real :: c_paut = 0.55 ! autoconversion cloud water to rain (use 0.5 to reduce autoconversion) + real :: c_paut = 0.55 ! autoconversion cloud water to rain (use 0.5 to reduce autoconversion) real :: c_psaci = 0.02 ! accretion: cloud ice to snow (was 0.1 in zetac) - real :: c_piacr = 5.0 ! accretion: rain to ice: - real :: c_cracw = 0.9 ! rain accretion efficiency + real :: c_piacr = 5.0 ! accretion: rain to ice: + real :: c_cracw = 0.9 ! rain accretion efficiency real :: c_pgacs = 2.0e-3 ! snow to graupel "accretion" eff. (was 0.1 in zetac) ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) @@ -257,12 +257,12 @@ module gfdl_cloud_microphys_mod ! cloud microphysics switchers logical :: fast_sat_adj = .false. ! has fast saturation adjustments - logical :: z_slope_liq = .true. ! use linear mono slope for autocconversions - logical :: z_slope_ice = .false. ! use linear mono slope for autocconversions - logical :: use_ccn = .false. ! must be true when prog_ccn is false - logical :: use_ppm = .false. ! use ppm fall scheme - logical :: mono_prof = .true. ! perform terminal fall with mono ppm scheme - logical :: mp_print = .false. ! cloud microphysics debugging printout + logical :: z_slope_liq = .true. ! use linear mono slope for autocconversions + logical :: z_slope_ice = .false. ! use linear mono slope for autocconversions + logical :: use_ccn = .false. ! must be true when prog_ccn is false + logical :: use_ppm = .false. ! use ppm fall scheme + logical :: mono_prof = .true. ! perform terminal fall with mono ppm scheme + logical :: mp_print = .false. ! cloud microphysics debugging printout ! real :: global_area = - 1. @@ -272,28 +272,28 @@ module gfdl_cloud_microphys_mod ! namelist ! ----------------------------------------------------------------------- - namelist / gfdl_cloud_microphysics_nml / & + namelist / gfdl_cloud_microphysics_nml / & mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & - rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & + tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & + rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print - public & + public & mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & + vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & - rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & + tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & + tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & + z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & + rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, mp_print contains @@ -309,10 +309,10 @@ module gfdl_cloud_microphys_mod ! hydrostatic, phys_hydrostatic, & ! iis, iie, jjs, jje, kks, kke, ktop, kbot, time) -subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & - qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & +subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & + 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, iis, iie, jjs, jje, kks, & + graupel, hydrostatic, phys_hydrostatic, iis, iie, jjs, jje, kks, & kke, ktop, kbot, seconds) implicit none @@ -401,8 +401,8 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & ! define cloud microphysics sub time step ! ----------------------------------------------------------------------- - mpdt = min (dt_in, mp_time) - rdt = 1. / dt_in + mpdt = min (dt_in, mp_time) + rdt = 1. / dt_in ntimes = nint (dt_in / mpdt) ! small time step: @@ -429,11 +429,11 @@ subroutine gfdl_cloud_microphys_driver (qv, ql, qr, qi, qs, qg, qa, qn, & ! ----------------------------------------------------------------------- do j = js, je - call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg, & - qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & - 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, & + call mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, qg,& + qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & + rain (:, j), snow (:, j), graupel (:, j), ice (:, j), m2_rain, & + 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) enddo @@ -586,10 +586,10 @@ end subroutine gfdl_cloud_microphys_driver ! 6) qg: graupel (kg / kg) ! ----------------------------------------------------------------------- -subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & +subroutine mpdrv (hydrostatic, uin, vin, w, delp, pt, qv, ql, qr, qi, qs, & qg, qa, qn, dz, is, ie, js, je, ks, ke, ktop, kbot, j, dt_in, ntimes, & - rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & - u_dt, v_dt, pt_dt, qv_dt, ql_dt, qr_dt, qi_dt, qs_dt, qg_dt, qa_dt, & + rain, snow, graupel, ice, m2_rain, m2_sol, cond, area1, land, & + u_dt, v_dt, 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) implicit none diff --git a/gfsphysics/physics/m_micro_driver.f90 b/gfsphysics/physics/m_micro_driver.f90 index 49b6a1468..6e57ecd53 100644 --- a/gfsphysics/physics/m_micro_driver.f90 +++ b/gfsphysics/physics/m_micro_driver.f90 @@ -1,5 +1,5 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & - &, prsl_i, prsi_i, prslk_i, prsik_i & + &, prsl_i, prsi_i, phil, phii & &, omega_i, QLLS_i, QLCN_i, QILS_i, QICN_i& &, lwheat_i, swheat_i, w_upi, cf_upi & &, FRLAND, ZPBL, CNV_MFD_i, CNV_PRC3_i & @@ -8,10 +8,11 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & &, TAUOROX, TAUOROY, CNV_FICE_i & &, CNV_NDROP_i,CNV_NICE_i, q_io, lwm_o & &, qi_o, t_io, rn_o, sr_o & - &, ncpl_io, ncpi_io, fprcp, rnw_io & - &, snw_io, ncpr_io, ncps_io, CLLS_io, KCBL & + &, ncpl_io, ncpi_io, fprcp, rnw_io, snw_io& + &, ncpr_io, ncps_io, CLLS_io, KCBL & + &, CLDREFFL, CLDREFFI, CLDREFFR, CLDREFFS & &, aero_in, skip_macro, cn_prc2, cn_snr & - &, lprnt, ipr, kdt, xlat, xlon) + &, lprnt, ipr, kdt, xlat, xlon, rhc_i) use machine , only: kind_phys use physcons, grav => con_g, pi => con_pi, & @@ -29,6 +30,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & use cldmacro, only: macro_cloud,meltfrz_inst,update_cld, & & meltfrz_inst use cldwat2m_micro,only: mmicro_pcond + use micro_mg2_0, only: micro_mg_tend, qcvar ! use wv_saturation, only: aqsat @@ -37,13 +39,15 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! and Donifan's nuclei activation, notice the vertical coordinate is top-down ! opposite to the GSM dynamic core, much work is still needed to consistently ! treat other parts of the model +! Anning Cheng 9/29/2017 implemented the MG2 from NCAR +! alphar8 for qc_var scaled from climatology value !------------------------------------ ! input ! real, parameter :: r_air = 3.47d-3 - real, parameter :: one=1.0, oneb3=one/3.0, onebcp=one/cp, & - & kapa=rgas*onebcp, cpbg=cp/grav, & - & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp -! & lvbcp=latvap/cp,lsbcp=(latvap+latice)/cp + real, parameter :: one=1.0, oneb3=one/3.0, onebcp=one/cp, & + & kapa=rgas*onebcp, cpbg=cp/grav, & + & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp,& + qsmall=1.e-14 integer, parameter :: ncolmicro = 1 integer,intent(in) :: im, ix,lm, ipr, kdt, fprcp @@ -51,22 +55,23 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & real (kind=kind_phys), intent(in):: dt_i real (kind=kind_phys), dimension(ix,lm),intent(in) :: & - & prsl_i,u_i,v_i,prslk_i,omega_i, QLLS_i,QILS_i, & + & prsl_i,u_i,v_i,phil, omega_i, QLLS_i,QILS_i, & & lwheat_i,swheat_i real (kind=kind_phys), dimension(ix,0:lm),intent(in):: prsi_i, & - & prsik_i + & phii real (kind=kind_phys), dimension(im,lm),intent(in) :: & & CNV_DQLDT_i, CLCN_i, QLCN_i, QICN_i, & & CNV_MFD_i, CNV_PRC3_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & - & CNV_NICE_i, w_upi + & CNV_NICE_i, w_upi, rhc_i real (kind=kind_phys),dimension(im),intent(in):: TAUGWX, & & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY, FRLAND,ZPBL,xlat,xlon ! & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY,ps_i,FRLAND,ZPBL ! & CNVPRCP ! output - real (kind=kind_phys),dimension(ix,lm) :: lwm_o, qi_o - real (kind=kind_phys),dimension(im) :: rn_o,sr_o + real (kind=kind_phys),dimension(ix,lm) :: lwm_o, qi_o, & + cldreffl, cldreffi, cldreffr, cldreffs + real (kind=kind_phys),dimension(im) :: rn_o, sr_o ! input and output real (kind=kind_phys),dimension(ix,lm),intent(inout):: q_io, t_io, & @@ -87,26 +92,26 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & CNV_MFD,CNV_PRC3,CNV_FICE,CNV_NDROP,CNV_NICE real(kind=kind_phys), dimension(IM,LM)::ncpl,ncpi,omega,SC_ICE, & - & RAD_CF, radheat,Q1,U1,V1,TH1,PLO, ZLO,PK, temp, & + & RAD_CF, radheat,Q1,U1,V1, PLO, ZLO, temp, & & QLLS, QLCN, QILS,QICN, CNV_CVW,CNV_UPDF,SMAXL,SMAXI, & & NHET_NUC, NLIM_NUC, CDNC_NUC,INC_NUC,CNN01,CNN04,CNN1,DNHET_IMM, & & NHET_IMM,NHET_DEP,NHET_DHF,DUST_IMM,DUST_DEP, DUST_DHF,WSUB, & & SIGW_GW,SIGW_CNV,SIGW_TURB,SIGW_RC,REV_CN_X,REV_LS_X,RSU_CN_X, & & RSU_LS_X, ALPHT_X, DLPDF_X, DIPDF_X,rnw,snw,ncpr,ncps, & - & ACLL_CN_X,ACIL_CN_X, PFRZ, FQA,QCNTOT,QTOT,QL_TOT,qi_tot,blk_l + & ACLL_CN_X,ACIL_CN_X, PFRZ, FQA,QCNTOT,QTOT,QL_TOT,qi_tot,blk_l,rhc - real(kind=kind_phys), dimension(IM,LM):: DQRL_X, RHCmicro, & + real(kind=kind_phys), dimension(IM,LM):: DQRL_X, & & CNV_DQLDT, CLCN,CLLS, & & CCN01,CCN04,CCN1 - real(kind=kind_phys), dimension(IM,LM):: QST3,DZET,QDDF3, & - & MASS,RHX_X, CFPDF_X, & + real(kind=kind_phys), dimension(IM,LM):: QST3, DZET, QDDF3, & + & MASS, RHX_X, CFPDF_X, & & VFALLSN_CN_X, QSNOW_CN, & - & VFALLRN_CN_X, QRAIN_CN + & VFALLRN_CN_X, QRAIN_CN, dum - real(kind=kind_phys), dimension(IM,LM+1):: ZET - real(kind=kind_phys),dimension(IM,0:LM) :: PLE, PKE, kh,PFI_CN_X,& - PFL_CN_X + real(kind=kind_phys), dimension(IM,LM+1) :: ZET + real(kind=kind_phys), dimension(IM,0:LM) :: PLE, PKE, kh,PFI_CN_X,& + PFL_CN_X real(kind=kind_phys),dimension(0:LM) ::SIGE real(kind=kind_phys),dimension(LM) :: rhdfdar8, rhu00r8, & @@ -118,12 +123,13 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & real(kind=kind_phys), dimension(IM) :: CN_PRC2,CN_SNR,CN_ARFX,& & LS_SNR,LS_PRC2, TPREC, & - & VMIP,twat + & VMIP +! & VMIP, twat ! Anning Cheng 10/24/2016 twat for total water, diagnostic purpose integer, dimension(IM) :: KCBL real(kind=kind_phys), dimension (LM) :: uwind_gw,vwind_gw, & - & tm_gw, pm_gw, nm_gw, h_gw, rho_gw, theta_tr, khaux, qcaux, & + & tm_gw, pm_gw, nm_gw, h_gw, rho_gw, khaux, qcaux, & & dummyW , wparc_cgw, cfaux, dpre8, & & wparc_ls,wparc_gw, swparc,smaxliq,smaxicer8,nheticer8, & & nhet_immr8,dnhet_immr8,nhet_depr8,nhet_dhfr8,sc_icer8, & @@ -134,9 +140,10 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & effir8, nevaprr8, evapsnowr8, prainr8, & & prodsnowr8, cmeoutr8, deffir8, pgamradr8, lamcradr8,qsoutr8, & & qroutr8,droutr8, qcsevapr8,qisevapr8, qvresr8, & - & cmeioutr8 + & cmeioutr8, dsoutr8, qcsinksum_rate1ord,qrtend,nrtend, & + & qstend, nstend, alphar8, rhr8 - real(kind=kind_phys), dimension(1) :: prectr8, precir8 + real(kind=kind_phys), dimension(1) :: prectr8, precir8 real(kind=kind_phys), dimension (LM) :: vtrmcr8,vtrmir8, & & qcsedtenr8,qisedtenr8, praor8,prcor8,mnucccor8, mnucctor8, & @@ -147,15 +154,21 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & ncalr8, ncair8, mnuccdor8, nnucctor8, nsoutr8, nroutr8, & & nnuccdor8, nnucccor8,naair8, & & nsacwior8, nsubior8, nprcior8, npraior8, npccnor8, npsacwsor8, & - & nsubcor8, npraor8, nprc1or8, tlatauxr8,pfrz_inc_r8 + & nsubcor8, npraor8, nprc1or8, tlatauxr8,pfrz_inc_r8,sadice, & + & sadsnow,am_evp_st,lflx,iflx,rflx,sflx,reff_rain,reff_snow, & + & umr,ums,qrsedten,qssedten,refl,arefl,areflz,frefl,csrfl, & + & acsrfl,fcsrfl,rercld,qrout2,qsout2,nrout2,nsout2,drout2, & + & dsout2,freqs,freqr,nfice,qcrat,prer_evap real(kind=kind_phys), dimension (0:LM) :: pi_gw, rhoi_gw, & & ni_gw, ti_gw real(kind=kind_phys), dimension(LM+1) :: pintr8, kkvhr8 - real (kind=kind_phys), parameter :: disp_liu=2., ui_scale=1.0 & - &, dcrit=20.0e-6 & +! real (kind=kind_phys), parameter :: disp_liu=2., ui_scale=1.0 & +! &, dcrit=20.0e-6 & + real (kind=kind_phys), parameter :: disp_liu=1.0, ui_scale=1.0 & + &, dcrit=1.0e-6 & ! &, ts_autice=1800.0 & ! &, ts_autice=3600.0 & !time scale &, ninstr8 = 0.1e6 & @@ -176,8 +189,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & type (AerProps) :: AeroAux, AeroAux_b real, allocatable, dimension(:,:,:) :: AERMASSMIX - logical :: use_average_v - + logical :: use_average_v, ltrue, lprint !================================== !====2-moment Microhysics= @@ -188,15 +200,20 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & TMAXLL/296./, fracover/1./, LTS_LOW/12./, LTS_UP/24./, & & MIN_EXP/0.5/ - data cloudparams/10.,4.,4.,1.,2.e-3,8.e-4,2.,1.,-1.,0.,1.3, & - &1.0e-9, 3.3e-4,20.,4.8,4.8,230.,1.0,1.0,230.,14400.,50.,0.01,0.1, & - &200.,0.,0., 0.5,0.5,2000.,0.8,0.5,-40.0,1.0,4.0,0.0,0.0,0.0, & - &1.0e-3,8.0e-4,1.0,0.95, 1.0,0.0,980.0,1.,1.,1.,0.,0.,1.e-5,2.e-5, & - &2.1e-5,4e-5,3e-5,0.1,1.,150./ - - + data cloudparams/ & + & 10.0, 4.0 , 4.0 , 1.0 , 2.e-3, 8.e-4, 2.0 , 1.0 , -1.0 & + &, 0.0 , 1.3 , 1.0e-9, 3.3e-4, 20.0 , 4.8 , 4.8 , 230.0 , 1.0 & + &, 1.0 , 230.0, 14400., 50.0 , 0.01 , 0.1 , 200.0, 0.0 , 0.0 & + &, 0.5 , 0.5 , 2000.0, 0.8 , 0.5 , -40.0, 1.0 , 4.0 , 0.0 & + &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 900.0& +! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 880.0& +! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 980.0& + &, 1.0 , 1.0 , 1.0 , 0.0 , 0.0 , 1.e-5, 2.e-5, 2.1e-5, 4.e-5& +! &, 3e-5, 0.1 , 4.0 , 250./ + &, 3e-5, 0.1 , 1.0 , 150./ +! rhr8 = 1.0 if(flipv) then DO K=1, LM ll = lm-k+1 @@ -220,19 +237,20 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CNV_UPDF(i,k) = cf_upi(i,ll) CNV_DQLDT(I,K) = CNV_DQLDT_i(I,ll) CLCN(I,k) = CLCN_i(I,ll) - CLLS(I,k) = CLLS_io(I,ll) + CLLS(I,k) = max(CLLS_io(I,ll)-CLCN_i(I,ll),0.0) PLO(i,k) = prsl_i(i,ll)*0.01 - PK(i,k) = prslk_i(i,ll) - TH1(i,k) = t_io(i,ll)/prslk_i(i,ll) + zlo(i,k) = phil(i,ll) * (1.0/grav) + temp(i,k) = t_io(i,ll) radheat(i,k) = lwheat_i(i,ll) + swheat_i(i,ll) + rhc(i,k) = rhc_i(i,ll) END DO END DO DO K=0, LM ll = lm-k DO I = 1,IM - PKE(i,k) = prsik_i(i,ll) - PLE(i,k) = prsi_i(i,ll) *.01 ! interface pressure in hPa + PLE(i,k) = prsi_i(i,ll) *.01 ! interface pressure in hPa + zet(i,k+1) = phii(i,ll) * (1.0/grav) END DO END DO if (.not. skip_macro) then @@ -273,18 +291,19 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CNV_UPDF(i,k) = cf_upi(i,k) CNV_DQLDT(I,K) = CNV_DQLDT_i(I,k) CLCN(I,k) = CLCN_i(I,k) - CLLS(I,k) = CLLS_io(I,k) + CLLS(I,k) = max(CLLS_io(I,k)-CLCN_i(I,k),0.0) PLO(i,k) = prsl_i(i,k)*0.01 - PK(i,k) = prslk_i(i,k) - TH1(i,k) = t_io(i,k)/prslk_i(i,k) + zlo(i,k) = phil(i,k) * (1.0/grav) + temp(i,k) = t_io(i,k) radheat(i,k) = lwheat_i(i,k) + swheat_i(i,k) + rhc(i,k) = rhc_i(i,k) END DO END DO DO K=0, LM DO I = 1,IM - PKE(i,k) = prsik_i(i,k) - PLE(i,k) = prsi_i(i,k) *.01 ! interface pressure in hPa + PLE(i,k) = prsi_i(i,k) *.01 ! interface pressure in hPa + zet(i,k+1) = phii(i,k) * (1.0/grav) END DO END DO if (.not. skip_macro) then @@ -307,7 +326,6 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do i=1,im KCBL(i) = max(LM-KCBL(i),10) - ZET(i,LM+1) = 0.0 vmip(i) = 0.0 KCT(i) = 10 enddo @@ -324,12 +342,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do L=LM,1,-1 do i=1,im - tx1 = cpbg * TH1 (i,L) * (1.0+VIREPS*Q1(i,L)) - ZLO(i,L ) = ZET(i,L+1) + tx1 * (PKE(i,L)-PK (i,L )) - ZET(i,L) = ZLO(i,L) + tx1 * (PK (i,L)-PKE(i,L-1)) DZET(i,L) = ZET(i,L) - ZET(i,L+1) -! - temp(i,l) = th1(i,l) * PK(i,l) tx1 = plo(i,l)*100.0 est3 = min(tx1, fpvs(temp(i,l))) qst3(i,l) = min(eps*est3/max(tx1+epsm1*est3,1.0e-10),1.0) @@ -412,7 +425,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & enddo end do - T_ICE_ALL = TICE - 40.0 +! T_ICE_ALL = TICE - 40.0 + T_ICE_ALL = CLOUDPARAMS(33) + TICE @@ -473,7 +487,6 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & pm_gw(k) = 100.0*PLO(I,k) tm_gw(k) = TEMP(I,k) - theta_tr(k) = TH1(I,k) nm_gw(k) = 0.0 rho_gw(k) = pm_gw(k) /(RGAS*tm_gw(k)) @@ -614,23 +627,22 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & if (plevr8(K) > 100.0) then - ccn_diag(1) = 0.001 ccn_diag(2) = 0.004 ccn_diag(3) = 0.01 - - if (K > 2 .and. K <= LM-2) then tauxr8 = (ter8(K-1) + ter8(K+1) + ter8(K)) * oneb3 - end if + else + tauxr8 = ter8(K) + endif if(aero_in) then AeroAux = AeroProps(I, K) else call init_Aer(AeroAux) call init_Aer(AeroAux_b) - end if + endif pfrz_inc_r8(k) = 0.0 rh1_r8 = 0.0 !related to cnv_dql_dt, needed to changed soon @@ -682,7 +694,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & NLIM_NUC(I,k) = nlimicer8(k) * 1e-6 SC_ICE(I,k) = min(max(sc_icer8(k),1.0),2.0) ! SC_ICE(I,k) = min(max(sc_icer8(k),1.0),1.2) - if(temp(i,k) > T_ICE_ALL) SC_ICE(i,k)=1.0 + if(temp(i,k) > T_ICE_ALL) SC_ICE(i,k) = 1.0 + if(temp(i,k) > TICE) SC_ICE(i,k) = rhc(i,k) CDNC_NUC(I,k) = npccninr8(k) INC_NUC (I,k) = naair8(k) NHET_IMM(I,k) = max(nhet_immr8(k), 0.0) @@ -728,16 +741,20 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & enddo enddo - if(lprnt) write(0,*)' skip_macro=',skip_macro +! if(lprnt) write(0,*)' skip_macro=',skip_macro if (.not. skip_macro) then ! if (lprnt) write(0,*) ' in micro qicn2=',qicn(ipr,25),' kdt=',kdt& ! &,' qils=',qils(ipr,25) +! if(lprnt) write(0,*)' bef macro_cloud clcn=',clcn(ipr,:) +! if(lprnt) write(0,*)' bef macro_cloud clls=',clls(ipr,:) - call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, PK, FRLAND, & +! call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, PK, FRLAND, & + call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, FRLAND, & & CNV_MFD, CNV_DQLDT, CNV_PRC3, CNV_UPDF, & - & U1, V1, TH1, Q1, QLLS, QLCN, QILS, QICN, & + & U1, V1, temp, Q1, QLLS, QLCN, QILS, QICN, & +! & U1, V1, TH1, Q1, QLLS, QLCN, QILS, QICN, & & CLCN, CLLS, CN_PRC2, CN_ARFX, CN_SNR, & & CLOUDPARAMS, SCLMFDFR, QST3, DZET, QDDF3, & & RHX_X, REV_CN_X, RSU_CN_X, & @@ -746,10 +763,11 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & & ALPHT_X, CFPDF_X, DQRL_X, VFALLSN_CN_X, & & VFALLRN_CN_X, CNV_FICE, CNV_NDROP, CNV_NICE, & & SC_ICE, NCPL, NCPI, PFRZ, & - & QRAIN_CN, QSNOW_CN, KCBL, lprnt, ipr) + & QRAIN_CN, QSNOW_CN, KCBL, lprnt, ipr, rhc) ! if (lprnt) write(0,*) ' in micro qicn3=',qicn(ipr,25) ! if(lprnt) write(0,*)' aft macro_cloud clcn=',clcn(ipr,:) +! if(lprnt) write(0,*)' aft macro_cloud clls=',clls(ipr,:) ! if(lprnt) write(0,*)' aft macro_cloud q1=',q1(ipr,:) ! if(lprnt) write(0,*)' aft macro_cloud qils=',qils(ipr,:) @@ -763,7 +781,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CNV_NDROP(i,k) = 0.0 CNV_NICE(i,k) = 0.0 endif - temp(i,k) = th1(i,k) * PK(i,k) +! temp(i,k) = th1(i,k) * PK(i,k) RAD_CF(i,k) = min(CLLS(i,k)+CLCN(i,k), 1.0) if (PFRZ(i,k) > 0.0) then @@ -779,8 +797,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & !make sure QI , NI stay within T limits - call meltfrz_inst(IM, LM, TEMP, QLLS, QLCN, QILS, QICN, NCPL, & - & NCPI) + call meltfrz_inst(IM, LM, TEMP, QLLS, QLCN, QILS, QICN, NCPL, NCPI) !============ a little treatment of cloud before micorphysics ! call update_cld(im,lm,DT_MOIST, ALPHT_X & @@ -805,8 +822,6 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! - - !TVQX1 = SUM( ( Q1 + QLCN + QICN )*DM, 3) do k=1,lm @@ -863,8 +878,16 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & cldfr8(k) = 0.0 endif - liqcldfr8(k) = cldfr8(k) - icecldfr8(k) = cldfr8(k) + if (temp(i,k) > tice) then + liqcldfr8(k) = cldfr8(k) + icecldfr8(k) = 0.0 + elseif (temp(i,k) <= t_ice_all) then + liqcldfr8(k) = 0.0 + icecldfr8(k) = cldfr8(k) + else + icecldfr8(k) = cldfr8(k) * (tice - temp(i,k))/(tice-t_ice_all) + liqcldfr8(k) = cldfr8(k) - icecldfr8(k) + endif cldor8(k) = cldfr8(k) @@ -916,127 +939,200 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & zmr8(k) = ZLO(I,k) ficer8(k) = qir8(k) /( qcr8(k)+qir8(k) + 1.e-10 ) omegr8(k) = WSUB(I,k) +! alphar8(k) = max(alpht_x(i,k)/maxval(alpht_x(i,:))*8.,0.5) + alphar8(k) = qcvar + rhr8(k) = rhc(i,k) END DO do k=1,lm+1 pintr8(k) = PLE(I,k-1) * 100.0 kkvhr8(k) = KH(I,k-1) END DO +! +! do k=1,lm +! if (cldfr8(k) <= 0.2 ) then +! alphar8(k) = 0.5 +! elseif (cldfr8(k) <= 0.999) then +!! tx1 = 0.0284 * exp(4.4*cldfr8(k)) +!! alphar8(k) = tx1 / (cldfr8(k) - tx1*(one-cldfr8(k))) +!! alphar8(k) = 0.5 + (7.5/0.799)*(cldfr8(k)-0.2) +! alphar8(k) = 0.5 + (7.5/0.799)*(cldfr8(k)-0.2) +! else +! alphar8(k) = 8.0 +! endif +! alphar8(k) = min(8.0, max(alphar8(k), 0.5)) +! enddo kbmin = KCBL(I) !!!Call to MG microphysics. Lives in cldwat2m_micro.f ! ttendr8, qtendr8,cwtendr8, not used so far Anning noted August 2015 - call mmicro_pcond ( ncolmicro, ncolmicro, dt_r8, ter8, ttendr8, & - & ncolmicro, LM , qvr8, qtendr8, cwtendr8, qcr8, qir8, ncr8, nir8, & - & fprcp,qrr8, qsr8, nrr8, nsr8, & - & plevr8, pdelr8, cldfr8, liqcldfr8, icecldfr8, cldor8, pintr8, & - & rpdelr8, zmr8, rate1ord_cw2pr, naair8, npccninr8, & -! & rpdelr8, zmr8, omegr8, rate1ord_cw2pr, naair8, npccninr8, & - & rndstr8,naconr8, rhdfdar8, rhu00r8, ficer8, & - & tlatr8, qvlatr8, qctendr8, qitendr8, nctendr8, nitendr8, effcr8, & - & effc_fnr8, effir8, prectr8, precir8, nevaprr8, evapsnowr8, & - & prainr8, prodsnowr8, cmeoutr8, deffir8, pgamradr8, lamcradr8, & - & qsoutr8, qroutr8,droutr8, qcsevapr8,qisevapr8, qvresr8, & - & cmeioutr8, vtrmcr8,vtrmir8, qcsedtenr8,qisedtenr8, praor8,prcor8,& - & mnucccor8, mnucctor8,msacwior8,psacwsor8, bergsor8,bergor8, & - & meltor8, homoor8,qcresor8,prcior8, praior8,qiresor8, mnuccror8, & - & pracsor8, meltsdtr8,frzrdtr8, ncalr8, ncair8, mnuccdor8, & - & nnucctor8, nsoutr8, nroutr8, ncnstr8, ninstr8, nimmr8, disp_liu, & - & nsootr8, rnsootr8, ui_scale, dcrit, nnuccdor8, nnucccor8, & - & nsacwior8, nsubior8, nprcior8, npraior8, npccnor8, npsacwsor8, & - & nsubcor8, npraor8, nprc1or8, tlatauxr8, nbincontactdust, & -! & kbmin, lprint ) - & lprnt,xlat(i),xlon(i)) - - -! if (lprint) write(0,*)' prectr8=',prectr8(1), & -! & ' precir8=',precir8(1) - LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) - LS_SNR(I) = max(1000.*precir8(1), 0.0) + if (fprcp <= 0) then ! if fprcp=-1, then Anning's code for MG2 will be used + call mmicro_pcond ( ncolmicro, ncolmicro, & + & dt_r8, ter8, ttendr8, & + & ncolmicro, LM , qvr8, & + & qtendr8, cwtendr8, qcr8, qir8, ncr8, nir8, & + & abs(fprcp), qrr8, qsr8, nrr8, nsr8, & + & plevr8, pdelr8, cldfr8, liqcldfr8, & + & icecldfr8, cldor8, pintr8, & + & rpdelr8, zmr8, rate1ord_cw2pr, & + & naair8, npccninr8, & + & rndstr8, naconr8, rhdfdar8, rhu00r8, ficer8, & + & tlatr8, qvlatr8, qctendr8, & + & qitendr8, nctendr8, nitendr8, effcr8, & + & effc_fnr8, effir8, prectr8, precir8, & + & nevaprr8, evapsnowr8, & + & prainr8, prodsnowr8, cmeoutr8, & + & deffir8, pgamradr8, lamcradr8, & + & qsoutr8, dsoutr8, qroutr8, droutr8, & + & qcsevapr8, qisevapr8, qvresr8, & + & cmeioutr8, vtrmcr8, vtrmir8, & + & qcsedtenr8, qisedtenr8, praor8, prcor8, & + & mnucccor8, mnucctor8, msacwior8, & + & psacwsor8, bergsor8, bergor8, & + & meltor8, homoor8, qcresor8, prcior8, & + & praior8, qiresor8, mnuccror8, & + & pracsor8, meltsdtr8, frzrdtr8, ncalr8, & + & ncair8, mnuccdor8, & + & nnucctor8, nsoutr8, nroutr8, & + & ncnstr8, ninstr8, nimmr8, disp_liu, & + & nsootr8, rnsootr8, ui_scale, dcrit, & + & nnuccdor8, nnucccor8, & + & nsacwior8, nsubior8, nprcior8, & + & npraior8, npccnor8, npsacwsor8, & + & nsubcor8, npraor8, nprc1or8, & + & tlatauxr8, nbincontactdust, & + & lprnt, xlat(i), xlon(i), rhr8) + +! if (lprint) write(0,*)' prectr8=',prectr8(1), & +! & ' precir8=',precir8(1) + LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) + LS_SNR(I) = max(1000.*precir8(1), 0.0) - do k=1,lm - QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 - QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 - Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_R8 + do k=1,lm + QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 + QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 + Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_R8 ! if(lprnt .and. i == ipr) write(0,*)' k=',k,' q1aftm=',q1(i,k) & ! &,' qvlatr8=',qvlatr8(k) - TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp - - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, 0.0) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, 0.0) - rnw(I,k) = qrr8(k) - snw(I,k) = qsr8(k) - NCPR(I,k) = nrr8(k) - NCPS(I,k) = nsr8(k) - - - -! CLDREFFL(I,k) = max(effcr8(k)*1.0e-6, 1.0e-6) -! CLDREFFI(I,k) = max(effir8(k)*1.0e-6, 1.0e-6) -! CLDREFFR(I,k) = droutr8(k) * 0.5 -! CLDREFFS(I,k) = 0.192*dsoutr8(k) * 0.5 - - -! QRAIN(I,k) = max(qroutr8(k), 0.0) -! QSNOW(I,k) = max(qsoutr8(k), 0.0) -! NRAIN(I,k) = max(nroutr8(k), 0.0) -! NSNOW(I,k) = max(nsoutr8(k), 0.0) - - - - -! RSU_LS_X(I,k) = evapsnowr8(k) -! REV_LS_X(I,k) = nevaprr8(k) -! SUBLC_X(I,k) = cmeioutr8(k) -! BERGS(I,k) = bergsor8(k) -! FRZ_TT_X(I,k) = mnucccor8(k) + mnucctor8(k) + homoor8(k) -! FRZ_PP_X(I,k) = mnuccror8(k) + pracsor8(k) -! MELT(I,k) = meltor8(k) -! SDM_X(I,k) = qisedtenr8(k) -! EVAPC_X(I,k) = qcsevapr8(k) -! BERG(I,k) = bergor8(k) -! ACIL_LS_X(I,k) = psacwsor8(k) + msacwior8(k, 1:LM) -! QCRES(I,k) = qcresor8(k) -! QIRES(I,k) = qiresor8(k) - -! ACLL_LS_X(I,k) = praor8(k) -! AUT_X(I,k) = prcor8(k) -! AUTICE(I,k) = prcior8(k) -! ACIL_AN_X(I,k) = praior8(k) -! ACLL_AN_X(I,k) = msacwior8(k) - -! FRZPP_LS(I,k) = frzrdtr8(k) * onebcp -! SNOWMELT_LS(I,k) = meltsdtr8(k)* onebcp - - - -! DNHET_CT(I,k) = nnucctor8(k) -! DNHET_IMM(I,k) = nnucccor8(k) -! DNCNUC(I,k) = nnuccdor8(k) -! DNCHMSPLIT(I,k) = nsacwior8(k) -! DNCSUBL (I,k) = nsubior8(k) -! DNCACRIS (I,k) = npraior8(k) -! DNCAUTICE (I,k) = nprcior8(k) - -! DNDCCN(I,k) = npccnor8(k) -! DNDACRLS(I,k) = npsacwsor8(k) -! DNDACRLR(I,k) = npraor8(k) -! DNDEVAPC(I,k) = nsubcor8(k) -! DNDAUTLIQ(I,k) = nprc1or8(k) - - - - -! DQRL_X(I,k) = qroutr8(k)/DT_R8 -! DQVDT_micro(I,k) = qvlatr8(k) -! DQIDT_micro(I,k) = qitendr8(k) -! DQLDT_micro(I,k) = qctendr8(k) -! DTDT_micro(I,k) = tlatr8(k) * onebcp - - enddo ! K loop + TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp + + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, 0.0) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, 0.0) + rnw(I,k) = qrr8(k) + snw(I,k) = qsr8(k) + NCPR(I,k) = nrr8(k) + NCPS(I,k) = nsr8(k) + + CLDREFFL(I,k) = min(max(effcr8(k), 10.),150.) + CLDREFFI(I,k) = min(max(effir8(k), 20.),150.) + CLDREFFR(I,k) = max(droutr8(k)*0.5*1.e6,150.) + CLDREFFS(I,k) = max(0.192*dsoutr8(k)*0.5*1.e6,250.) + + enddo ! K loop + + else + ltrue = any(qcr8 >= qsmall) .or. any(qir8 >= qsmall) & + .or.any(qsr8 >= qsmall) .or. any(qrr8 >= qsmall) +! if (lprnt .and. i == ipr) then +! write(0,*)' bef micro_mg_tend ter8= ', ter8(:) +! write(0,*)' bef micro_mg_tend qvr8= ', qvr8(:),'dt_r8=',dt_r8 +! write(0,*)' bef micro_mg_tend rhr8= ', rhr8(:) +! endif + lprint = lprnt .and. i == ipr + if (ltrue) then + call micro_mg_tend ( & + & ncolmicro, lm, dt_r8, & + & ter8, qvr8, & + & qcr8, qir8, & + & ncr8, nir8, & + & qrr8, qsr8, & + & nrr8, nsr8, & + & alphar8, 1., & + & plevr8, pdelr8, & +! & cldfr8, liqcldfr8, icecldfr8, rhc, & + & cldfr8, liqcldfr8, icecldfr8, rhr8, & + & qcsinksum_rate1ord, & + & naair8, npccninr8, & + & rndstr8, naconr8, & + & tlatr8, qvlatr8, & + & qctendr8, qitendr8, & + & nctendr8, nitendr8, & + & qrtend, qstend, & + & nrtend, nstend, & + & effcr8, effc_fnr8, effir8, & + & sadice, sadsnow, & + & prectr8, precir8, & + & nevaprr8, evapsnowr8, & + & am_evp_st, & + & prainr8, prodsnowr8, & + & cmeoutr8, deffir8, & + & pgamradr8, lamcradr8, & + & qsoutr8, dsoutr8, & + & lflx, iflx, & + & rflx, sflx, qroutr8, & + & reff_rain, reff_snow, & + & qcsevapr8, qisevapr8, qvresr8, & + & cmeioutr8, vtrmcr8, vtrmir8, & + & umr, ums, & + & qcsedtenr8, qisedtenr8, & + & qrsedten, qssedten, & + & praor8, prcor8, & + & mnucccor8, mnucctor8, msacwior8, & + & psacwsor8, bergsor8, bergor8, & + & meltor8, homoor8, & + & qcresor8, prcior8, praior8, & + & qiresor8, mnuccror8, pracsor8, & + & meltsdtr8, frzrdtr8, mnuccdor8, & + & nroutr8, nsoutr8, & + & refl, arefl, areflz, & + & frefl, csrfl, acsrfl, & + & fcsrfl, rercld, & + & ncair8, ncalr8, & + & qrout2, qsout2, & + & nrout2, nsout2, & + & drout2, dsout2, & + & freqs, freqr, & + & nfice, qcrat, & + & prer_evap,xlat(i),xlon(i), lprint) + + LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) + LS_SNR(I) = max(1000.*precir8(1), 0.0) + do k=1,lm + QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 + QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 + Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_R8 + TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, 0.0) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, 0.0) + rnw(I,k) = rnw(I,k) + qrtend(k)*dt_r8 + snw(I,k) = snw(I,k) + qstend(k)*dt_r8 + NCPR(I,k) = NCPR(I,k) + nrtend(k)*dt_r8 + NCPS(I,k) = NCPS(I,k) + nstend(k)*dt_r8 + + CLDREFFL(I,k) = min(max(effcr8(k), 10.),150.) + CLDREFFI(I,k) = min(max(effir8(k), 20.),150.) + CLDREFFR(I,k) = max(reff_rain(k),150.) + CLDREFFS(I,k) = max(reff_snow(k),250.) + enddo ! K loop +! if (lprnt .and. i == ipr) then +! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) +! write(0,*)' aft micro_mg_tend q1= ', q1(i,:) +! endif + else + LS_PRC2(I) = 0. + LS_SNR(I) = 0. + do k=1,lm + CLDREFFL(I,k) = 10. + CLDREFFI(I,k) = 50. + CLDREFFR(I,k) = 1000. + CLDREFFS(I,k) = 250. + + enddo ! K loop + endif + endif enddo ! I loop !============================================Finish 2-moment micro implementation=========================== @@ -1055,10 +1151,10 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & end do call update_cld(im,lm, DT_MOIST, ALPHT_X & - &, INT(CLOUDPARAMS(57)), PLO, Q1, QLLS & - &, QLCN, QILS, QICN, TEMP & - &, CLLS, CLCN, SC_ICE, NCPI & - &, NCPL, INC_NUC, RHCmicro) + &, INT(CLOUDPARAMS(57)), PLO, Q1, QLLS, QLCN & + &, QILS, QICN, TEMP, CLLS, CLCN & + &, SC_ICE, NCPI, NCPL) + do k=1,lm do i=1,im @@ -1100,7 +1196,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ncps_io(i,k) = NCPS(i,ll) lwm_o(i,k) = QL_TOT(i,ll) qi_o(i,k) = QI_TOT(i,ll) - CLLS_io(i,k) = CLLS(i,ll) +! CLLS_io(i,k) = CLLS(i,ll) + CLLS_io(i,k) = min(CLLS(i,ll)+CLCN(i,ll),1.0) END DO END DO else @@ -1116,7 +1213,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ncps_io(i,k) = NCPS(i,k) lwm_o(i,k) = QL_TOT(i,k) qi_o(i,k) = QI_TOT(i,k) - CLLS_io(i,k) = CLLS(i,k) +! CLLS_io(i,k) = CLLS(i,k) + CLLS_io(i,k) = min(CLLS(i,k)+CLCN(i,k),1.) END DO END DO end if @@ -1134,6 +1232,24 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & cn_snr(i) = cn_snr(i) * dt_i * 0.001 END DO +! if (lprnt) then +! write(0,*)' end micro_mg_tend t_io= ', t_io(ipr,:) +! endif +! do k=1,lm +! do i=1,im +! dum(i,k) = clls_io(i,k) +! enddo +! enddo +! do k=2,lm-1 +! do i=1,im +! clls_io(i,k) = 0.25*dum(i,k-1) + 0.5*dum(i,k)+0.25*dum(i,k+1) +! enddo +! enddo +! do i=1,im +! clls_io(i,lm) = 0.5 * (dum(i,lm-1) + dum(i,lm)) +! enddo + + !======================================================================= diff --git a/gfsphysics/physics/micro_mg2_0.F90 b/gfsphysics/physics/micro_mg2_0.F90 new file mode 100755 index 000000000..0f4ba0f3f --- /dev/null +++ b/gfsphysics/physics/micro_mg2_0.F90 @@ -0,0 +1,3231 @@ +module micro_mg2_0 +!--------------------------------------------------------------------------------- +! Purpose: +! MG microphysics version 2.0 - Update of MG microphysics with +! prognostic precipitation. +! +! Author: Andrew Gettelman, Hugh Morrison, Sean Santos +! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan +! Anning Cheng adopted for FV3GFS 9/29/2017 +! add GMAO ice conversion and Liu et. al liquid water +! conversion in 10/12/2017 +! Anning showed promising results for FV3GFS on 10/15/2017 +! S. Moorthi - Oct/Nov 2017 - optimized the code +! S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit +! Version 2 history: Sep 2011: Development begun. +! Feb 2013: Added of prognostic precipitation. +! Aug 2015: Published and released version +! +! invoked in CAM by specifying -microphys=mg2.0 +! +! References: +! +! Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. +! +! Part I: Off line tests and comparisons with other schemes. +! +! J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. +! +! +! +! Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell +! +! Advanced Two-Moment Microphysics for Global Models. +! +! Part II: Global model solutions and Aerosol-Cloud Interactions. +! +! J. Climate, 28, 1288-1307. doi:10.1175/JCLI-D-14-00103.1 , 2015. +! +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- +! +! NOTE: Modified to allow other microphysics packages (e.g. CARMA) to do ice +! microphysics in cooperation with the MG liquid microphysics. This is +! controlled by the do_cldice variable. +! +! If do_cldice is false, then MG microphysics should not update CLDICE or +! NUMICE; it is assumed that the other microphysics scheme will have updated +! CLDICE and NUMICE. The other microphysics should handle the following +! processes that would have been done by MG: +! - Detrainment (liquid and ice) +! - Homogeneous ice nucleation +! - Heterogeneous ice nucleation +! - Bergeron process +! - Melting of ice +! - Freezing of cloud drops +! - Autoconversion (ice -> snow) +! - Growth/Sublimation of ice +! - Sedimentation of ice +! +! This option has not been updated since the introduction of prognostic +! precipitation, and probably should be adjusted to cover snow as well. +! +!--------------------------------------------------------------------------------- +! Based on micro_mg (restructuring of former cldwat2m_micro) +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Xiaohong Liu and Steve Ghan +! December 2005-May 2010 +! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) +! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- +! Code comments added by HM, 093011 +! General code structure: +! +! Code is divided into two main subroutines: +! subroutine micro_mg_init --> initializes microphysics routine, should be called +! once at start of simulation +! subroutine micro_mg_tend --> main microphysics routine to be called each time step +! this also calls several smaller subroutines to calculate +! microphysical processes and other utilities +! +! List of external functions: +! qsat_water --> for calculating saturation vapor pressure with respect to liquid water +! qsat_ice --> for calculating saturation vapor pressure with respect to ice +! gamma --> standard mathematical gamma function +! ......................................................................... +! List of inputs through use statement in fortran90: +! Variable Name Description Units +! ......................................................................... +! gravit acceleration due to gravity m s-2 +! rair dry air gas constant for air J kg-1 K-1 +! tmelt temperature of melting point for water K +! cpair specific heat at constant pressure for dry air J kg-1 K-1 +! rh2o gas constant for water vapor J kg-1 K-1 +! latvap latent heat of vaporization J kg-1 +! latice latent heat of fusion J kg-1 +! qsat_water external function for calculating liquid water +! saturation vapor pressure/humidity - +! qsat_ice external function for calculating ice +! saturation vapor pressure/humidity pa +! rhmini relative humidity threshold parameter for +! nucleating ice - +! ......................................................................... +! NOTE: List of all inputs/outputs passed through the call/subroutine statement +! for micro_mg_tend is given below at the start of subroutine micro_mg_tend. +!--------------------------------------------------------------------------------- + +! Procedures required: +! 1) An implementation of the gamma function (if not intrinsic). +! 2) saturation vapor pressure and specific humidity over water +! 3) svp over ice +use machine, only : r8 => kind_phys +use physcons, only : epsqs => con_eps, fv => con_fvirt +use funcphys, only : fpvsl, fpvsi + +!use wv_sat_methods, only: & +! qsat_water => wv_sat_qsat_water, & +! qsat_ice => wv_sat_qsat_ice + +! Parameters from the utilities module. +use micro_mg_utils, only : pi, omsm, qsmall, mincld, rhosn, rhoi, & + rhow, rhows, ac, bc, ai, bi, & + aj, bj, ar, br, as, bs, & + mi0, rising_factorial + +implicit none +private +save + +public :: micro_mg_init, micro_mg_tend, qcvar + +! Switches for specification rather than prediction of droplet and crystal number +! note: number will be adjusted as needed to keep mean size within bounds, +! even when specified droplet or ice number is used +! +! If constant cloud ice number is set (nicons = .true.), +! then all microphysical processes except mass transfer due to ice nucleation +! (mnuccd) are based on the fixed cloud ice number. Calculation of +! mnuccd follows from the prognosed ice crystal number ni. + +logical :: nccons ! nccons = .true. to specify constant cloud droplet number +logical :: nicons ! nicons = .true. to specify constant cloud ice number + +! specified ice and droplet number concentrations +! note: these are local in-cloud values, not grid-mean +real(r8) :: ncnst ! droplet num concentration when nccons=.true. (m-3) +real(r8) :: ninst ! ice num concentration when nicons=.true. (m-3) + +!========================================================= +! Private module parameters +!========================================================= + +!Range of cloudsat reflectivities (dBz) for analytic simulator +real(r8), parameter :: csmin = -30._r8 +real(r8), parameter :: csmax = 26._r8 +real(r8), parameter :: mindbz = -99._r8 +real(r8), parameter :: minrefl = 1.26e-10_r8 ! minrefl = 10._r8**(mindbz/10._r8) + +! autoconversion size threshold for cloud ice to snow (m) +real(r8) :: dcs, ts_au, qcvar + +! minimum mass of new crystal due to freezing of cloud droplets done +! externally (kg) +real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 +real(r8), parameter :: zero=0.0_r8, one=1.0_r8, two=2.0_r8, three=3.0_r8, & + four=4.0_r8, five=5.0_r8, six=6._r8, half=0.5_r8, & + ten=10.0_r8, forty=40.0_r8, epsln=1.0e-8_r8 + +!========================================================= +! Constants set in initialization +!========================================================= + +! Set using arguments to micro_mg_init +real(r8) :: g ! gravity +real(r8) :: r ! dry air gas constant +real(r8) :: rv ! water vapor gas constant +real(r8) :: cpp ! specific heat of dry air +real(r8) :: tmelt ! freezing point of water (K) + +! latent heats of: +real(r8) :: xxlv ! vaporization +real(r8) :: xlf ! freezing +real(r8) :: xxls ! sublimation + +real(r8) :: rhmini ! Minimum rh for ice cloud fraction > 0. + +! flags +logical :: microp_uniform, do_cldice, use_hetfrz_classnuc + +real(r8) :: rhosu ! typical 850mn air density + +real(r8) :: icenuct ! ice nucleation temperature: currently -5 degrees C + +real(r8) :: snowmelt ! what temp to melt all snow: currently 2 degrees C +real(r8) :: rainfrze ! what temp to freeze all rain: currently -5 degrees C + +! additional constants to help speed up code +real(r8) :: gamma_br_plus1, gamma_bs_plus1, gamma_bi_plus1, gamma_bj_plus1 +real(r8) :: gamma_br_plus4, gamma_bs_plus4, gamma_bi_plus4, gamma_bj_plus4 +real(r8) :: xxlv_squared, xxls_squared +real(r8) :: omeps + +character(len=16) :: micro_mg_precip_frac_method ! type of precipitation fraction method +real(r8) :: micro_mg_berg_eff_factor ! berg efficiency factor + +logical :: allow_sed_supersat ! Allow supersaturated conditions after sedimentation loop +logical :: do_sb_physics ! do SB 2001 autoconversion or accretion physics + +!=============================================================================== +contains +!=============================================================================== + +subroutine micro_mg_init( & + kind, gravit, rair, rh2o, cpair, & + tmelt_in, latvap, latice, & + rhmini_in, micro_mg_dcs,ts_auto, mg_qcvar, & + microp_uniform_in, do_cldice_in, use_hetfrz_classnuc_in, & + micro_mg_precip_frac_method_in, micro_mg_berg_eff_factor_in, & + allow_sed_supersat_in, do_sb_physics_in, & + nccons_in, nicons_in, ncnst_in, ninst_in) + + use micro_mg_utils, only : micro_mg_utils_init + use wv_saturation, only : gestbl + + !----------------------------------------------------------------------- + ! + ! Purpose: + ! initialize constants for MG microphysics + ! + ! Author: Andrew Gettelman Dec 2005 + ! + !----------------------------------------------------------------------- + + integer, intent(in) :: kind ! Kind used for reals + real(r8), intent(in) :: gravit + real(r8), intent(in) :: rair + real(r8), intent(in) :: rh2o + real(r8), intent(in) :: cpair + real(r8), intent(in) :: tmelt_in ! Freezing point of water (K) + real(r8), intent(in) :: latvap + real(r8), intent(in) :: latice + real(r8), intent(in) :: rhmini_in ! Minimum rh for ice cloud fraction > 0. + real(r8), intent(in) :: micro_mg_dcs + real(r8), intent(in) :: ts_auto + real(r8), intent(in) :: mg_qcvar + + logical, intent(in) :: microp_uniform_in ! .true. = configure uniform for sub-columns + ! .false. = use w/o sub-columns (standard) + logical, intent(in) :: do_cldice_in ! .true. = do all processes (standard) + ! .false. = skip all processes affecting cloud ice + logical, intent(in) :: use_hetfrz_classnuc_in ! use heterogeneous freezing + + character(len=16),intent(in) :: micro_mg_precip_frac_method_in ! type of precipitation fraction method + real(r8), intent(in) :: micro_mg_berg_eff_factor_in ! berg efficiency factor + logical, intent(in) :: allow_sed_supersat_in ! allow supersaturated conditions after sedimentation loop + logical, intent(in) :: do_sb_physics_in ! do SB autoconversion and accretion physics + + logical, intent(in) :: nccons_in, nicons_in + real(r8), intent(in) :: ncnst_in, ninst_in + logical ip + real(r8):: tmn, tmx, trice + + + + !----------------------------------------------------------------------- + + dcs = micro_mg_dcs * 1.0e-6 + ts_au = ts_auto + qcvar = mg_qcvar + + ! Initialize subordinate utilities module. + call micro_mg_utils_init(kind, rh2o, cpair, tmelt_in, latvap, latice, dcs) + + + ! declarations for MG code (transforms variable names) + + g = gravit ! gravity + r = rair ! dry air gas constant: note units(phys_constants are in J/K/kmol) + rv = rh2o ! water vapor gas constant + cpp = cpair ! specific heat of dry air + tmelt = tmelt_in + rhmini = rhmini_in + micro_mg_precip_frac_method = micro_mg_precip_frac_method_in + micro_mg_berg_eff_factor = micro_mg_berg_eff_factor_in + allow_sed_supersat = allow_sed_supersat_in + do_sb_physics = do_sb_physics_in + + nccons = nccons_in + nicons = nicons_in + ncnst = ncnst_in + ninst = ninst_in + + ! latent heats + + xxlv = latvap ! latent heat vaporization + xlf = latice ! latent heat freezing + xxls = xxlv + xlf ! latent heat of sublimation + + ! flags + microp_uniform = microp_uniform_in + do_cldice = do_cldice_in + use_hetfrz_classnuc = use_hetfrz_classnuc_in + + ! typical air density at 850 mb + + rhosu = 85000._r8 / (rair * tmelt) + + ! Maximum temperature at which snow is allowed to exist + snowmelt = tmelt + two + ! Minimum temperature at which rain is allowed to exist + rainfrze = tmelt - forty + + ! Ice nucleation temperature + icenuct = tmelt - five + + ! Define constants to help speed up code (this limits calls to gamma function) + gamma_br_plus1 = gamma(one+br) + gamma_br_plus4 = gamma(four+br) + gamma_bs_plus1 = gamma(one+bs) + gamma_bs_plus4 = gamma(four+bs) + gamma_bi_plus1 = gamma(one+bi) + gamma_bi_plus4 = gamma(four+bi) + gamma_bj_plus1 = gamma(one+bj) + gamma_bj_plus4 = gamma(four+bj) + + xxlv_squared = xxlv * xxlv + xxls_squared = xxls * xxls + omeps = one - epsqs + tmn = 173.16_r8 + tmx = 375.16_r8 + trice = 35.00_r8 + ip = .true. + call gestbl(tmn ,tmx ,trice ,ip ,epsqs , latvap ,latice ,rh2o , & + cpair ,tmelt_in ) + + + +end subroutine micro_mg_init + +!=============================================================================== +!microphysics routine for each timestep goes here... + +subroutine micro_mg_tend ( & + mgncol, nlev, deltatin, & + t, q, & + qcn, qin, & + ncn, nin, & + qrn, qsn, & + nrn, nsn, & + relvar, accre_enhan_i, & + p, pdel, & + cldn, liqcldf, icecldf, qsatfac, & + qcsinksum_rate1ord, & + naai, npccn, & + rndst, nacon, & + tlat, qvlat, & + qctend, qitend, & + nctend, nitend, & + qrtend, qstend, & + nrtend, nstend, & + effc, effc_fn, effi, & + sadice, sadsnow, & + prect, preci, & + nevapr, evapsnow, & + am_evp_st, & + prain, prodsnow, & + cmeout, deffi, & + pgamrad, lamcrad, & + qsout, dsout, & + lflx, iflx, & + rflx, sflx, qrout, & + reff_rain, reff_snow, & + qcsevap, qisevap, qvres, & + cmeitot, vtrmc, vtrmi, & + umr, ums, & + qcsedten, qisedten, & + qrsedten, qssedten, & + pratot, prctot, & + mnuccctot, mnuccttot, msacwitot, & + psacwstot, bergstot, bergtot, & + melttot, homotot, & + qcrestot, prcitot, praitot, & + qirestot, mnuccrtot, pracstot, & + meltsdttot, frzrdttot, mnuccdtot, & + nrout, nsout, & + refl, arefl, areflz, & + frefl, csrfl, acsrfl, & + fcsrfl, rercld, & + ncai, ncal, & + qrout2, qsout2, & + nrout2, nsout2, & + drout2, dsout2, & + freqs, freqr, & + nfice, qcrat, & + prer_evap,xlat,xlon,lprnt) + + ! Constituent properties. + use micro_mg_utils, only: mg_liq_props, & + mg_ice_props, & + mg_rain_props, & + mg_snow_props + + ! Size calculation functions. + use micro_mg_utils, only: size_dist_param_liq, & + size_dist_param_basic, & + avg_diameter + + ! Microphysical processes. + use micro_mg_utils, only: ice_deposition_sublimation, & + sb2001v2_liq_autoconversion, & + sb2001v2_accre_cld_water_rain, & + kk2000_liq_autoconversion, & + ice_autoconversion, & + immersion_freezing, & + contact_freezing, & + snow_self_aggregation, & + accrete_cloud_water_snow, & + secondary_ice_production, & + accrete_rain_snow, & + heterogeneous_rain_freezing, & + accrete_cloud_water_rain, & + self_collection_rain, & + accrete_cloud_ice_snow, & + evaporate_sublimate_precip, & + bergeron_process_snow, & + liu_liq_autoconversion, & + gmao_ice_autoconversion + + !Authors: Hugh Morrison, Andrew Gettelman, NCAR, Peter Caldwell, LLNL + ! e-mail: morrison@ucar.edu, andrew@ucar.edu + + ! input arguments + integer, intent(in) :: mgncol ! number of microphysics columns + integer, intent(in) :: nlev ! number of layers + real(r8), intent(in) :: xlat,xlon ! number of layers + real(r8), intent(in) :: deltatin ! time step (s) + real(r8), intent(in) :: t(mgncol,nlev) ! input temperature (K) + real(r8), intent(in) :: q(mgncol,nlev) ! input h20 vapor mixing ratio (kg/kg) + + ! note: all input cloud variables are grid-averaged + real(r8), intent(in) :: qcn(mgncol,nlev) ! cloud water mixing ratio (kg/kg) + real(r8), intent(in) :: qin(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) + real(r8), intent(in) :: ncn(mgncol,nlev) ! cloud water number conc (1/kg) + real(r8), intent(in) :: nin(mgncol,nlev) ! cloud ice number conc (1/kg) + + real(r8), intent(in) :: qrn(mgncol,nlev) ! rain mixing ratio (kg/kg) + real(r8), intent(in) :: qsn(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8), intent(in) :: nrn(mgncol,nlev) ! rain number conc (1/kg) + real(r8), intent(in) :: nsn(mgncol,nlev) ! snow number conc (1/kg) + + real(r8) :: relvar(mgncol,nlev) ! cloud water relative variance (-) + real(r8) :: accre_enhan(mgncol,nlev)! optional accretion +! real(r8), intent(in) :: relvar_i ! cloud water relative variance (-) + real(r8), intent(in) :: accre_enhan_i ! optional accretion + ! enhancement factor (-) + + real(r8), intent(in) :: p(mgncol,nlev) ! air pressure (pa) + real(r8), intent(in) :: pdel(mgncol,nlev) ! pressure difference across level (pa) + + real(r8), intent(in) :: cldn(mgncol,nlev) ! cloud fraction (no units) + real(r8), intent(in) :: liqcldf(mgncol,nlev) ! liquid cloud fraction (no units) + real(r8), intent(in) :: icecldf(mgncol,nlev) ! ice cloud fraction (no units) + real(r8), intent(in) :: qsatfac(mgncol,nlev) ! subgrid cloud water saturation scaling factor (no units) + logical, intent(in) :: lprnt + + + ! used for scavenging + ! Inputs for aerosol activation + real(r8), intent(inout) :: naai(mgncol,nlev) ! ice nucleation number (from microp_aero_ts) (1/kg) + real(r8), intent(in) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) + + ! Note that for these variables, the dust bin is assumed to be the last index. + ! (For example, in CAM, the last dimension is always size 4.) + real(r8), intent(in) :: rndst(mgncol,nlev,10) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) + real(r8), intent(in) :: nacon(mgncol,nlev,10) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) + + ! output arguments + + real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) ! 1st order rate for + ! direct cw to precip conversion + real(r8), intent(out) :: tlat(mgncol,nlev) ! latent heating rate (W/kg) + real(r8), intent(out) :: qvlat(mgncol,nlev) ! microphysical tendency qv (1/s) + real(r8), intent(out) :: qctend(mgncol,nlev) ! microphysical tendency qc (1/s) + real(r8), intent(out) :: qitend(mgncol,nlev) ! microphysical tendency qi (1/s) + real(r8), intent(out) :: nctend(mgncol,nlev) ! microphysical tendency nc (1/(kg*s)) + real(r8), intent(out) :: nitend(mgncol,nlev) ! microphysical tendency ni (1/(kg*s)) + + real(r8), intent(out) :: qrtend(mgncol,nlev) ! microphysical tendency qr (1/s) + real(r8), intent(out) :: qstend(mgncol,nlev) ! microphysical tendency qs (1/s) + real(r8), intent(out) :: nrtend(mgncol,nlev) ! microphysical tendency nr (1/(kg*s)) + real(r8), intent(out) :: nstend(mgncol,nlev) ! microphysical tendency ns (1/(kg*s)) + real(r8), intent(out) :: effc(mgncol,nlev) ! droplet effective radius (micron) + real(r8), intent(out) :: effc_fn(mgncol,nlev) ! droplet effective radius, assuming nc = 1.e8 kg-1 + real(r8), intent(out) :: effi(mgncol,nlev) ! cloud ice effective radius (micron) + real(r8), intent(out) :: sadice(mgncol,nlev) ! cloud ice surface area density (cm2/cm3) + real(r8), intent(out) :: sadsnow(mgncol,nlev) ! cloud snow surface area density (cm2/cm3) + real(r8), intent(out) :: prect(mgncol) ! surface precip rate (m/s) + real(r8), intent(out) :: preci(mgncol) ! cloud ice/snow precip rate (m/s) + real(r8), intent(out) :: nevapr(mgncol,nlev) ! evaporation rate of rain + snow (1/s) + real(r8), intent(out) :: evapsnow(mgncol,nlev) ! sublimation rate of snow (1/s) + real(r8), intent(out) :: am_evp_st(mgncol,nlev) ! stratiform evaporation area (frac) + real(r8), intent(out) :: prain(mgncol,nlev) ! production of rain + snow (1/s) + real(r8), intent(out) :: prodsnow(mgncol,nlev) ! production of snow (1/s) + real(r8), intent(out) :: cmeout(mgncol,nlev) ! evap/sub of cloud (1/s) + real(r8), intent(out) :: deffi(mgncol,nlev) ! ice effective diameter for optics (radiation) (micron) + real(r8), intent(out) :: pgamrad(mgncol,nlev) ! ice gamma parameter for optics (radiation) (no units) + real(r8), intent(out) :: lamcrad(mgncol,nlev) ! slope of droplet distribution for optics (radiation) (1/m) + real(r8), intent(out) :: qsout(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8), intent(out) :: dsout(mgncol,nlev) ! snow diameter (m) + real(r8), intent(out) :: lflx(mgncol,nlev+1) ! grid-box average liquid condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: iflx(mgncol,nlev+1) ! grid-box average ice condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: rflx(mgncol,nlev+1) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), intent(out) :: sflx(mgncol,nlev+1) ! grid-box average snow flux (kg m^-2 s^-1) + real(r8), intent(out) :: qrout(mgncol,nlev) ! grid-box average rain mixing ratio (kg/kg) + real(r8), intent(out) :: reff_rain(mgncol,nlev) ! rain effective radius (micron) + real(r8), intent(out) :: reff_snow(mgncol,nlev) ! snow effective radius (micron) + real(r8), intent(out) :: qcsevap(mgncol,nlev) ! cloud water evaporation due to sedimentation (1/s) + real(r8), intent(out) :: qisevap(mgncol,nlev) ! cloud ice sublimation due to sublimation (1/s) + real(r8), intent(out) :: qvres(mgncol,nlev) ! residual condensation term to ensure RH < 100% (1/s) + real(r8), intent(out) :: cmeitot(mgncol,nlev) ! grid-mean cloud ice sub/dep (1/s) + real(r8), intent(out) :: vtrmc(mgncol,nlev) ! mass-weighted cloud water fallspeed (m/s) + real(r8), intent(out) :: vtrmi(mgncol,nlev) ! mass-weighted cloud ice fallspeed (m/s) + real(r8), intent(out) :: umr(mgncol,nlev) ! mass weighted rain fallspeed (m/s) + real(r8), intent(out) :: ums(mgncol,nlev) ! mass weighted snow fallspeed (m/s) + real(r8), intent(out) :: qcsedten(mgncol,nlev) ! qc sedimentation tendency (1/s) + real(r8), intent(out) :: qisedten(mgncol,nlev) ! qi sedimentation tendency (1/s) + real(r8), intent(out) :: qrsedten(mgncol,nlev) ! qr sedimentation tendency (1/s) + real(r8), intent(out) :: qssedten(mgncol,nlev) ! qs sedimentation tendency (1/s) + + ! microphysical process rates for output (mixing ratio tendencies) (all have units of 1/s) + real(r8), intent(out) :: pratot(mgncol,nlev) ! accretion of cloud by rain + real(r8), intent(out) :: prctot(mgncol,nlev) ! autoconversion of cloud to rain + real(r8), intent(out) :: mnuccctot(mgncol,nlev) ! mixing ratio tend due to immersion freezing + real(r8), intent(out) :: mnuccttot(mgncol,nlev) ! mixing ratio tend due to contact freezing + real(r8), intent(out) :: msacwitot(mgncol,nlev) ! mixing ratio tend due to H-M splintering + real(r8), intent(out) :: psacwstot(mgncol,nlev) ! collection of cloud water by snow + real(r8), intent(out) :: bergstot(mgncol,nlev) ! bergeron process on snow + real(r8), intent(out) :: bergtot(mgncol,nlev) ! bergeron process on cloud ice + real(r8), intent(out) :: melttot(mgncol,nlev) ! melting of cloud ice + real(r8), intent(out) :: homotot(mgncol,nlev) ! homogeneous freezing cloud water + real(r8), intent(out) :: qcrestot(mgncol,nlev) ! residual cloud condensation due to removal of excess supersat + real(r8), intent(out) :: prcitot(mgncol,nlev) ! autoconversion of cloud ice to snow + real(r8), intent(out) :: praitot(mgncol,nlev) ! accretion of cloud ice by snow + real(r8), intent(out) :: qirestot(mgncol,nlev) ! residual ice deposition due to removal of excess supersat + real(r8), intent(out) :: mnuccrtot(mgncol,nlev) ! mixing ratio tendency due to heterogeneous freezing of rain to snow (1/s) + real(r8), intent(out) :: pracstot(mgncol,nlev) ! mixing ratio tendency due to accretion of rain by snow (1/s) + real(r8), intent(out) :: meltsdttot(mgncol,nlev)! latent heating rate due to melting of snow (W/kg) + real(r8), intent(out) :: frzrdttot(mgncol,nlev) ! latent heating rate due to homogeneous freezing of rain (W/kg) + real(r8), intent(out) :: mnuccdtot(mgncol,nlev) ! mass tendency from ice nucleation + real(r8), intent(out) :: nrout(mgncol,nlev) ! rain number concentration (1/m3) + real(r8), intent(out) :: nsout(mgncol,nlev) ! snow number concentration (1/m3) + real(r8), intent(out) :: refl(mgncol,nlev) ! analytic radar reflectivity + real(r8), intent(out) :: arefl(mgncol,nlev) ! average reflectivity will zero points outside valid range + real(r8), intent(out) :: areflz(mgncol,nlev) ! average reflectivity in z. + real(r8), intent(out) :: frefl(mgncol,nlev) ! fractional occurrence of radar reflectivity + real(r8), intent(out) :: csrfl(mgncol,nlev) ! cloudsat reflectivity + real(r8), intent(out) :: acsrfl(mgncol,nlev) ! cloudsat average + real(r8), intent(out) :: fcsrfl(mgncol,nlev) ! cloudsat fractional occurrence of radar reflectivity + real(r8), intent(out) :: rercld(mgncol,nlev) ! effective radius calculation for rain + cloud + real(r8), intent(out) :: ncai(mgncol,nlev) ! output number conc of ice nuclei available (1/m3) + real(r8), intent(out) :: ncal(mgncol,nlev) ! output number conc of CCN (1/m3) + real(r8), intent(out) :: qrout2(mgncol,nlev) ! copy of qrout as used to compute drout2 + real(r8), intent(out) :: qsout2(mgncol,nlev) ! copy of qsout as used to compute dsout2 + real(r8), intent(out) :: nrout2(mgncol,nlev) ! copy of nrout as used to compute drout2 + real(r8), intent(out) :: nsout2(mgncol,nlev) ! copy of nsout as used to compute dsout2 + real(r8), intent(out) :: drout2(mgncol,nlev) ! mean rain particle diameter (m) + real(r8), intent(out) :: dsout2(mgncol,nlev) ! mean snow particle diameter (m) + real(r8), intent(out) :: freqs(mgncol,nlev) ! fractional occurrence of snow + real(r8), intent(out) :: freqr(mgncol,nlev) ! fractional occurrence of rain + real(r8), intent(out) :: nfice(mgncol,nlev) ! fractional occurrence of ice + real(r8), intent(out) :: qcrat(mgncol,nlev) ! limiter for qc process rates (1=no limit --> 0. no qc) + + real(r8), intent(out) :: prer_evap(mgncol,nlev) + + + ! Tendencies calculated by external schemes that can replace MG's native + ! process tendencies. + + ! Used with CARMA cirrus microphysics + ! (or similar external microphysics model) + ! real(r8), intent(in) :: tnd_qsnow(:,:) ! snow mass tendency (kg/kg/s) + ! real(r8), intent(in) :: tnd_nsnow(:,:) ! snow number tendency (#/kg/s) + ! real(r8), intent(in) :: re_ice(:,:) ! ice effective radius (m) + + ! From external ice nucleation. + !real(r8), intent(in) :: frzimm(:,:) ! Number tendency due to immersion freezing (1/cm3) + !real(r8), intent(in) :: frzcnt(:,:) ! Number tendency due to contact freezing (1/cm3) + !real(r8), intent(in) :: frzdep(:,:) ! Number tendency due to deposition nucleation (1/cm3) + + ! local workspace + ! all units mks unless otherwise stated + + ! local copies of input variables + real(r8) :: qc(mgncol,nlev) ! cloud liquid mixing ratio (kg/kg) + real(r8) :: qi(mgncol,nlev) ! cloud ice mixing ratio (kg/kg) + real(r8) :: nc(mgncol,nlev) ! cloud liquid number concentration (1/kg) + real(r8) :: ni(mgncol,nlev) ! cloud liquid number concentration (1/kg) + real(r8) :: qr(mgncol,nlev) ! rain mixing ratio (kg/kg) + real(r8) :: qs(mgncol,nlev) ! snow mixing ratio (kg/kg) + real(r8) :: nr(mgncol,nlev) ! rain number concentration (1/kg) + real(r8) :: ns(mgncol,nlev) ! snow number concentration (1/kg) + + ! general purpose variables + real(r8) :: deltat ! sub-time step (s) + real(r8) :: oneodt ! one / deltat + real(r8) :: mtime ! the assumed ice nucleation timescale + + ! physical properties of the air at a given point + real(r8) :: rho(mgncol,nlev) ! density (kg m-3) + real(r8) :: rhoinv(mgncol,nlev) ! one / density (kg m-3) + real(r8) :: dv(mgncol,nlev) ! diffusivity of water vapor + real(r8) :: mu(mgncol,nlev) ! viscosity + real(r8) :: sc(mgncol,nlev) ! schmidt number + real(r8) :: rhof(mgncol,nlev) ! density correction factor for fallspeed + + ! cloud fractions + real(r8) :: precip_frac(mgncol,nlev)! precip fraction assuming maximum overlap + real(r8) :: cldm(mgncol,nlev) ! cloud fraction + real(r8) :: icldm(mgncol,nlev) ! ice cloud fraction + real(r8) :: lcldm(mgncol,nlev) ! liq cloud fraction + real(r8) :: qsfm(mgncol,nlev) ! subgrid cloud water saturation scaling factor + + ! mass mixing ratios + real(r8) :: qcic(mgncol,nlev) ! in-cloud cloud liquid + real(r8) :: qiic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: qsic(mgncol,nlev) ! in-precip snow + real(r8) :: qric(mgncol,nlev) ! in-precip rain + + ! number concentrations + real(r8) :: ncic(mgncol,nlev) ! in-cloud droplet + real(r8) :: niic(mgncol,nlev) ! in-cloud cloud ice + real(r8) :: nsic(mgncol,nlev) ! in-precip snow + real(r8) :: nric(mgncol,nlev) ! in-precip rain + ! maximum allowed ni value + real(r8) :: nimax(mgncol,nlev) + + ! Size distribution parameters for: + ! cloud ice + real(r8) :: lami(mgncol,nlev) ! slope + real(r8) :: n0i(mgncol,nlev) ! intercept + ! cloud liquid + real(r8) :: lamc(mgncol,nlev) ! slope + real(r8) :: pgam(mgncol,nlev) ! spectral width parameter + ! snow + real(r8) :: lams(mgncol,nlev) ! slope + real(r8) :: n0s(mgncol,nlev) ! intercept + ! rain + real(r8) :: lamr(mgncol,nlev) ! slope + real(r8) :: n0r(mgncol,nlev) ! intercept + + ! Rates/tendencies due to: + + ! Instantaneous snow melting + real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstsm(mgncol,nlev) ! number concentration + ! Instantaneous rain freezing + real(r8) :: minstrf(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstrf(mgncol,nlev) ! number concentration + + ! deposition of cloud ice + real(r8) :: vap_dep(mgncol,nlev) ! deposition from vapor to ice PMC 12/3/12 + ! sublimation of cloud ice + real(r8) :: ice_sublim(mgncol,nlev) ! sublimation from ice to vapor PMC 12/3/12 + ! ice nucleation + real(r8) :: nnuccd(mgncol,nlev) ! number rate from deposition/cond.-freezing + real(r8) :: mnuccd(mgncol,nlev) ! mass mixing ratio + ! freezing of cloud water + real(r8) :: mnuccc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccc(mgncol,nlev) ! number concentration + ! contact freezing of cloud water + real(r8) :: mnucct(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnucct(mgncol,nlev) ! number concentration + ! deposition nucleation in mixed-phase clouds (from external scheme) + real(r8) :: mnudep(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnudep(mgncol,nlev) ! number concentration + ! ice multiplication + real(r8) :: msacwi(mgncol,nlev) ! mass mixing ratio + real(r8) :: nsacwi(mgncol,nlev) ! number concentration + ! autoconversion of cloud droplets + real(r8) :: prc(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprc(mgncol,nlev) ! number concentration (rain) + real(r8) :: nprc1(mgncol,nlev) ! number concentration (cloud droplets) + ! self-aggregation of snow + real(r8) :: nsagg(mgncol,nlev) ! number concentration + ! self-collection of rain + real(r8) :: nragg(mgncol,nlev) ! number concentration + ! collection of droplets by snow + real(r8) :: psacws(mgncol,nlev) ! mass mixing ratio + real(r8) :: npsacws(mgncol,nlev) ! number concentration + ! collection of rain by snow + real(r8) :: pracs(mgncol,nlev) ! mass mixing ratio + real(r8) :: npracs(mgncol,nlev) ! number concentration + ! freezing of rain + real(r8) :: mnuccr(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccr(mgncol,nlev) ! number concentration + ! freezing of rain to form ice (mg add 4/26/13) + real(r8) :: mnuccri(mgncol,nlev) ! mass mixing ratio + real(r8) :: nnuccri(mgncol,nlev) ! number concentration + ! accretion of droplets by rain + real(r8) :: pra(mgncol,nlev) ! mass mixing ratio + real(r8) :: npra(mgncol,nlev) ! number concentration + ! autoconversion of cloud ice to snow + real(r8) :: prci(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprci(mgncol,nlev) ! number concentration + ! accretion of cloud ice by snow + real(r8) :: prai(mgncol,nlev) ! mass mixing ratio + real(r8) :: nprai(mgncol,nlev) ! number concentration + ! evaporation of rain + real(r8) :: pre(mgncol,nlev) ! mass mixing ratio + ! sublimation of snow + real(r8) :: prds(mgncol,nlev) ! mass mixing ratio + ! number evaporation + real(r8) :: nsubi(mgncol,nlev) ! cloud ice + real(r8) :: nsubc(mgncol,nlev) ! droplet + real(r8) :: nsubs(mgncol,nlev) ! snow + real(r8) :: nsubr(mgncol,nlev) ! rain + ! bergeron process + real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) + real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) + + + ! fallspeeds + ! number-weighted + real(r8) :: uns(mgncol,nlev) ! snow + real(r8) :: unr(mgncol,nlev) ! rain + ! air density corrected fallspeed parameters + real(r8) :: arn(mgncol,nlev) ! rain + real(r8) :: asn(mgncol,nlev) ! snow + real(r8) :: acn(mgncol,nlev) ! cloud droplet + real(r8) :: ain(mgncol,nlev) ! cloud ice + real(r8) :: ajn(mgncol,nlev) ! cloud small ice + + ! Mass of liquid droplets used with external heterogeneous freezing. + real(r8) :: mi0l(mgncol) + + ! saturation vapor pressures + real(r8) :: esl(mgncol,nlev) ! liquid + real(r8) :: esi(mgncol,nlev) ! ice + real(r8) :: esn ! checking for RH after rain evap + + ! saturation vapor mixing ratios + real(r8) :: qvl(mgncol,nlev) ! liquid + real(r8) :: qvi(mgncol,nlev) ! ice + real(r8) :: qvn ! checking for RH after rain evap + + ! relative humidity + real(r8) :: relhum(mgncol,nlev) + + ! parameters for cloud water and cloud ice sedimentation calculations + real(r8) :: fc(mgncol,nlev) + real(r8) :: fnc(mgncol,nlev) + real(r8) :: fi(mgncol,nlev) + real(r8) :: fni(mgncol,nlev) + + real(r8) :: fr(mgncol,nlev) + real(r8) :: fnr(mgncol,nlev) + real(r8) :: fs(mgncol,nlev) + real(r8) :: fns(mgncol,nlev) + + real(r8) :: faloutc(nlev) + real(r8) :: faloutnc(nlev) + real(r8) :: falouti(nlev) + real(r8) :: faloutni(nlev) + + real(r8) :: faloutr(nlev) + real(r8) :: faloutnr(nlev) + real(r8) :: falouts(nlev) + real(r8) :: faloutns(nlev) + + real(r8) :: faltndc + real(r8) :: faltndnc + real(r8) :: faltndi + real(r8) :: faltndni + real(r8) :: faltndqie + real(r8) :: faltndqce + + real(r8) :: faltndr + real(r8) :: faltndnr + real(r8) :: faltnds + real(r8) :: faltndns + + real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation + + ! dummy variables + real(r8) :: dum + real(r8) :: dum1 + real(r8) :: dum2 + real(r8) :: dumni0 + real(r8) :: dumns0 + real(r8) :: tx1, tx2, tx3, tx4, tx5, tx6, tx7 + ! dummies for checking RH + real(r8) :: qtmp + real(r8) :: ttmp + ! dummies for conservation check + real(r8) :: ratio + real(r8) :: tmpfrz + ! dummies for in-cloud variables + real(r8) :: dumc(mgncol,nlev) ! qc + real(r8) :: dumnc(mgncol,nlev) ! nc + real(r8) :: dumi(mgncol,nlev) ! qi + real(r8) :: dumni(mgncol,nlev) ! ni + real(r8) :: dumr(mgncol,nlev) ! rain mixing ratio + real(r8) :: dumnr(mgncol,nlev) ! rain number concentration + real(r8) :: dums(mgncol,nlev) ! snow mixing ratio + real(r8) :: dumns(mgncol,nlev) ! snow number concentration + ! Array dummy variable + !real(r8) :: dum_2D(mgncol,nlev) + real(r8) :: pdel_inv(mgncol,nlev) + + ! loop array variables + ! "i" and "k" are column/level iterators for internal (MG) variables + ! "n" is used for other looping (currently just sedimentation) + integer i, k, n + + ! number of sub-steps for loops over "n" (for sedimentation) + integer nstep, mdust, nlb + + ! Varaibles to scale fall velocity between small and regular ice regimes. + real(r8) :: irad, ifrac + logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. +! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.true. + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + ! Process inputs + + ! assign variable deltat to deltatin + deltat = deltatin + oneodt = one / deltat + nlb = nlev/3 + + ! Copies of input concentrations that may be changed internally. + do k=1,nlev + do i=1,mgncol + qc(i,k) = qcn(i,k) + nc(i,k) = ncn(i,k) + qi(i,k) = qin(i,k) + ni(i,k) = nin(i,k) + qr(i,k) = qrn(i,k) + nr(i,k) = nrn(i,k) + qs(i,k) = qsn(i,k) + ns(i,k) = nsn(i,k) + enddo + enddo + + ! cldn: used to set cldm, unused for subcolumns + ! liqcldf: used to set lcldm, unused for subcolumns + ! icecldf: used to set icldm, unused for subcolumns + + if (microp_uniform) then + ! subcolumns, set cloud fraction variables to one + ! if cloud water or ice is present, if not present + ! set to mincld (mincld used instead of zero, to prevent + ! possible division by zero errors). + + do k=1,nlev + do i=1,mgncol + + if (qc(i,k) >= qsmall) then + lcldm(i,k) = one + else + lcldm(i,k) = mincld + endif + + if (qi(i,k) >= qsmall) then + icldm(i,k) = one + else + icldm(i,k) = mincld + endif + + cldm(i,k) = max(icldm(i,k), lcldm(i,k)) +! qsfm(i,k) = one + qsfm(i,k) = qsatfac(i,k) + enddo + enddo + + else ! get cloud fraction, check for minimum + do k=1,nlev + do i=1,mgncol + cldm(i,k) = max(cldn(i,k), mincld) + lcldm(i,k) = max(liqcldf(i,k), mincld) + icldm(i,k) = max(icecldf(i,k), mincld) + qsfm(i,k) = qsatfac(i,k) + enddo + enddo + end if +! if (lprnt) write(0,*)' cldm=',cldm(1,nlev-20:nlev) +! if (lprnt) write(0,*)' liqcldf=',liqcldf(1,nlev-20:nlev) +! if (lprnt) write(0,*)' lcldm=',lcldm(1,nlev-20:nlev) +! if (lprnt) write(0,*)' icecldf=',icecldf(1,nlev-20:nlev) +! if (lprnt) write(0,*)' icldm=',icldm(1,nlev-20:nlev) +! if (lprnt) write(0,*)' qsfm=',qsfm(1,nlev-20:nlev) + + ! Initialize local variables + + ! local physical properties + do k=1,nlev + do i=1,mgncol +! rho(i,k) = p(i,k) / (r*t(i,k)*(one+fv*q(i,k))) + rho(i,k) = p(i,k) / (r*t(i,k)) + rhoinv(i,k) = one / rho(i,k) + dv(i,k) = 8.794E-5_r8 * t(i,k)**1.81_r8 / p(i,k) + mu(i,k) = 1.496E-6_r8 * t(i,k)*sqrt(t(i,k)) / (t(i,k) + 120._r8) + sc(i,k) = mu(i,k) / (rho(i,k)*dv(i,k)) + + ! air density adjustment for fallspeed parameters + ! includes air density correction factor to the + ! power of 0.54 following Heymsfield and Bansemer 2007 + + rhof(i,k) = (rhosu*rhoinv(i,k))**0.54_r8 + + arn(i,k) = ar*rhof(i,k) + asn(i,k) = as*rhof(i,k) + acn(i,k) = g*rhow/(18._r8*mu(i,k)) + tx1 = (rhosu*rhoinv(i,k))**0.35_r8 + ain(i,k) = ai*tx1 + ajn(i,k) = aj*tx1 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Get humidity and saturation vapor pressures + +! do k=1,nlev +! do i=1,mgncol +! relvar(i,k) = relvar_i + accre_enhan(i,k) = accre_enhan_i +! call qsat_water(t(i,k), p(i,k), esl(i,k), qvl(i,k)) + esl(i,k) = min(fpvsl(t(i,k)), p(i,k)) + qvl(i,k) = epsqs*esl(i,k) / (p(i,k)-omeps*esl(i,k)) + + + ! make sure when above freezing that esi=esl, not active yet + if (t(i,k) >= tmelt) then + esi(i,k) = esl(i,k) + qvi(i,k) = qvl(i,k) + else +! call qsat_ice(t(i,k), p(i,k), esi(i,k), qvi(i,k)) + esi(i,k) = min(fpvsi(t(i,k)), p(i,k)) + qvi(i,k) = epsqs*esi(i,k) / (p(i,k)-omeps*esi(i,k)) + end if + + ! Scale the water saturation values to reflect subgrid scale + ! ice cloud fraction, where ice clouds begin forming at a + ! gridbox average relative humidity of rhmini (not 1). + ! + ! NOTE: For subcolumns and other non-subgrid clouds, qsfm will be 1. + qvi(i,k) = qsfm(i,k) * qvi(i,k) +! esi(i,k) = qsfm(i,k) * esi(i,k) + qvl(i,k) = qsfm(i,k) * qvl(i,k) +! esl(i,k) = qsfm(i,k) * esl(i,k) + + relhum(i,k) = max(zero, min(q(i,k)/max(qvl(i,k), qsmall), two)) + end do + end do + + + !=============================================== + + ! set mtime here to avoid answer-changing + mtime = deltat + + ! initialize microphysics output + do k=1,nlev + do i=1,mgncol + qcsevap(i,k) = zero + qisevap(i,k) = zero + qvres(i,k) = zero + cmeitot(i,k) = zero + vtrmc(i,k) = zero + vtrmi(i,k) = zero + qcsedten(i,k) = zero + qisedten(i,k) = zero + qrsedten(i,k) = zero + qssedten(i,k) = zero + + pratot(i,k) = zero + prctot(i,k) = zero + mnuccctot(i,k) = zero + mnuccttot(i,k) = zero + msacwitot(i,k) = zero + psacwstot(i,k) = zero + bergstot(i,k) = zero + bergtot(i,k) = zero + melttot(i,k) = zero + homotot(i,k) = zero + qcrestot(i,k) = zero + prcitot(i,k) = zero + praitot(i,k) = zero + qirestot(i,k) = zero + mnuccrtot(i,k) = zero + pracstot(i,k) = zero + meltsdttot(i,k) = zero + frzrdttot(i,k) = zero + mnuccdtot(i,k) = zero + + rflx(i,k) = zero + sflx(i,k) = zero + lflx(i,k) = zero + iflx(i,k) = zero + + ! initialize precip output + + qrout(i,k) = zero + qsout(i,k) = zero + nrout(i,k) = zero + nsout(i,k) = zero + + ! for refl calc + rainrt(i,k) = zero + + ! initialize rain size + rercld(i,k) = zero + + qcsinksum_rate1ord(i,k) = zero + + ! initialize variables for trop_mozart + nevapr(i,k) = zero + prer_evap(i,k) = zero + evapsnow(i,k) = zero + am_evp_st(i,k) = zero + prain(i,k) = zero + prodsnow(i,k) = zero + cmeout(i,k) = zero + + precip_frac(i,k) = mincld + + lamc(i,k) = zero + + ! initialize microphysical tendencies + + tlat(i,k) = zero + qvlat(i,k) = zero + qctend(i,k) = zero + qitend(i,k) = zero + qstend(i,k) = zero + qrtend(i,k) = zero + nctend(i,k) = zero + nitend(i,k) = zero + nrtend(i,k) = zero + nstend(i,k) = zero + + ! initialize in-cloud and in-precip quantities to zero + qcic(i,k) = zero + qiic(i,k) = zero + qsic(i,k) = zero + qric(i,k) = zero + + ncic(i,k) = zero + niic(i,k) = zero + nsic(i,k) = zero + nric(i,k) = zero + + ! initialize precip fallspeeds to zero + ums(i,k) = zero + uns(i,k) = zero + umr(i,k) = zero + unr(i,k) = zero + + ! initialize limiter for output + qcrat(i,k) = one + + ! Many outputs have to be initialized here at the top to work around + ! ifort problems, even if they are always overwritten later. + effc(i,k) = ten + lamcrad(i,k) = zero + pgamrad(i,k) = zero + effc_fn(i,k) = ten + effi(i,k) = 25._r8 + sadice(i,k) = zero + sadsnow(i,k) = zero + deffi(i,k) = 50._r8 + + qrout2(i,k) = zero + nrout2(i,k) = zero + drout2(i,k) = zero + qsout2(i,k) = zero + nsout2(i,k) = zero + dsout(i,k) = zero + dsout2(i,k) = zero + + freqr(i,k) = zero + freqs(i,k) = zero + + reff_rain(i,k) = zero + reff_snow(i,k) = zero + + refl(i,k) = -9999._r8 + arefl(i,k) = zero + areflz(i,k) = zero + frefl(i,k) = zero + csrfl(i,k) = zero + acsrfl(i,k) = zero + fcsrfl(i,k) = zero + + ncal(i,k) = zero + ncai(i,k) = zero + + nfice(i,k) = zero + enddo + enddo + ! initialize precip at surface + + do i=1,mgncol + prect(i) = zero + preci(i) = zero + enddo + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! droplet activation + ! get provisional droplet number after activation. This is used for + ! all microphysical process calculations, for consistency with update of + ! droplet mass before microphysics + + ! calculate potential for droplet activation if cloud water is present + ! tendency from activation (npccn) is read in from companion routine + + ! output activated liquid and ice (convert from #/kg -> #/m3) + !-------------------------------------------------- + where (qc >= qsmall .and. lcldm > epsln) + nc = max(nc + npccn*deltat, zero) + ncal = nc*rho/lcldm ! sghan minimum in #/cm3 + elsewhere + ncal = zero + end where + + do k=1,nlev + do i=1,mgncol + if( (t(i,k) < icenuct)) then + ncai(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) * 1000._r8 + ncai(i,k) = min(ncai(i,k), 208.9e3_r8) + naai(i,k) = ncai(i,k) * rhoinv(i,k) + else + naai(i,k) = zero + ncai(i,k) = zero + endif + enddo + enddo + + + !=============================================== + + ! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% + ! + ! NOTE: If using gridbox average values, condensation will not occur until rh=1, + ! so the threshold seems like it should be 1.05 and not rhmini + 0.05. For subgrid + ! clouds (using rhmini and qsfacm), the relhum has already been adjusted, and thus + ! the nucleation threshold should also be 1.05 and not rhmini + 0.05. + + !------------------------------------------------------- + + if (do_cldice) then + where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8 & + .and. icldm > epsln ) + + !if NAAI > 0. then set numice = naai (as before) + !note: this is gridbox averaged + nnuccd = (naai-ni/icldm)/mtime*icldm + nnuccd = max(nnuccd, zero) + nimax = naai*icldm + + !Calc mass of new particles using new crystal mass... + !also this will be multiplied by mtime as nnuccd is... + + mnuccd = nnuccd * mi0 + + elsewhere + nnuccd = zero + nimax = zero + mnuccd = zero + end where + + end if + + + !============================================================================= + do k=1,nlev + + do i=1,mgncol + + ! calculate instantaneous precip processes (melting and homogeneous freezing) + + ! melting of snow at +2 C + + if (t(i,k) > snowmelt) then + if (qs(i,k) > zero) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -xlf/cpp*qs(i,k) + if (t(i,k)+dum < snowmelt) then + dum = (t(i,k)-snowmelt)*cpp/xlf + dum = min(one, max(zero, dum/qs(i,k))) + else + dum = one + end if + + minstsm(i,k) = dum*qs(i,k) + ninstsm(i,k) = dum*ns(i,k) + + dum1 = -xlf * minstsm(i,k) * oneodt + tlat(i,k) = tlat(i,k) + dum1 + meltsdttot(i,k) = meltsdttot(i,k) + dum1 + + qs(i,k) = max(qs(i,k) - minstsm(i,k), zero) + ns(i,k) = max(ns(i,k) - ninstsm(i,k), zero) + qr(i,k) = max(qr(i,k) + minstsm(i,k), zero) + nr(i,k) = max(nr(i,k) + ninstsm(i,k), zero) + end if + end if + + end do + end do +! if (lprnt) write(0,*)' tlat1=',tlat(1,:)*deltat + + do k=1,nlev + do i=1,mgncol + ! freezing of rain at -5 C + + if (t(i,k) < rainfrze) then + + if (qr(i,k) > zero) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = xlf/cpp*qr(i,k) + if (t(i,k)+dum > rainfrze) then + dum = -(t(i,k)-rainfrze)*cpp/xlf + dum = min(one, max(zero, dum/qr(i,k))) + else + dum = one + end if + + minstrf(i,k) = dum*qr(i,k) + ninstrf(i,k) = dum*nr(i,k) + + ! heating tendency + dum1 = xlf * minstrf(i,k) * oneodt + tlat(i,k) = tlat(i,k) + dum1 + frzrdttot(i,k) = frzrdttot(i,k) + dum1 + + qr(i,k) = max(qr(i,k) - minstrf(i,k), zero) + nr(i,k) = max(nr(i,k) - ninstrf(i,k), zero) + qs(i,k) = max(qs(i,k) + minstrf(i,k), zero) + ns(i,k) = max(ns(i,k) + ninstrf(i,k), zero) + + end if + end if + end do + end do + +! if (lprnt) write(0,*)' tlat2=',tlat(1,:)*deltat + do k=1,nlev + do i=1,mgncol + ! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations + !------------------------------------------------------- + ! for microphysical process calculations + ! units are kg/kg for mixing ratio, 1/kg for number conc + + if (qc(i,k) >= qsmall .and. lcldm(i,k) > epsln) then + ! limit in-cloud values to 0.005 kg/kg + dum = one / lcldm(i,k) + qcic(i,k) = min(qc(i,k)*dum, 5.e-3_r8) + ncic(i,k) = max(nc(i,k)*dum, zero) + + ! specify droplet concentration + if (nccons) then + ncic(i,k) = ncnst * rhoinv(i,k) + end if + else + qcic(i,k) = zero + ncic(i,k) = zero + end if + + if (qi(i,k) >= qsmall) then + ! limit in-cloud values to 0.005 kg/kg + dum = one / max(icldm(i,k),epsln) + qiic(i,k) = min(qi(i,k)*dum, 5.e-3_r8) + niic(i,k) = max(ni(i,k)*dum, zero) + + ! switch for specification of cloud ice number + if (nicons) then + niic(i,k) = ninst * rhoinv(i,k) + end if + else + qiic(i,k) = zero + niic(i,k) = zero + end if + + end do + end do + + !======================================================================== + + ! for sub-columns cldm has already been set to 1 if cloud + ! water or ice is present, so precip_frac will be correctly set below + ! and nothing extra needs to be done here + + precip_frac = cldm + + micro_vert_loop: do k=1,nlev + + if (trim(micro_mg_precip_frac_method) == 'in_cloud') then + + if (k /= 1) then + where (qc(:,k) < qsmall .and. qi(:,k) < qsmall) + precip_frac(:,k) = precip_frac(:,k-1) + end where + endif + + else if (trim(micro_mg_precip_frac_method) == 'max_overlap') then + + ! calculate precip fraction based on maximum overlap assumption + + ! if rain or snow mix ratios are smaller than threshold, + ! then leave precip_frac as cloud fraction at current level + if (k /= 1) then + where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall) + precip_frac(:,k) = max(precip_frac(:,k-1),precip_frac(:,k)) + end where + end if + + endif + + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! get size distribution parameters based on in-cloud cloud water + ! these calculations also ensure consistency between number and mixing ratio + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! cloud liquid + !------------------------------------------- + + call size_dist_param_liq(mg_liq_props, qcic(:,k), ncic(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) + + + !======================================================================== + ! autoconversion of cloud liquid water to rain + ! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc + ! minimum qc of 1 x 10^-8 prevents floating point error + + if (.not. do_sb_physics) then + call kk2000_liq_autoconversion(microp_uniform, qcic(:,k), & + ncic(:,k), rho(:,k), relvar(:,k), prc(:,k), nprc(:,k), nprc1(:,k), mgncol) + endif + + ! assign qric based on prognostic qr, using assumed precip fraction + ! note: this could be moved above for consistency with qcic and qiic calculations + do i=1,mgncol + dum = one / max(precip_frac(i,k),epsln) + qric(i,k) = min(qr(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg + nric(i,k) = nr(i,k) * dum + + + ! add autoconversion to precip from above to get provisional rain mixing ratio + ! and number concentration (qric and nric) + + if(qric(i,k) < qsmall) then + qric(i,k) = zero + nric(i,k) = zero + endif + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nric(i,k) = max(nric(i,k),zero) + enddo + ! Get size distribution parameters for cloud ice + + call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & + lami(:,k), mgncol, n0=n0i(:,k)) + + ! Alternative autoconversion + if (do_sb_physics) then + if (do_liq_liu) then + call liu_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & + qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k),mgncol) + else + call sb2001v2_liq_autoconversion(pgam(:,k),qcic(:,k),ncic(:,k), & + qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) + endif + endif + + !....................................................................... + ! Autoconversion of cloud ice to snow + ! similar to Ferrier (1994) + + if (do_cldice) then + if(do_ice_gmao) then + call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), & + lami(:,k), n0i(:,k), dcs,ts_au,prci(:,k), nprci(:,k), mgncol) + else + call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & + dcs, ts_au,prci(:,k), nprci(:,k), mgncol) + end if + !else + ! Add in the particles that we have already converted to snow, and + ! don't do any further autoconversion of ice. + !prci(:,k) = tnd_qsnow(:,k) / cldm(:,k) + !nprci(:,k) = tnd_nsnow(:,k) / cldm(:,k) + end if + + ! note, currently we don't have this + ! inside the do_cldice block, should be changed later + ! assign qsic based on prognostic qs, using assumed precip fraction + do i=1,mgncol + dum = one / max(precip_frac(i,k),epsln) + qsic(i,k) = min(qs(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg + nsic(i,k) = ns(i,k) * dum + + ! if precip mix ratio is zero so should number concentration + + if(qsic(i,k) < qsmall) then + qsic(i,k) = zero + nsic(i,k) = zero + endif + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + nsic(i,k) = max(nsic(i,k), zero) + enddo + + !....................................................................... + ! get size distribution parameters for precip + !...................................................................... + ! rain + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), & + lamr(:,k), mgncol, n0=n0r(:,k)) + + do i=1,mgncol + if (lamr(i,k) >= qsmall) then + dum = arn(i,k) / lamr(i,k)**br + dum1 = 9.1_r8*rhof(i,k) + + ! provisional rain number and mass weighted mean fallspeed (m/s) + + unr(i,k) = min(dum1, dum*gamma_br_plus1) + umr(i,k) = min(dum1, dum*gamma_br_plus4*(one/six)) + else + + umr(i,k) = zero + unr(i,k) = zero + endif + enddo + + !...................................................................... + ! snow + + call size_dist_param_basic(mg_snow_props, qsic(:,k), nsic(:,k), & + lams(:,k), mgncol, n0=n0s(:,k)) + + do i=1,mgncol + if (lams(i,k) > zero) then + + ! provisional snow number and mass weighted mean fallspeed (m/s) + + dum = asn(i,k) / lams(i,k)**bs + dum1 = 1.2_r8*rhof(i,k) + ums(i,k) = min(dum1, dum*gamma_bs_plus4*(one/six)) + uns(i,k) = min(dum1, dum*gamma_bs_plus1) + + else + ums(i,k) = zero + uns(i,k) = zero + endif + enddo + + if (do_cldice) then + if (.not. use_hetfrz_classnuc) then + + ! heterogeneous freezing of cloud water + !---------------------------------------------- + + call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & + qcic(:,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k), mgncol) + + ! make sure number of droplets frozen does not exceed available ice nuclei concentration + ! this prevents 'runaway' droplet freezing + + where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8 .and. lcldm(:,k) > epsln) + where (nnuccc(:,k)*lcldm(:,k) > nnuccd(:,k)) + ! scale mixing ratio of droplet freezing with limit + mnuccc(:,k) = mnuccc(:,k)*(nnuccd(:,k)/(nnuccc(:,k)*lcldm(:,k))) + nnuccc(:,k) = nnuccd(:,k)/lcldm(:,k) + end where + end where + + mdust = size(rndst,3) + call contact_freezing(microp_uniform, t(:,k), p(:,k), rndst(:,k,:), & + nacon(:,k,:), pgam(:,k), lamc(:,k), qcic(:,k), ncic(:,k), & + relvar(:,k), mnucct(:,k), nnucct(:,k), mgncol, mdust) + + mnudep(:,k) = 0._r8 + nnudep(:,k) = 0._r8 + + !else + + ! Mass of droplets frozen is the average droplet mass, except + ! with two limiters: concentration must be at least 1/cm^3, and + ! mass must be at least the minimum defined above. + !mi0l = qcic(:,k)/max(ncic(:,k), 1.0e6_r8/rho(:,k)) + !mi0l = max(mi0l_min, mi0l) + + !where (qcic(:,k) >= qsmall) + !nnuccc(:,k) = frzimm(:,k)*1.0e6_r8/rho(:,k) + !mnuccc(:,k) = nnuccc(:,k)*mi0l + + !nnucct(:,k) = frzcnt(:,k)*1.0e6_r8/rho(:,k) + !mnucct(:,k) = nnucct(:,k)*mi0l + + !nnudep(:,k) = frzdep(:,k)*1.0e6_r8/rho(:,k) + !mnudep(:,k) = nnudep(:,k)*mi0 + !elsewhere + !nnuccc(:,k) = 0._r8 + !mnuccc(:,k) = 0._r8 + + !nnucct(:,k) = 0._r8 + !mnucct(:,k) = 0._r8 + + !nnudep(:,k) = 0._r8 + !mnudep(:,k) = 0._r8 + !end where + + end if + + else + do i=1,mgncol + mnuccc(i,k) = zero + nnuccc(i,k) = zero + mnucct(i,k) = zero + nnucct(i,k) = zero + mnudep(i,k) = zero + nnudep(i,k) = zero + enddo + end if + + call snow_self_aggregation(t(:,k), rho(:,k), asn(:,k), rhosn, qsic(:,k), nsic(:,k), & + nsagg(:,k), mgncol) + + call accrete_cloud_water_snow(t(:,k), rho(:,k), asn(:,k), uns(:,k), mu(:,k), & + qcic(:,k), ncic(:,k), qsic(:,k), pgam(:,k), lamc(:,k), lams(:,k), n0s(:,k), & + psacws(:,k), npsacws(:,k), mgncol) + + if (do_cldice) then + call secondary_ice_production(t(:,k), psacws(:,k), msacwi(:,k), nsacwi(:,k), mgncol) + else + nsacwi(:,k) = 0.0_r8 + msacwi(:,k) = 0.0_r8 + end if + + call accrete_rain_snow(t(:,k), rho(:,k), umr(:,k), ums(:,k), unr(:,k), uns(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pracs(:,k), npracs(:,k), mgncol) + + call heterogeneous_rain_freezing(t(:,k), qric(:,k), nric(:,k), lamr(:,k), & + mnuccr(:,k), nnuccr(:,k), mgncol) + + if (do_sb_physics) then + call sb2001v2_accre_cld_water_rain(qcic(:,k), ncic(:,k), qric(:,k), & + rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) + else + call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(:,k), & + ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(:,k), npra(:,k), mgncol) + endif + + call self_collection_rain(rho(:,k), qric(:,k), nric(:,k), nragg(:,k), mgncol) + + if (do_cldice) then + call accrete_cloud_ice_snow(t(:,k), rho(:,k), asn(:,k), qiic(:,k), niic(:,k), & + qsic(:,k), lams(:,k), n0s(:,k), prai(:,k), nprai(:,k), mgncol) + else + prai(:,k) = 0._r8 + nprai(:,k) = 0._r8 + end if + + call evaporate_sublimate_precip(t(:,k), rho(:,k), & + dv(:,k), mu(:,k), sc(:,k), q(:,k), qvl(:,k), qvi(:,k), & + lcldm(:,k), precip_frac(:,k), arn(:,k), asn(:,k), qcic(:,k), qiic(:,k), & + qric(:,k), qsic(:,k), lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), & + pre(:,k), prds(:,k), am_evp_st(:,k), mgncol) + + call bergeron_process_snow(t(:,k), rho(:,k), dv(:,k), mu(:,k), sc(:,k), & + qvl(:,k), qvi(:,k), asn(:,k), qcic(:,k), qsic(:,k), lams(:,k), n0s(:,k), & + bergs(:,k), mgncol) + + bergs(:,k)=bergs(:,k)*micro_mg_berg_eff_factor + + !+++PMC 12/3/12 - NEW VAPOR DEP/SUBLIMATION GOES HERE!!! + if (do_cldice) then + + call ice_deposition_sublimation(t(:,k), q(:,k), qi(:,k), ni(:,k), & + icldm(:,k), rho(:,k), dv(:,k), qvl(:,k), qvi(:,k), & + berg(:,k), vap_dep(:,k), ice_sublim(:,k), mgncol) + + do i=1,mgncol +! sublimation should not exceed available ice + ice_sublim(i,k) = max(ice_sublim(i,k), -qi(i,k)*oneodt) + end do + + berg(:,k)=berg(:,k)*micro_mg_berg_eff_factor + + where (vap_dep(:,k) < 0._r8 .and. qi(:,k) > qsmall .and. icldm(:,k) > mincld) + nsubi(:,k) = vap_dep(:,k) / qi(:,k) * ni(:,k) / max(icldm(:,k),epsln) + elsewhere + nsubi(:,k) = 0._r8 + end where + + ! bergeron process should not reduce nc unless + ! all ql is removed (which is handled elsewhere) + !in fact, nothing in this entire file makes nsubc nonzero. + nsubc(:,k) = 0._r8 + + end if !do_cldice + !---PMC 12/3/12 + + do i=1,mgncol + + ! conservation to ensure no negative values of cloud water/precipitation + ! in case microphysical process rates are large + !=================================================================== + + ! note: for check on conservation, processes are multiplied by omsm + ! to prevent problems due to round off error + + ! conservation of qc + !------------------------------------------------------------------- + + dum = ((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k)+ & + psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*deltat + + if (dum > qc(i,k)) then + ratio = qc(i,k)*oneodt/((prc(i,k)+pra(i,k)+mnuccc(i,k)+mnucct(i,k)+ & + msacwi(i,k)+psacws(i,k)+bergs(i,k))*lcldm(i,k)+berg(i,k))*omsm + prc(i,k) = ratio * prc(i,k) + pra(i,k) = ratio * pra(i,k) + mnuccc(i,k) = ratio * mnuccc(i,k) + mnucct(i,k) = ratio * mnucct(i,k) + msacwi(i,k) = ratio * msacwi(i,k) + psacws(i,k) = ratio * psacws(i,k) + bergs(i,k) = ratio * bergs(i,k) + berg(i,k) = ratio * berg(i,k) + qcrat(i,k) = ratio + else + qcrat(i,k) = one + end if + + !PMC 12/3/12: ratio is also frac of step w/ liquid. + !thus we apply berg for "ratio" of timestep and vapor + !deposition for the remaining frac of the timestep. + if (qc(i,k) >= qsmall) then + vap_dep(i,k) = vap_dep(i,k)*(1._r8-qcrat(i,k)) + end if + + end do + + do i=1,mgncol + + !================================================================= + ! apply limiter to ensure that ice/snow sublimation and rain evap + ! don't push conditions into supersaturation, and ice deposition/nucleation don't + ! push conditions into sub-saturation + ! note this is done after qc conservation since we don't know how large + ! vap_dep is before then + ! estimates are only approximate since other process terms haven't been limited + ! for conservation yet + + ! first limit ice deposition/nucleation vap_dep + mnuccd + + dum1 = vap_dep(i,k) + mnuccd(i,k) + if (dum1 > 1.e-20_r8) then + dum = (q(i,k)-qvi(i,k))/(one + xxls_squared*qvi(i,k)/(cpp*rv*t(i,k)*t(i,k)))*oneodt + dum = max(dum, zero) + if (dum1 > dum) then + ! Allocate the limited "dum" tendency to mnuccd and vap_dep + ! processes. Don't divide by cloud fraction; these are grid- + ! mean rates. + dum1 = mnuccd(i,k) / (vap_dep(i,k)+mnuccd(i,k)) + mnuccd(i,k) = dum*dum1 + vap_dep(i,k) = dum - mnuccd(i,k) + end if + end if + + end do + + do i=1,mgncol + + !=================================================================== + ! conservation of nc + !------------------------------------------------------------------- + dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & + npsacws(i,k)-nsubc(i,k))*lcldm(i,k) * deltat + + if (dum > nc(i,k)) then + ratio = nc(i,k) / dum * omsm + + nprc1(i,k) = ratio * nprc1(i,k) + npra(i,k) = ratio * npra(i,k) + nnuccc(i,k) = ratio * nnuccc(i,k) + nnucct(i,k) = ratio * nnucct(i,k) + npsacws(i,k) = ratio * npsacws(i,k) + nsubc(i,k) = ratio * nsubc(i,k) + end if + + mnuccri(i,k) = zero + nnuccri(i,k) = zero + + if (do_cldice) then + + ! freezing of rain to produce ice if mean rain size is smaller than Dcs + if (lamr(i,k) > qsmall .and. 1._r8/lamr(i,k) < Dcs) then + mnuccri(i,k) = mnuccr(i,k) + nnuccri(i,k) = nnuccr(i,k) + mnuccr(i,k) = zero + nnuccr(i,k) = zero + end if + end if + + end do + + do i=1,mgncol + + ! conservation of rain mixing ratio + !------------------------------------------------------------------- + dum1 = (-pre(i,k)+pracs(i,k)+mnuccr(i,k)+mnuccri(i,k)) * precip_frac(i,k) + dum2 = (pra(i,k)+prc(i,k))*lcldm(i,k) + dum = (dum1 - dum2) * deltat + + ! note that qrtend is included below because of instantaneous freezing/melt + if (dum > qr(i,k) .and. dum1 >= qsmall) then + ratio = (qr(i,k)*oneodt + dum2) / dum1 * omsm + pre(i,k) = ratio * pre(i,k) + pracs(i,k) = ratio * pracs(i,k) + mnuccr(i,k) = ratio * mnuccr(i,k) + mnuccri(i,k) = ratio * mnuccri(i,k) + end if + + end do + + do i=1,mgncol + + ! conservation of rain number + !------------------------------------------------------------------- + + ! Add evaporation of rain number. + if (pre(i,k) < zero) then + dum = max(-one, pre(i,k)*deltat/qr(i,k)) + nsubr(i,k) = dum*nr(i,k) * oneodt + else + nsubr(i,k) = zero + end if + + end do + + do i=1,mgncol + + dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k) + dum2 = nprc(i,k)*lcldm(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > nr(i,k)) then + ratio = (nr(i,k)*oneodt + dum2) / dum1 * omsm + + nragg(i,k) = ratio * nragg(i,k) + npracs(i,k) = ratio * npracs(i,k) + nnuccr(i,k) = ratio * nnuccr(i,k) + nsubr(i,k) = ratio * nsubr(i,k) + nnuccri(i,k) = ratio * nnuccri(i,k) + end if + + end do + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of qi + !------------------------------------------------------------------- + + dum1 = (prci(i,k)+prai(i,k))*icldm(i,k)-ice_sublim(i,k) + dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & + + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k) & + + mnuccri(i,k)*precip_frac(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > qi(i,k)) then + ratio = (qi(i,k)*oneodt + dum2) / dum1 * omsm + + prci(i,k) = ratio * prci(i,k) + prai(i,k) = ratio * prai(i,k) + ice_sublim(i,k) = ratio * ice_sublim(i,k) + end if + + end do + + end if + + if (do_cldice) then + + do i=1,mgncol + + ! conservation of ni + !------------------------------------------------------------------- + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = zero + end if + dum1 = (nprci(i,k)+nprai(i,k)-nsubi(i,k))*icldm(i,k) + dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k) & + + nnuccri(i,k)*precip_frac(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > ni(i,k)) then + ratio = (ni(i,k)*oneodt + dum2) / dum1 * omsm + + nprci(i,k) = ratio * nprci(i,k) + nprai(i,k) = ratio * nprai(i,k) + nsubi(i,k) = ratio * nsubi(i,k) + end if + + end do + + end if + + do i=1,mgncol + + ! conservation of snow mixing ratio + !------------------------------------------------------------------- + dum1 = - prds(i,k) * precip_frac(i,k) + dum2 = (pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) & + + (prai(i,k)+prci(i,k))*icldm(i,k) + (bergs(i,k)+psacws(i,k))*lcldm(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > qs(i,k) .and. -prds(i,k) >= qsmall) then + ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm + + prds(i,k) = ratio * prds(i,k) + end if + + end do + + do i=1,mgncol + + ! conservation of snow number + !------------------------------------------------------------------- + ! calculate loss of number due to sublimation + ! for now neglect sublimation of ns + nsubs(i,k) = zero + + dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)) + dum2 = nnuccr(i,k)*precip_frac(i,k) + nprci(i,k)*icldm(i,k) + dum = (dum1 - dum2) * deltat + dum = ((-nsagg(i,k)-nsubs(i,k)-nnuccr(i,k))*precip_frac(i,k)-nprci(i,k)*icldm(i,k))*deltat + + if (dum > ns(i,k)) then + ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm + + nsubs(i,k) = ratio * nsubs(i,k) + nsagg(i,k) = ratio * nsagg(i,k) + end if + + end do + + do i=1,mgncol + + ! next limit ice and snow sublimation and rain evaporation + ! get estimate of q and t at end of time step + ! don't include other microphysical processes since they haven't + ! been limited via conservation checks yet + + tx1 = pre(i,k) * precip_frac(i,k) + tx2 = prds(i,k) * precip_frac(i,k) + tx3 = tx1 + tx2 + ice_sublim(i,k) + if (tx3 < -1.e-20_r8) then + + qtmp = q(i,k) - (ice_sublim(i,k)+vap_dep(i,k)+mnuccd(i,k)+tx1+tx2)*deltat + ttmp = t(i,k) + (tx1*xxlv + (tx2+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k))*xxls) & + * (deltat/cpp) + + ! use rhw to allow ice supersaturation + ! call qsat_water(ttmp, p(i,k), esn, qvn) + esn = min(fpvsl(ttmp), p(i,k)) + qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) + + ! modify ice/precip evaporation rate if q > qsat + if (qtmp > qvn) then + + tx4 = one / tx3 + dum1 = tx1 * tx4 + dum2 = tx2 * tx4 + ! recalculate q and t after vap_dep and mnuccd but without evap or sublim + tx5 = (vap_dep(i,k)+mnuccd(i,k)) * deltat + qtmp = q(i,k) - tx5 + ttmp = t(i,k) + tx5 * (xxls/cpp) + + ! use rhw to allow ice supersaturation + !call qsat_water(ttmp, p(i,k), esn, qvn) + esn = min(fpvsl(ttmp), p(i,k)) + qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) + + dum = (qtmp-qvn) / (one + xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) + dum = min(dum, zero) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + tx4 = one / max(precip_frac(i,k),epsln) + pre(i,k) = dum*dum1*oneodt*tx4 + + ! do separately using RHI for prds and ice_sublim + !call qsat_ice(ttmp, p(i,k), esn, qvn) + esn = min(fpvsi(ttmp), p(i,k)) + qvn = epsqs*esn / (p(i,k)-omeps*esn) * qsfm(i,k) + + + dum = (qtmp-qvn) / (one + xxls_squared*qvn/(cpp*rv*ttmp*ttmp)) + dum = min(dum, zero) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + prds(i,k) = dum*dum2*oneodt*tx4 + + ! don't divide ice_sublim by cloud fraction since it is grid-averaged + dum1 = one - dum1 - dum2 + ice_sublim(i,k) = dum*dum1*oneodt + end if + end if + + end do + + ! Big "administration" loop enforces conservation, updates variables + ! that accumulate over substeps, and sets output variables. + + do i=1,mgncol + + ! get tendencies due to microphysical conversion processes + !========================================================== + ! note: tendencies are multiplied by appropriate cloud/precip + ! fraction to get grid-scale values + ! note: vap_dep is already grid-average values + + ! The net tendencies need to be added to rather than overwritten, + ! because they may have a value already set for instantaneous + ! melting/freezing. + + qvlat(i,k) = qvlat(i,k) - (pre(i,k)+prds(i,k))*precip_frac(i,k)-& + vap_dep(i,k)-ice_sublim(i,k)-mnuccd(i,k)-mnudep(i,k)*lcldm(i,k) + + tlat(i,k) = tlat(i,k) + ((pre(i,k)*precip_frac(i,k)) & + *xxlv+(prds(i,k)*precip_frac(i,k)+vap_dep(i,k)+ice_sublim(i,k)+mnuccd(i,k)+mnudep(i,k)*lcldm(i,k))*xxls+ & + ((bergs(i,k)+psacws(i,k)+mnuccc(i,k)+mnucct(i,k)+msacwi(i,k))*lcldm(i,k)+(mnuccr(i,k)+ & + pracs(i,k)+mnuccri(i,k))*precip_frac(i,k)+berg(i,k))*xlf) + + + qctend(i,k) = qctend(i,k) + (-pra(i,k)-prc(i,k)-mnuccc(i,k)-mnucct(i,k)-msacwi(i,k)- & + psacws(i,k)-bergs(i,k))*lcldm(i,k)-berg(i,k) + + if (do_cldice) then + qitend(i,k) = qitend(i,k) + & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k))*lcldm(i,k)+(-prci(i,k)- & + prai(i,k))*icldm(i,k)+vap_dep(i,k)+berg(i,k)+ice_sublim(i,k)+ & + mnuccd(i,k)+mnuccri(i,k)*precip_frac(i,k) + end if + + qrtend(i,k) = qrtend(i,k) + (pra(i,k)+prc(i,k))*lcldm(i,k)+(pre(i,k)-pracs(i,k)- & + mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + + qstend(i,k) = qstend(i,k) + (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k) & + + (prds(i,k)+pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + + cmeout(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! add output for cmei (accumulate) + cmeitot(i,k) = vap_dep(i,k) + ice_sublim(i,k) + mnuccd(i,k) + + ! assign variables for trop_mozart, these are grid-average + !------------------------------------------------------------------- + ! evaporation/sublimation is stored here as positive term + + evapsnow(i,k) = -prds(i,k) * precip_frac(i,k) + nevapr(i,k) = -pre(i,k) * precip_frac(i,k) + prer_evap(i,k) = -pre(i,k) * precip_frac(i,k) + + ! change to make sure prain is positive: do not remove snow from + ! prain used for wet deposition + prain(i,k) = (pra(i,k)+prc(i,k))*lcldm(i,k)+(-pracs(i,k)- & + mnuccr(i,k)-mnuccri(i,k))*precip_frac(i,k) + prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+(& + pracs(i,k)+mnuccr(i,k))*precip_frac(i,k) + + ! following are used to calculate 1st order conversion rate of cloud water + ! to rain and snow (1/s), for later use in aerosol wet removal routine + ! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc + ! used to calculate pra, prc, ... in this routine + ! qcsinksum_rate1ord = { rate of direct transfer of cloud water to rain & snow } + ! (no cloud ice or bergeron terms) + qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) + ! Avoid zero/near-zero division. + qcsinksum_rate1ord(i,k) = qcsinksum_rate1ord(i,k) / max(qc(i,k),1.0e-30_r8) + + + ! microphysics output, note this is grid-averaged + pratot(i,k) = pra(i,k) * lcldm(i,k) + prctot(i,k) = prc(i,k) * lcldm(i,k) + mnuccctot(i,k) = mnuccc(i,k) * lcldm(i,k) + mnuccttot(i,k) = mnucct(i,k) * lcldm(i,k) + msacwitot(i,k) = msacwi(i,k) * lcldm(i,k) + psacwstot(i,k) = psacws(i,k) * lcldm(i,k) + bergstot(i,k) = bergs(i,k) * lcldm(i,k) + bergtot(i,k) = berg(i,k) + prcitot(i,k) = prci(i,k) * icldm(i,k) + praitot(i,k) = prai(i,k) * icldm(i,k) + mnuccdtot(i,k) = mnuccd(i,k) * icldm(i,k) + + pracstot(i,k) = pracs(i,k) * precip_frac(i,k) + mnuccrtot(i,k) = mnuccr(i,k) * precip_frac(i,k) + + + nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & + - npra(i,k)-nprc1(i,k))*lcldm(i,k) + + if (do_cldice) then + if (use_hetfrz_classnuc) then + tmpfrz = nnuccc(i,k) + else + tmpfrz = zero + end if + nitend(i,k) = nitend(i,k) + nnuccd(i,k)+ & + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k))*lcldm(i,k)+(nsubi(i,k)-nprci(i,k)- & + nprai(i,k))*icldm(i,k)+nnuccri(i,k)*precip_frac(i,k) + end if + + nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)+nnuccr(i,k))*precip_frac(i,k) & + + nprci(i,k)*icldm(i,k) + + nrtend(i,k) = nrtend(i,k) + nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & + - nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) + + ! make sure that ni at advanced time step does not exceed + ! maximum (existing N + source terms*dt), which is possible if mtime < deltat + ! note that currently mtime = deltat + !================================================================ + + if (do_cldice .and. nitend(i,k) > zero .and. ni(i,k)+nitend(i,k)*deltat > nimax(i,k)) then + nitend(i,k) = max(zero, (nimax(i,k)-ni(i,k))*oneodt) + end if + + end do + + ! End of "administration" loop + + end do micro_vert_loop ! end k loop + +! if (lprnt) write(0,*)' tlat3=',tlat(1,:)*deltat + !----------------------------------------------------- + ! convert rain/snow q and N for output to history, note, + ! output is for gridbox average + + do k=1,nlev + do i=1,mgncol + qrout(i,k) = qr(i,k) + nrout(i,k) = nr(i,k) * rho(i,k) + qsout(i,k) = qs(i,k) + nsout(i,k) = ns(i,k) * rho(i,k) + enddo + enddo + + ! calculate n0r and lamr from rain mass and number + ! divide by precip fraction to get in-precip (local) values of + ! rain mass and number, divide by rhow to get rain number in kg^-1 + + do k=1,nlev + + call size_dist_param_basic(mg_rain_props, qric(:,k), nric(:,k), lamr(:,k), mgncol, n0=n0r(:,k)) + + enddo + ! Calculate rercld + + ! calculate mean size of combined rain and cloud water + + call calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol, nlev) + + + ! Assign variables back to start-of-timestep values + ! Some state variables are changed before the main microphysics loop + ! to make "instantaneous" adjustments. Afterward, we must move those changes + ! back into the tendencies. + ! These processes: + ! - Droplet activation (npccn, impacts nc) + ! - Instantaneous snow melting (minstsm/ninstsm, impacts qr/qs/nr/ns) + ! - Instantaneous rain freezing (minstfr/ninstrf, impacts qr/qs/nr/ns) + !================================================================================ + + do k=1,nlev + do i=1,mgncol + ! Re-apply droplet activation tendency + nc(i,k) = ncn(i,k) + nctend(i,k) = nctend(i,k) + npccn(i,k) + + ! Re-apply rain freezing and snow melting. + tx1 = qs(i,k) + qs(i,k) = qsn(i,k) + qstend(i,k) = qstend(i,k) + (tx1-qs(i,k)) * oneodt + + tx1 = ns(i,k) + ns(i,k) = nsn(i,k) + nstend(i,k) = nstend(i,k) + (tx1-ns(i,k)) * oneodt + + tx1 = qr(i,k) + qr(i,k) = qrn(i,k) + qrtend(i,k) = qrtend(i,k) + (tx1-qr(i,k)) * oneodt + + tx1 = nr(i,k) + nr(i,k) = nrn(i,k) + nrtend(i,k) = nrtend(i,k) + (tx1-nr(i,k)) * oneodt + + !............................................................................. + + !================================================================================ + + ! modify to include snow. in prain & evap (diagnostic here: for wet dep) + nevapr(i,k) = nevapr(i,k) + evapsnow(i,k) + prain(i,k) = prain(i,k) + prodsnow(i,k) + + + enddo + enddo + + do k=1,nlev + + do i=1,mgncol + + ! calculate sedimentation for cloud water and ice + !================================================================================ + + ! update in-cloud cloud mixing ratio and number concentration + ! with microphysical tendencies to calculate sedimentation, assign to dummy vars + ! note: these are in-cloud values***, hence we divide by cloud fraction + + if (lcldm(i,k) > epsln) then + tx1 = one / lcldm(i,k) + dumc(i,k) = (qc(i,k)+qctend(i,k)*deltat) * tx1 + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)*tx1, zero) + else + dumc(i,k) = zero + dumnc(i,k) = zero + endif + if (icldm(i,k) > epsln) then + tx1 = one / icldm(i,k) + dumi(i,k) = (qi(i,k)+qitend(i,k)*deltat) * tx1 + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)*tx1, zero) + else + dumi(i,k) = zero + dumni(i,k) = zero + endif + if (precip_frac(i,k) > epsln) then + tx1 = one / precip_frac(i,k) + dumr(i,k) = (qr(i,k)+qrtend(i,k)*deltat) * tx1 + dums(i,k) = (qs(i,k)+qstend(i,k)*deltat) * tx1 + + dumnr(i,k) = max((nr(i,k)+nrtend(i,k)*deltat)*tx1, zero) + dumns(i,k) = max((ns(i,k)+nstend(i,k)*deltat)*tx1, zero) + else + dumr(i,k) = zero + dumr(i,k) = zero + dums(i,k) = zero + dumns(i,k) = zero + endif + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k) = ncnst*rhoinv(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k) = ninst*rhoinv(i,k) + end if + enddo + enddo + + do k=1,nlev + + ! obtain new slope parameter to avoid possible singularity + + call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & + lami(:,k), mgncol) + + call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) + + enddo + + do k=1,nlev + do i=1,mgncol + + ! calculate number and mass weighted fall velocity for droplets and cloud ice + !------------------------------------------------------------------- + + + if (dumc(i,k) >= qsmall) then + + tx1 = lamc(i,k)**bc + vtrmc(i,k) = acn(i,k)*gamma(four+bc+pgam(i,k)) & + / (tx1*gamma(pgam(i,k)+four)) + + fc(i,k) = g*rho(i,k)*vtrmc(i,k) + + fnc(i,k) = g*rho(i,k)* acn(i,k)*gamma(one+bc+pgam(i,k)) & + / (tx1*gamma(pgam(i,k)+one)) + else + fc(i,k) = zero + fnc(i,k) = zero + end if + + ! calculate number and mass weighted fall velocity for cloud ice + + if (dumi(i,k) >= qsmall) then + + tx3 = one / lami(i,k) + tx1 = ain(i,k) * tx3**bi + tx2 = 1.2_r8*rhof(i,k) + vtrmi(i,k) = min(tx1*(gamma_bi_plus4/six), tx2) + + tx4 = g*rho(i,k) + fi(i,k) = tx4 * vtrmi(i,k) + fni(i,k) = tx4 * min(tx1*gamma_bi_plus1, tx2) + + ! adjust the ice fall velocity for smaller (r < 20 um) ice + ! particles (blend over 18-20 um) + irad = (1.5_r8 * 1e6_r8) * tx3 + ifrac = min(one, max(zero, (irad-18._r8)*half)) + + if (ifrac < one) then + tx1 = ajn(i,k) / lami(i,k)**bj + vtrmi(i,k) = ifrac*vtrmi(i,k) + (one-ifrac) * min(tx1*(gamma_bj_plus4/six), tx2) + + fi(i,k) = tx4*vtrmi(i,k) + fni(i,k) = ifrac * fni(i,k) + (one-ifrac) * tx4 * min(tx1*gamma_bj_plus1, tx2) + end if + else + fi(i,k) = zero + fni(i,k)= zero + end if + + enddo + + enddo + + do k=1,nlev + + ! fallspeed for rain + + call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & + lamr(:,k), mgncol) + enddo + + do k=1,nlev + + do i=1,mgncol +! if (lamr(i,k) >= qsmall) then + if (dumr(i,k) >= qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for rain (m/s) + + tx1 = arn(i,k) / lamr(i,k)**br + tx2 = 9.1_r8*rhof(i,k) + unr(i,k) = min(tx1*gamma_br_plus1, tx2) + umr(i,k) = min(tx1*gamma_br_plus4/six, tx2) + + fr(i,k) = g*rho(i,k)*umr(i,k) + fnr(i,k) = g*rho(i,k)*unr(i,k) + + else + fr(i,k) = zero + fnr(i,k) = zero + end if + + ! fallspeed for snow + + call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), lams(i,k)) + +! if (lams(i,k) >= qsmall) then + if (dums(i,k) >= qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for snow (m/s) + tx1 = asn(i,k) / lams(i,k)**bs + tx2 = 1.2_r8*rhof(i,k) + ums(i,k) = min(tx1*gamma_bs_plus4/six, tx2) + uns(i,k) = min(tx1*gamma_bs_plus1, tx2) + + fs(i,k) = g*rho(i,k)*ums(i,k) + fns(i,k) = g*rho(i,k)*uns(i,k) + + else + fs(i,k) = zero + fns(i,k) = zero + end if + + ! redefine dummy variables - sedimentation is calculated over grid-scale + ! quantities to ensure conservation + + dumc(i,k) = qc(i,k) + qctend(i,k)*deltat + dumi(i,k) = qi(i,k) + qitend(i,k)*deltat + dumr(i,k) = qr(i,k) + qrtend(i,k)*deltat + dums(i,k) = qs(i,k) + qstend(i,k)*deltat + + dumnc(i,k) = nc(i,k) + nctend(i,k)*deltat + dumni(i,k) = ni(i,k) + nitend(i,k)*deltat + dumnr(i,k) = nr(i,k) + nrtend(i,k)*deltat + dumns(i,k) = ns(i,k) + nstend(i,k)*deltat + + if (dumc(i,k) < qsmall) dumnc(i,k) = zero + if (dumi(i,k) < qsmall) dumni(i,k) = zero + if (dumr(i,k) < qsmall) dumnr(i,k) = zero + if (dums(i,k) < qsmall) dumns(i,k) = zero + + enddo + end do !!! vertical loop + + do k=1,nlev + do i=1,mgncol + pdel_inv(i,k) = one / pdel(i,k) + enddo + enddo +! if (lprnt) write(0,*)' bef sedimentation dumc=',dumc(i,nlev-10:nlev) + + ! initialize nstep for sedimentation sub-steps + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + do i=1,mgncol + nstep = 1 + int(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + if (do_cldice) then + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + + do n = 1,nstep + + ! top of model + + k = 1 + + ! add fallout terms to microphysical tendencies + + tx5 = dumi(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumi(i,k) = tx5 / (one + fi(i,k)*tx7) + tx6 = (dumi(i,k)-tx5) * oneodt + qitend(i,k) = qitend(i,k) + tx6 + tx5 = dumni(i,k) + dumni(i,k) = tx5 / (one + fni(i,k)*tx7) + nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt + + ! sedimentation tendency for output + qisedten(i,k) = qisedten(i,k) + tx6 + + falouti(k) = fi(i,k) * dumi(i,k) + faloutni(k) = fni(i,k) * dumni(i,k) + + iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux + + do k = 2,nlev + + ! for cloud liquid and ice, if cloud fraction increases with height + ! then add flux from above to both vapor and cloud water of current level + ! this means that flux entering clear portion of cell from above evaporates + ! instantly + + ! note: this is not an issue with precip, since we assume max overlap + + tx5 = dumi(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumi(i,k) = (tx5 + falouti(k-1)*tx7) / (one + fi(i,k)*tx7) + tx6 = (dumi(i,k)-tx5) * oneodt + ! add fallout terms to eulerian tendencies + qitend(i,k) = qitend(i,k) + tx6 + tx5 = dumni(i,k) + dumni(i,k) = (tx5 + faloutni(k-1)*tx7) / (one + fni(i,k)*tx7) + nitend(i,k) = nitend(i,k) + (dumni(i,k)-tx5) * oneodt + + + qisedten(i,k) = qisedten(i,k) + tx6 ! sedimentation tendency for output + + + falouti(k) = fi(i,k) * dumi(i,k) + faloutni(k) = fni(i,k) * dumni(i,k) + + iflx(i,k+1) = iflx(i,k+1) + falouti(k) * tx3 ! Ice flux + end do + + ! units below are m/s + ! sedimentation flux at surface is added to precip flux at surface + ! to get total precip (cloud + precip water) rate + + prect(i) = prect(i) + falouti(nlev) * (tx3*0.001_r8) + preci(i) = preci(i) + falouti(nlev) * (tx3*0.001_r8) + + end do + end if + +! if (lprnt) write(0,*)' tlat4=',tlat(1,:)*deltat + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( maxval( fc(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fnc(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + + do n = 1,nstep + + ! top of model + k = 1 + + tx5 = dumc(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumc(i,k) = tx5 / (one + fc(i,k)*tx7) + tx6 = (dumc(i,k)-tx5) * oneodt + qctend(i,k) = qctend(i,k) + tx6 + tx5 = dumnc(i,k) + dumnc(i,k) = tx5 / (one + fnc(i,k)*tx7) + nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt + + + ! sedimentation tendency for output + qcsedten(i,k) = qcsedten(i,k) + tx6 + + faloutc(k) = fc(i,k) * dumc(i,k) + faloutnc(k) = fnc(i,k) * dumnc(i,k) + + lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 + do k = 2,nlev + + tx5 = dumc(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumc(i,k) = (tx5 + faloutc(k-1)*tx7) / (one + fc(i,k)*tx7) + tx6 = (dumc(i,k)-tx5) * oneodt + qctend(i,k) = qctend(i,k) + tx6 + tx5 = dumnc(i,k) + dumnc(i,k) = (tx5 + faloutnc(k-1)*tx7) / (one + fnc(i,k)*tx7) + nctend(i,k) = nctend(i,k) + (dumnc(i,k)-tx5) * oneodt + + + + qcsedten(i,k) = qcsedten(i,k) + tx6 ! sedimentation tendency for output + + faloutc(k) = fc(i,k) * dumc(i,k) + faloutnc(k) = fnc(i,k) * dumnc(i,k) + + lflx(i,k+1) = lflx(i,k+1) + faloutc(k) * tx3 ! Liquid condensate flux here + end do + + prect(i) = prect(i) + faloutc(nlev) * (tx3*0.001_r8) + + end do +! if (lprnt) write(0,*)' tlat5=',tlat(1,:)*deltat + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + + do n = 1,nstep + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + + tx5 = dumr(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumr(i,k) = tx5 / (one + fr(i,k)*tx7) + tx6 = (dumr(i,k)-tx5) * oneodt + qrtend(i,k) = qrtend(i,k) + tx6 + tx5 = dumnr(i,k) + dumnr(i,k) = tx5 / (one + fnr(i,k)*tx7) + nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt + + ! sedimentation tendency for output + qrsedten(i,k) = qrsedten(i,k) + tx6 + + faloutr(k) = fr(i,k) * dumr(i,k) + faloutnr(k) = fnr(i,k) * dumnr(i,k) + + rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 + + do k = 2,nlev + + tx5 = dumr(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumr(i,k) = (tx5 + faloutr(k-1)*tx7) / (one + fr(i,k)*tx7) + tx6 = (dumr(i,k)-tx5) * oneodt + qrtend(i,k) = qrtend(i,k) + tx6 + tx5 = dumnr(i,k) + dumnr(i,k) = (tx5 + faloutnr(k-1)*tx7) / (one + fnr(i,k)*tx7) + nrtend(i,k) = nrtend(i,k) + (dumnr(i,k)-tx5) * oneodt + + + ! sedimentation tendency for output + qrsedten(i,k) = qrsedten(i,k) + tx6 ! sedimentation tendency for output + + faloutr(k) = fr(i,k) * dumr(i,k) + faloutnr(k) = fnr(i,k) * dumnr(i,k) + + rflx(i,k+1) = rflx(i,k+1) + faloutr(k) * tx3 ! Rain Flux + end do + + prect(i) = prect(i) + faloutr(nlev) * (tx3*0.001_r8) + + end do + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + int(max( maxval( fs(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fns(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + do n = 1,nstep + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + + tx5 = dums(i,k) + tx7 = pdel_inv(i,k) * tx1 + dums(i,k) = tx5 / (one + fs(i,k)*tx7) + tx6 = (dums(i,k)-tx5) * oneodt + qstend(i,k) = qstend(i,k) + tx6 + tx5 = dumns(i,k) + dumns(i,k) = tx5 / (one + fns(i,k)*tx7) + nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt + + ! sedimentation tendency for output + qssedten(i,k) = qssedten(i,k) + tx6 + + falouts(k) = fs(i,k) * dums(i,k) + faloutns(k) = fns(i,k) * dumns(i,k) + + sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 + + do k = 2,nlev + + + tx5 = dums(i,k) + tx7 = pdel_inv(i,k) * tx1 + dums(i,k) = (tx5 + falouts(k-1)*tx7) / (one + fs(i,k)*tx7) + tx6 = (dums(i,k)-tx5) * oneodt + qstend(i,k) = qstend(i,k) + tx6 + tx5 = dumns(i,k) + dumns(i,k) = (tx5 + faloutns(k-1)*tx7) / (one + fns(i,k)*tx7) + nstend(i,k) = nstend(i,k) + (dumns(i,k)-tx5) * oneodt + + + qssedten(i,k) = qssedten(i,k) + tx6 ! sedimentation tendency for output + + falouts(k) = fs(i,k) * dums(i,k) + faloutns(k) = fns(i,k) * dumns(i,k) + + sflx(i,k+1) = sflx(i,k+1) + falouts(k) * tx3 ! Snow Flux + end do !! k loop + + prect(i) = prect(i) + falouts(nlev) * (tx3*0.001_r8) + preci(i) = preci(i) + falouts(nlev) * (tx3*0.001_r8) + + end do !! nstep loop + + enddo ! end of i loop + ! end sedimentation + + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + ! get new update for variables that includes sedimentation tendency + ! note : here dum variables are grid-average, NOT in-cloud + + do k=1,nlev + do i=1,mgncol + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat, zero) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat, zero) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat, zero) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat, zero) + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k) = ncnst*rhoinv(i,k)*lcldm(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k) = ninst*rhoinv(i,k)*icldm(i,k) + end if + + if (dumc(i,k) < qsmall) dumnc(i,k) = zero + if (dumi(i,k) < qsmall) dumni(i,k) = zero + if (dumr(i,k) < qsmall) dumnr(i,k) = zero + if (dums(i,k) < qsmall) dumns(i,k) = zero + + enddo + + enddo + + ! calculate instantaneous processes (melting, homogeneous freezing) + !==================================================================== + + ! melting of snow at +2 C + do k=1,nlev + + do i=1,mgncol + + tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - snowmelt + if (tx1 > zero) then + if (dums(i,k) > zero) then + + ! make sure melting snow doesn't reduce temperature below threshold + dum = -(xlf/cpp) * dums(i,k) + if (tx1+dum < zero) then + dum = min(one, max(zero, -tx1/dum)) + else + dum = one + end if + + tx1 = dum * oneodt + qstend(i,k) = qstend(i,k) - tx1*dums(i,k) + nstend(i,k) = nstend(i,k) - tx1*dumns(i,k) + qrtend(i,k) = qrtend(i,k) + tx1*dums(i,k) + nrtend(i,k) = nrtend(i,k) + tx1*dumns(i,k) + + dum1 = - xlf * tx1 * dums(i,k) + tlat(i,k) = tlat(i,k) + dum1 + meltsdttot(i,k) = meltsdttot(i,k) + dum1 + end if + end if + enddo + enddo + do k=1,nlev + do i=1,mgncol + + ! freezing of rain at -5 C + + tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - rainfrze + if (tx1 < zero) then + + if (dumr(i,k) > zero) then + + ! make sure freezing rain doesn't increase temperature above threshold + dum = (xlf/cpp) * dumr(i,k) + if (tx1+dum > zero) then + dum = min(one, max(zero, -tx1/dum)) + else + dum = one + end if + tx2 = dum * oneodt + qrtend(i,k) = qrtend(i,k) - tx2 * dumr(i,k) + nrtend(i,k) = nrtend(i,k) - tx2 * dumnr(i,k) + + ! get mean size of rain = 1/lamr, add frozen rain to either snow or cloud ice + ! depending on mean rain size + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) + + if (lamr(i,k) < one/Dcs) then + qstend(i,k) = qstend(i,k) + tx2 * dumr(i,k) + nstend(i,k) = nstend(i,k) + tx2 * dumnr(i,k) + else + qitend(i,k) = qitend(i,k) + tx2 * dumr(i,k) + nitend(i,k) = nitend(i,k) + tx2 * dumnr(i,k) + end if + ! heating tendency + dum1 = xlf*dum*dumr(i,k)*oneodt + frzrdttot(i,k) = dum1 + frzrdttot(i,k) + tlat(i,k) = dum1 + tlat(i,k) + + end if + end if + + enddo + enddo + if (do_cldice) then + do k=1,nlev + do i=1,mgncol + tx1 = t(i,k) + tlat(i,k) * (deltat/cpp) - tmelt + if (tx1 > zero) then + if (dumi(i,k) > zero) then + + ! limit so that melting does not push temperature below freezing + !----------------------------------------------------------------- + dum = -dumi(i,k)*xlf/cpp + if (tx1+dum < zero) then + dum = min(one, max(zero, tx1/dum)) + else + dum = one + end if + + tx2 = dum * oneodt + qctend(i,k) = qctend(i,k) + tx2*dumi(i,k) + + ! for output + melttot(i,k) = tx2*dumi(i,k) + + ! assume melting ice produces droplet + ! mean volume radius of 8 micron + + nctend(i,k) = nctend(i,k) + three*tx2*dumi(i,k)/(four*pi*5.12e-16_r8*rhow) + + qitend(i,k) = ((one-dum)*dumi(i,k)-qi(i,k)) * oneodt + nitend(i,k) = ((one-dum)*dumni(i,k)-ni(i,k)) * oneodt + tlat(i,k) = tlat(i,k) - xlf*tx2*dumi(i,k) + end if + end if + enddo + enddo + +! if (lprnt) write(0,*)' tlat6=',tlat(1,:)*deltat +! if (lprnt) write(0,*)' qitend=',qitend(1,nlev-10:nlev)*deltat +! if (lprnt) write(0,*)' qctend=',qctend(1,nlev-10:nlev)*deltat + ! homogeneously freeze droplets at -40 C + !----------------------------------------------------------------- + + do k=1,nlev + do i=1,mgncol + tx1 = t(i,k) + tlat(i,k)*(deltat/cpp) - 233.15_r8 + if (tx1 < zero) then + if (dumc(i,k) > zero) then + + ! limit so that freezing does not push temperature above threshold + dum = (xlf/cpp) * dumc(i,k) + if (tx1+dum > zero) then + dum = min(one, max(zero, -tx1/dum)) + else + dum = one + end if + + tx2 = dum * oneodt * dumc(i,k) + qitend(i,k) = tx2 + qitend(i,k) + homotot(i,k) = tx2 ! for output + + ! assume 25 micron mean volume radius of homogeneously frozen droplets + ! consistent with size of detrained ice in stratiform.F90 + + nitend(i,k) = nitend(i,k) + tx2*(three/(four*pi*1.563e-14_r8* 500._r8)) + qctend(i,k) = ((one-dum)*dumc(i,k)-qc(i,k)) * oneodt + nctend(i,k) = ((one-dum)*dumnc(i,k)-nc(i,k)) * oneodt + tlat(i,k) = tlat(i,k) + xlf*tx2 + end if + end if + enddo + enddo + ! remove any excess over-saturation, which is possible due to non-linearity when adding + ! together all microphysical processes + !----------------------------------------------------------------- + ! follow code similar to old CAM scheme + do k=1,nlev + do i=1,mgncol + + qtmp = q(i,k) + qvlat(i,k) * deltat + ttmp = t(i,k) + tlat(i,k) * (deltat/cpp) + + ! use rhw to allow ice supersaturation + !call qsat_water(ttmp, p(i,k), esn, qvn) + esn = min(fpvsl(ttmp), p(i,k)) + qvn = epsqs*esn/(p(i,k)-omeps*esn) * qsfm(i,k) + + + if (qtmp > qvn .and. qvn > 0 .and. allow_sed_supersat) then + ! expression below is approximate since there may be ice deposition + dum = (qtmp-qvn)/(one+xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) * oneodt + ! add to output cme + cmeout(i,k) = cmeout(i,k) + dum + ! now add to tendencies, partition between liquid and ice based on temperature + if (ttmp > 268.15_r8) then + dum1 = zero + ! now add to tendencies, partition between liquid and ice based on te + !------------------------------------------------------- + else if (ttmp < 238.15_r8) then + dum1 = one + else + dum1 = (268.15_r8-ttmp)/30._r8 + end if + + tx1 = xxls*dum1 + xxlv*(one-dum1) + dum = (qtmp-qvn)/(one+tx1*tx1*qvn/(cpp*rv*ttmp*ttmp)) * oneodt + tx2 = dum*(one-dum1) + qctend(i,k) = qctend(i,k) + tx2 + qcrestot(i,k) = tx2 ! for output + qitend(i,k) = qitend(i,k) + dum*dum1 + qirestot(i,k) = dum*dum1 + qvlat(i,k) = qvlat(i,k) - dum + ! for output + qvres(i,k) = -dum + tlat(i,k) = tlat(i,k) + dum*tx1 + end if + enddo + enddo + end if + +! if (lprnt) write(0,*)' tlat7=',tlat(1,:)*deltat + ! calculate effective radius for pass to radiation code + !========================================================= + ! if no cloud water, default value is 10 micron for droplets, + ! 25 micron for cloud ice + + ! update cloud variables after instantaneous processes to get effective radius + ! variables are in-cloud to calculate size dist parameters + do k=1,nlev + do i=1,mgncol + tx1 = one / max(lcldm(i,k),epsln) + tx2 = one / max(icldm(i,k),epsln) + tx3 = one / precip_frac(i,k) + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat, zero) * tx1 + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat, zero) * tx2 + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat, zero) * tx1 + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat, zero) * tx2 + + dumr(i,k) = max(qr(i,k)+qrtend(i,k)*deltat, zero) * tx3 + dumnr(i,k) = max(nr(i,k)+nrtend(i,k)*deltat, zero) * tx3 + dums(i,k) = max(qs(i,k)+qstend(i,k)*deltat, zero) * tx3 + dumns(i,k) = max(ns(i,k)+nstend(i,k)*deltat, zero) * tx3 + + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k) = ncnst * rhoinv(i,k) + end if + + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k) = ninst * rhoinv(i,k) + end if + + ! limit in-cloud mixing ratio to reasonable value of 5 g kg-1 + dumc(i,k) = min(dumc(i,k), 5.e-3_r8) + dumi(i,k) = min(dumi(i,k), 5.e-3_r8) + ! limit in-precip mixing ratios + dumr(i,k) = min(dumr(i,k), 10.e-3_r8) + dums(i,k) = min(dums(i,k), 10.e-3_r8) + enddo + enddo + ! cloud ice effective radius + !----------------------------------------------------------------- + + if (do_cldice) then + do k=1,nlev + do i=1,mgncol + if (dumi(i,k) >= qsmall) then + + tx1 = dumni(i,k) + call size_dist_param_basic(mg_ice_props, dumi(i,k), dumni(i,k), & + lami(i,k), dumni0) + + if (dumni(i,k) /= tx1) then + ! adjust number conc if needed to keep mean size in reasonable range + nitend(i,k) = (dumni(i,k)*icldm(i,k)-ni(i,k)) * oneodt + end if + + tx1 = one / lami(i,k) + effi(i,k) = (1.5_r8*1.e6_r8) * tx1 + sadice(i,k) = two*pi*(tx1*tx1*tx1)*dumni0*rho(i,k)*1.e-2_r8 ! m2/m3 -> cm2/cm3 + + else + effi(i,k) = 25._r8 + sadice(i,k) = zero + end if + + ! ice effective diameter for david mitchell's optics + deffi(i,k) = effi(i,k) * (rhoi+rhoi)/rhows + enddo + enddo + !else + !do k=1,nlev + !do i=1,mgncol + ! NOTE: If CARMA is doing the ice microphysics, then the ice effective + ! radius has already been determined from the size distribution. + !effi(i,k) = re_ice(i,k) * 1.e6_r8 ! m -> um + !deffi(i,k)=effi(i,k) * 2._r8 + !sadice(i,k) = 4._r8*pi*(effi(i,k)**2)*ni(i,k)*rho(i,k)*1e-2_r8 + !enddo + !enddo + end if + + ! cloud droplet effective radius + !----------------------------------------------------------------- + do k=1,nlev + do i=1,mgncol + if (dumc(i,k) >= qsmall) then + + + ! switch for specification of droplet and crystal number + if (nccons) then + ! make sure nc is consistence with the constant N by adjusting tendency, need + ! to multiply by cloud fraction + ! note that nctend may be further adjusted below if mean droplet size is + ! out of bounds + + nctend(i,k) = (ncnst*rhoinv(i,k)*lcldm(i,k)-nc(i,k)) * oneodt + + end if + + dum = dumnc(i,k) + + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + if (dum /= dumnc(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nctend(i,k) = (dumnc(i,k)*lcldm(i,k)-nc(i,k)) * oneodt + end if + + effc(i,k) = (half*1.e6_r8) * (pgam(i,k)+three) / lamc(i,k) + !assign output fields for shape here + lamcrad(i,k) = lamc(i,k) + pgamrad(i,k) = pgam(i,k) + + + ! recalculate effective radius for constant number, in order to separate + ! first and second indirect effects + !====================================== + ! assume constant number of 10^8 kg-1 + + dumnc(i,k) = 1.e8_r8 + + ! Pass in "false" adjust flag to prevent number from being changed within + ! size distribution subroutine. + call size_dist_param_liq(mg_liq_props, dumc(i,k), dumnc(i,k), rho(i,k), & + pgam(i,k), lamc(i,k)) + + effc_fn(i,k) = (half*1.e6_r8) * (pgam(i,k)+three)/lamc(i,k) + + else + effc(i,k) = ten + lamcrad(i,k) = zero + pgamrad(i,k) = zero + effc_fn(i,k) = ten + end if + enddo + enddo + ! recalculate 'final' rain size distribution parameters + ! to ensure that rain size is in bounds, adjust rain number if needed + do k=1,nlev + do i=1,mgncol + + if (dumr(i,k) >= qsmall) then + + dum = dumnr(i,k) + + call size_dist_param_basic(mg_rain_props, dumr(i,k), dumnr(i,k), lamr(i,k)) + + if (dum /= dumnr(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nrtend(i,k) = (dumnr(i,k)*precip_frac(i,k)-nr(i,k)) *oneodt + end if + + end if + enddo + enddo + ! recalculate 'final' snow size distribution parameters + ! to ensure that snow size is in bounds, adjust snow number if needed + do k=1,nlev + do i=1,mgncol + if (dums(i,k) >= qsmall) then + + dum = dumns(i,k) + + call size_dist_param_basic(mg_snow_props, dums(i,k), dumns(i,k), & + lams(i,k), n0=dumns0) + + if (dum /= dumns(i,k)) then + ! adjust number conc if needed to keep mean size in reasonable range + nstend(i,k) = (dumns(i,k)*precip_frac(i,k)-ns(i,k)) * oneodt + end if + + tx1 = (two*pi*1.e-2_r8) / (lams(i,k)*lams(i,k)*lams(i,k)) + sadsnow(i,k) = tx1*dumns0*rho(i,k) ! m2/m3 -> cm2/cm3 + + end if + + + end do ! vertical k loop + enddo + do k=1,nlev + do i=1,mgncol + ! if updated q (after microphysics) is zero, then ensure updated n is also zero + !================================================================================= + if (qc(i,k)+qctend(i,k)*deltat < qsmall) nctend(i,k) = -nc(i,k) * oneodt + if (do_cldice .and. qi(i,k)+qitend(i,k)*deltat < qsmall) nitend(i,k) = -ni(i,k) * oneodt + if (qr(i,k)+qrtend(i,k)*deltat < qsmall) nrtend(i,k) = -nr(i,k) * oneodt + if (qs(i,k)+qstend(i,k)*deltat < qsmall) nstend(i,k) = -ns(i,k) * oneodt + + end do + + end do + + ! DO STUFF FOR OUTPUT: + !================================================== + + do k=1,nlev + do i=1,mgncol + + ! qc and qi are only used for output calculations past here, + ! so add qctend and qitend back in one more time + qc(i,k) = qc(i,k) + qctend(i,k)*deltat + qi(i,k) = qi(i,k) + qitend(i,k)*deltat + + ! averaging for snow and rain number and diameter + !-------------------------------------------------- + + ! drout2/dsout2: + ! diameter of rain and snow + ! dsout: + ! scaled diameter of snow (passed to radiation in CAM) + ! reff_rain/reff_snow: + ! calculate effective radius of rain and snow in microns for COSP using Eq. 9 of COSP v1.3 manual + + if (qrout(i,k) > 1.e-7_r8 .and. nrout(i,k) > zero) then + qrout2(i,k) = qrout(i,k) * precip_frac(i,k) + nrout2(i,k) = nrout(i,k) * precip_frac(i,k) + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just drout2 times constants. + drout2(i,k) = avg_diameter(qrout(i,k), nrout(i,k), rho(i,k), rhow) + freqr(i,k) = precip_frac(i,k) + + reff_rain(i,k) = (1.e6_r8*1.5_r8) * drout2(i,k) + else + qrout2(i,k) = zero + nrout2(i,k) = zero + drout2(i,k) = zero + freqr(i,k) = zero + reff_rain(i,k) = zero + endif + + if (qsout(i,k) > 1.e-7_r8 .and. nsout(i,k) > zero) then + qsout2(i,k) = qsout(i,k) * precip_frac(i,k) + nsout2(i,k) = nsout(i,k) * precip_frac(i,k) + ! The avg_diameter call does the actual calculation; other diameter + ! outputs are just dsout2 times constants. + dsout2(i,k) = avg_diameter(qsout(i,k), nsout(i,k), rho(i,k), rhosn) + freqs(i,k) = precip_frac(i,k) + + dsout(i,k) = three*rhosn/rhows*dsout2(i,k) + + reff_snow(i,k) = (1.e6_r8*1.5_r8) * dsout2(i,k) + else + dsout(i,k) = zero + qsout2(i,k) = zero + nsout2(i,k) = zero + dsout2(i,k) = zero + freqs(i,k) = zero + reff_snow(i,k) = zero + endif + + enddo + enddo + + ! analytic radar reflectivity + !-------------------------------------------------- + ! formulas from Matthew Shupe, NOAA/CERES + ! *****note: radar reflectivity is local (in-precip average) + ! units of mm^6/m^3 + + do k=1,nlev + do i = 1,mgncol + if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten .and. lcldm(i,k) > epsln) then + tx1 = rho(i,k) / lcldm(i,k) + tx2 = 1000._r8 * qc(i,k) * tx1 + dum = tx2 * tx2 * lcldm(i,k) & + /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)*tx1*1.e-6_r8*precip_frac(i,k)) +! dum = (qc(i,k)/lcldm(i,k)*rho(i,k)*1000._r8)**2 & +! /(0.109_r8*(nc(i,k)+nctend(i,k)*deltat)/lcldm(i,k)*rho(i,k)/1.e6_r8)*lcldm(i,k)/precip_frac(i,k) + else + dum = zero + end if + if (qi(i,k) >= qsmall .and. icldm(i,k) > epsln) then +! dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*1000._r8/0.1_r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(i,k) + dum1 = (qi(i,k)*rho(i,k)/icldm(i,k)*10000._r8)**(one/0.63_r8)*icldm(i,k)/precip_frac(i,k) + else + dum1 = zero + end if + + if (qsout(i,k) >= qsmall) then +! dum1 = dum1 + (qsout(i,k)*rho(i,k)*1000._r8/0.1_r8)**(one/0.63_r8) + dum1 = dum1 + (qsout(i,k)*rho(i,k)*10000._r8)**(one/0.63_r8) + end if + + refl(i,k) = dum + dum1 + + ! add rain rate, but for 37 GHz formulation instead of 94 GHz + ! formula approximated from data of Matrasov (2007) + ! rainrt is the rain rate in mm/hr + ! reflectivity (dum) is in DBz + + if (rainrt(i,k) >= 0.001_r8) then + dum = rainrt(i,k) * rainrt(i,k) + dum = log10(dum*dum*dum) + 16._r8 + + ! convert from DBz to mm^6/m^3 + + dum = ten**(dum/ten) + else + ! don't include rain rate in R calculation for values less than 0.001 mm/hr + dum = zero + end if + + ! add to refl + + refl(i,k) = refl(i,k) + dum + + !output reflectivity in Z. + areflz(i,k) = refl(i,k) * precip_frac(i,k) + + ! convert back to DBz + + if (refl(i,k) > minrefl) then + refl(i,k) = ten*log10(refl(i,k)) + else + refl(i,k) = -9999._r8 + end if + + !set averaging flag + if (refl(i,k) > mindbz) then + arefl(i,k) = refl(i,k) * precip_frac(i,k) + frefl(i,k) = precip_frac(i,k) + else + arefl(i,k) = zero + areflz(i,k) = zero + frefl(i,k) = zero + end if + + ! bound cloudsat reflectivity + + csrfl(i,k) = min(csmax,refl(i,k)) + + !set averaging flag + if (csrfl(i,k) > csmin) then + acsrfl(i,k) = refl(i,k) * precip_frac(i,k) + fcsrfl(i,k) = precip_frac(i,k) + else + acsrfl(i,k) = zero + fcsrfl(i,k) = zero + end if + + end do + end do + + do k=1,nlev + do i = 1,mgncol + !redefine fice here.... + tx2 = qsout(i,k) + qi(i,k) + tx1 = tx2 + qrout(i,k) + qc(i,k) + if ( tx2 > qsmall .and. tx1 > qsmall) then + nfice(i,k) = min(tx2/tx1, one) + else + nfice(i,k) = zero + endif + enddo + enddo + +end subroutine micro_mg_tend + +!======================================================================== +!OUTPUT CALCULATIONS +!======================================================================== + +subroutine calc_rercld(lamr, n0r, lamc, pgam, qric, qcic, ncic, rercld, mgncol,nlev) + integer, intent(in) :: mgncol, nlev + real(r8), dimension(mgncol,nlev), intent(in) :: lamr ! rain size parameter (slope) + real(r8), dimension(mgncol,nlev), intent(in) :: n0r ! rain size parameter (intercept) + real(r8), dimension(mgncol,nlev), intent(in) :: lamc ! size distribution parameter (slope) + real(r8), dimension(mgncol,nlev), intent(in) :: pgam ! droplet size parameter + real(r8), dimension(mgncol,nlev), intent(in) :: qric ! in-cloud rain mass mixing ratio + real(r8), dimension(mgncol,nlev), intent(in) :: qcic ! in-cloud cloud liquid + real(r8), dimension(mgncol,nlev), intent(in) :: ncic ! in-cloud droplet number concentration + + real(r8), dimension(mgncol,nlev), intent(inout) :: rercld ! effective radius calculation for rain + cloud + + ! combined size of precip & cloud drops + real(r8) :: Atmp + + integer :: i, k + + do k=1,nlev + do i=1,mgncol + ! Rain drops + if (lamr(i,k) > zero) then + Atmp = n0r(i,k) * (half*pi) / (lamr(i,k)*lamr(i,k)*lamr(i,k)) + else + Atmp = zero + end if + + ! Add cloud drops + if (lamc(i,k) > zero) then + Atmp = Atmp + ncic(i,k) * pi * rising_factorial(pgam(i,k)+one, 2) & + / (four*lamc(i,k)*lamc(i,k)) + end if + + if (Atmp > zero) then + rercld(i,k) = rercld(i,k) + three *(qric(i,k) + qcic(i,k)) / (four * rhow * Atmp) + end if + enddo + enddo +end subroutine calc_rercld + +!======================================================================== + +end module micro_mg2_0 diff --git a/gfsphysics/physics/micro_mg_utils.F90 b/gfsphysics/physics/micro_mg_utils.F90 new file mode 100755 index 000000000..38b6b4edc --- /dev/null +++ b/gfsphysics/physics/micro_mg_utils.F90 @@ -0,0 +1,1731 @@ +module micro_mg_utils + +!-------------------------------------------------------------------------- +! +! This module contains process rates and utility functions used by the MG +! microphysics. +! +! Original MG authors: Andrew Gettelman, Hugh Morrison +! Contributions from: Peter Caldwell, Xiaohong Liu and Steve Ghan +! +! Separated from MG 1.5 by B. Eaton. +! Separated module switched to MG 2.0 and further changes by S. Santos. +! Anning Cheng changed for FV3GFS 9/29/2017 +! added ac_time as an input +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +! +!-------------------------------------------------------------------------- +! +! List of required external functions that must be supplied: +! gamma --> standard mathematical gamma function (if gamma is an +! intrinsic, define HAVE_GAMMA_INTRINSICS) +! +!-------------------------------------------------------------------------- +! +! Constants that must be specified in the "init" method (module variables): +! +! kind kind of reals (to verify correct linkage only) - +! gravit acceleration due to gravity m s-2 +! rair dry air gas constant for air J kg-1 K-1 +! rh2o gas constant for water vapor J kg-1 K-1 +! cpair specific heat at constant pressure for dry air J kg-1 K-1 +! tmelt temperature of melting point for water K +! latvap latent heat of vaporization J kg-1 +! latice latent heat of fusion J kg-1 +! +!-------------------------------------------------------------------------- + +! 8 byte real and integer +use machine, only : r8 => kind_phys +use machine, only : i8 => kind_phys +implicit none +private +save + +public :: & + micro_mg_utils_init, & + size_dist_param_liq, & + size_dist_param_basic, & + avg_diameter, & + rising_factorial, & + ice_deposition_sublimation, & + sb2001v2_liq_autoconversion, & + sb2001v2_accre_cld_water_rain, & + kk2000_liq_autoconversion, & + ice_autoconversion, & + immersion_freezing, & + contact_freezing, & + snow_self_aggregation, & + accrete_cloud_water_snow, & + secondary_ice_production, & + accrete_rain_snow, & + heterogeneous_rain_freezing, & + accrete_cloud_water_rain, & + self_collection_rain, & + accrete_cloud_ice_snow, & + evaporate_sublimate_precip, & + bergeron_process_snow, & + liu_liq_autoconversion, & + gmao_ice_autoconversion + + +public :: MGHydrometeorProps + +type :: MGHydrometeorProps + ! Density (kg/m^3) + real(r8) :: rho + ! Information for size calculations. + ! Basic calculation of mean size is: + ! lambda = (shape_coef*nic/qic)^(1/eff_dim) + ! Then lambda is constrained by bounds. + real(r8) :: eff_dim + real(r8) :: shape_coef + real(r8) :: lambda_bounds(2) + ! Minimum average particle mass (kg). + ! Limit is applied at the beginning of the size distribution calculations. + real(r8) :: min_mean_mass +end type MGHydrometeorProps + +interface MGHydrometeorProps + module procedure NewMGHydrometeorProps +end interface + +type(MGHydrometeorProps), public :: mg_liq_props +type(MGHydrometeorProps), public :: mg_ice_props +type(MGHydrometeorProps), public :: mg_rain_props +type(MGHydrometeorProps), public :: mg_snow_props + +interface size_dist_param_liq + module procedure size_dist_param_liq_vect + module procedure size_dist_param_liq_line +end interface +interface size_dist_param_basic + module procedure size_dist_param_basic_vect + module procedure size_dist_param_basic_line +end interface + +!================================================= +! Public module parameters (mostly for MG itself) +!================================================= + +! Pi to 20 digits; more than enough to reach the limit of double precision. +real(r8), parameter, public :: pi = 3.14159265358979323846_r8 + +! "One minus small number": number near unity for round-off issues. +!real(r8), parameter, public :: omsm = 1._r8 - 1.e-5_r8 +real(r8), parameter, public :: omsm = 1._r8 - 1.e-6_r8 + +! Smallest mixing ratio considered in microphysics. +real(r8), parameter, public :: qsmall = 1.e-18_r8 + +! minimum allowed cloud fraction +real(r8), parameter, public :: mincld = 0.0001_r8 +!real(r8), parameter, public :: mincld = 0.0_r8 + +real(r8), parameter, public :: rhosn = 250._r8 ! bulk density snow +real(r8), parameter, public :: rhoi = 500._r8 ! bulk density ice +real(r8), parameter, public :: rhow = 1000._r8 ! bulk density liquid +real(r8), parameter, public :: rhows = 917._r8 ! bulk density water solid + +! fall speed parameters, V = aD^b (V is in m/s) +! droplets +real(r8), parameter, public :: ac = 3.e7_r8 +real(r8), parameter, public :: bc = 2._r8 +! snow +real(r8), parameter, public :: as = 11.72_r8 +real(r8), parameter, public :: bs = 0.41_r8 +! cloud ice +real(r8), parameter, public :: ai = 700._r8 +real(r8), parameter, public :: bi = 1._r8 +! small cloud ice (r< 10 um) - sphere, bulk density +real(r8), parameter, public :: aj = ac*((rhoi/rhows)**(bc/3._r8))*rhows/rhow +real(r8), parameter, public :: bj = bc +! rain +real(r8), parameter, public :: ar = 841.99667_r8 +real(r8), parameter, public :: br = 0.8_r8 + +! mass of new crystal due to aerosol freezing and growth (kg) +! Make this consistent with the lower bound, to support UTLS and +! stratospheric ice, and the smaller ice size limit. +real(r8), parameter, public :: mi0 = 4._r8/3._r8*pi*rhoi*(1.e-6_r8)**3 + +!================================================= +! Private module parameters +!================================================= + +! Signaling NaN bit pattern that represents a limiter that's turned off. +integer(i8), parameter :: limiter_off = int(Z'7FF1111111111111', i8) + +! alternate threshold used for some in-cloud mmr +real(r8), parameter :: icsmall = 1.e-8_r8 + +! particle mass-diameter relationship +! currently we assume spherical particles for cloud ice/snow +! m = cD^d +! exponent +real(r8), parameter :: dsph = 3._r8 + +! Bounds for mean diameter for different constituents. +real(r8), parameter :: lam_bnd_rain(2) = 1._r8/[500.e-6_r8, 20.e-6_r8] +real(r8), parameter :: lam_bnd_snow(2) = 1._r8/[2000.e-6_r8, 10.e-6_r8] + +! Minimum average mass of particles. +real(r8), parameter :: min_mean_mass_liq = 1.e-20_r8 +real(r8), parameter :: min_mean_mass_ice = 1.e-20_r8 + +! ventilation parameters +! for snow +real(r8), parameter :: f1s = 0.86_r8 +real(r8), parameter :: f2s = 0.28_r8 +! for rain +real(r8), parameter :: f1r = 0.78_r8 +real(r8), parameter :: f2r = 0.308_r8 + +! collection efficiencies +! aggregation of cloud ice and snow +real(r8), parameter :: eii = 0.5_r8 + +! immersion freezing parameters, bigg 1953 +real(r8), parameter :: bimm = 100._r8 +real(r8), parameter :: aimm = 0.66_r8 + +! Mass of each raindrop created from autoconversion. +real(r8), parameter :: droplet_mass_25um = 4._r8/3._r8*pi*rhow*(25.e-6_r8)**3 +real(r8), parameter :: droplet_mass_40um = 4._r8/3._r8*pi*rhow*(40.e-6_r8)**3 + +!========================================================= +! Constants set in initialization +!========================================================= + +! Set using arguments to micro_mg_init +real(r8) :: rv ! water vapor gas constant +real(r8) :: cpp ! specific heat of dry air +real(r8) :: tmelt ! freezing point of water (K) + +! latent heats of: +real(r8) :: xxlv ! vaporization +real(r8) :: xlf ! freezing +real(r8) :: xxls ! sublimation + +! additional constants to help speed up code +real(r8) :: gamma_bs_plus3 +real(r8) :: gamma_half_br_plus5 +real(r8) :: gamma_half_bs_plus5 +! +real(r8), parameter :: zero = 0._r8, one = 1._r8, two = 2._r8, three = 3._r8, & + four = 4._r8, five = 5._r8, six = 6._r8, pio6 = pi/six, & + pio3 = pi/three, half = 0.5_r8, oneo3 = one/three + +!========================================================= +! Utilities that are cheaper if the compiler knows that +! some argument is an integer. +!========================================================= + +interface rising_factorial + module procedure rising_factorial_r8 + module procedure rising_factorial_integer +end interface rising_factorial + +interface var_coef + module procedure var_coef_r8 + module procedure var_coef_integer +end interface var_coef + +!========================================================================== +contains +!========================================================================== + +! Initialize module variables. +! +! "kind" serves no purpose here except to check for unlikely linking +! issues; always pass in the kind for a double precision real. +! +! +! Check the list at the top of this module for descriptions of all other +! arguments. +subroutine micro_mg_utils_init( kind, rh2o, cpair, tmelt_in, latvap, & + latice, dcs) + + integer, intent(in) :: kind + real(r8), intent(in) :: rh2o + real(r8), intent(in) :: cpair + real(r8), intent(in) :: tmelt_in + real(r8), intent(in) :: latvap + real(r8), intent(in) :: latice + real(r8), intent(in) :: dcs + + + ! Name this array to workaround an XLF bug (otherwise could just use the + ! expression that sets it). + real(r8) :: ice_lambda_bounds(2) + + !----------------------------------------------------------------------- + + + ! declarations for MG code (transforms variable names) + + rv = rh2o ! water vapor gas constant + cpp = cpair ! specific heat of dry air + tmelt = tmelt_in + + ! latent heats + + xxlv = latvap ! latent heat vaporization + xlf = latice ! latent heat freezing + xxls = xxlv + xlf ! latent heat of sublimation + + ! Define constants to help speed up code (this limits calls to gamma function) + gamma_bs_plus3 = gamma(three+bs) + gamma_half_br_plus5 = gamma((five+br)*half) + gamma_half_bs_plus5 = gamma((five+bs)*half) + + ! Don't specify lambda bounds for cloud liquid, as they are determined by + ! pgam dynamically. + mg_liq_props = MGHydrometeorProps(rhow, dsph, min_mean_mass=min_mean_mass_liq) + + ! Mean ice diameter can not grow bigger than twice the autoconversion + ! threshold for snow. + ice_lambda_bounds = one/[two*dcs, 1.e-6_r8] + + mg_ice_props = MGHydrometeorProps(rhoi, dsph, & + ice_lambda_bounds, min_mean_mass_ice) + + mg_rain_props = MGHydrometeorProps(rhow, dsph, lam_bnd_rain) + mg_snow_props = MGHydrometeorProps(rhosn, dsph, lam_bnd_snow) + +end subroutine micro_mg_utils_init + +! Constructor for a constituent property object. +function NewMGHydrometeorProps(rho, eff_dim, lambda_bounds, min_mean_mass) & + result(res) + real(r8), intent(in) :: rho, eff_dim + real(r8), intent(in), optional :: lambda_bounds(2), min_mean_mass + type(MGHydrometeorProps) :: res + + res%rho = rho + res%eff_dim = eff_dim + if (present(lambda_bounds)) then + res%lambda_bounds = lambda_bounds + else + res%lambda_bounds = no_limiter() + end if + if (present(min_mean_mass)) then + res%min_mean_mass = min_mean_mass + else + res%min_mean_mass = no_limiter() + end if + + res%shape_coef = rho * pio6 * gamma(eff_dim+one) + +end function NewMGHydrometeorProps + +!======================================================================== +!FORMULAS +!======================================================================== + +! Use gamma function to implement rising factorial extended to the reals. +pure function rising_factorial_r8(x, n) result(res) + real(r8), intent(in) :: x, n + real(r8) :: res + + res = gamma(x+n) / gamma(x) + +end function rising_factorial_r8 + +! Rising factorial can be performed much cheaper if n is a small integer. +pure function rising_factorial_integer(x, n) result(res) + real(r8), intent(in) :: x + integer, intent(in) :: n + real(r8) :: res + + integer :: i + real(r8) :: factor + + res = one + factor = x + + do i = 1, n + res = res * factor + factor = factor + one + end do + +end function rising_factorial_integer + +! Calculate correction due to latent heat for evaporation/sublimation +elemental function calc_ab(t, qv, xxl) result(ab) + real(r8), intent(in) :: t ! Temperature + real(r8), intent(in) :: qv ! Saturation vapor pressure + real(r8), intent(in) :: xxl ! Latent heat + + real(r8) :: ab + + real(r8) :: dqsdt + + dqsdt = xxl*qv / (rv*t*t) + ab = one + dqsdt*xxl/cpp + +end function calc_ab + +! get cloud droplet size distribution parameters +elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc) + type(MGHydrometeorProps), intent(in) :: props + real(r8), intent(in) :: qcic + real(r8), intent(inout) :: ncic + real(r8), intent(in) :: rho + + real(r8), intent(out) :: pgam + real(r8), intent(out) :: lamc + + type(MGHydrometeorProps) :: props_loc + + if (qcic > qsmall) then + + ! Local copy of properties that can be modified. + ! (Elemental routines that operate on arrays can't modify scalar + ! arguments.) + props_loc = props + + ! Get pgam from fit to observations of martin et al. 1994 + pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 + pgam = one / (pgam*pgam) - one + pgam = max(pgam, two) + + ! Set coefficient for use in size_dist_param_basic. + ! The 3D case is so common and optimizable that we specialize it: + if (props_loc%eff_dim == three) then + props_loc%shape_coef = pio6 * props_loc%rho * & + rising_factorial(pgam+one, 3) + else + props_loc%shape_coef = pio6 * props_loc%rho * & + rising_factorial(pgam+one, props_loc%eff_dim) + end if + + ! Limit to between 2 and 50 microns mean size. + props_loc%lambda_bounds = (pgam+one) * one/[50.e-6_r8, 2.e-6_r8] + + call size_dist_param_basic(props_loc, qcic, ncic, lamc) + + else + ! pgam not calculated in this case, so set it to a value likely to + ! cause an error if it is accidentally used + ! (gamma function undefined for negative integers) + pgam = -100._r8 + lamc = zero + end if + +end subroutine size_dist_param_liq_line + +! get cloud droplet size distribution parameters + +subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) + + type(mghydrometeorprops), intent(in) :: props + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: qcic + real(r8), dimension(mgncol), intent(inout) :: ncic + real(r8), dimension(mgncol), intent(in) :: rho + real(r8), dimension(mgncol), intent(out) :: pgam + real(r8), dimension(mgncol), intent(out) :: lamc + type(mghydrometeorprops) :: props_loc + integer :: i + + do i=1,mgncol + if (qcic(i) > qsmall) then + ! Local copy of properties that can be modified. + ! (Elemental routines that operate on arrays can't modify scalar + ! arguments.) + props_loc = props + ! Get pgam from fit to observations of martin et al. 1994 + pgam(i) = 0.0005714_r8*1.e-6_r8*ncic(i)*rho(i) + 0.2714_r8 + pgam(i) = one/(pgam(i)*pgam(i)) - one + pgam(i) = max(pgam(i), two) + endif + enddo + do i=1,mgncol + if (qcic(i) > qsmall) then + ! Set coefficient for use in size_dist_param_basic. + ! The 3D case is so common and optimizable that we specialize + ! it: + if (props_loc%eff_dim == three) then + props_loc%shape_coef = pio6 * props_loc%rho * & + rising_factorial(pgam(i)+one, 3) + else + props_loc%shape_coef = pio6 * props_loc%rho * & + rising_factorial(pgam(i)+one, props_loc%eff_dim) + end if + ! Limit to between 2 and 50 microns mean size. + props_loc%lambda_bounds(1) = (pgam(i)+one) / 50.e-6_r8 + props_loc%lambda_bounds(2) = (pgam(i)+one) / 2.e-6_r8 + call size_dist_param_basic(props_loc, qcic(i), ncic(i), lamc(i)) + endif + enddo + do i=1,mgncol + if (qcic(i) <= qsmall) then + ! pgam not calculated in this case, so set it to a value likely to + ! cause an error if it is accidentally used + ! (gamma function undefined for negative integers) + pgam(i) = -100._r8 + lamc(i) = zero + end if + enddo + +end subroutine size_dist_param_liq_vect + +! Basic routine for getting size distribution parameters. +elemental subroutine size_dist_param_basic_line(props, qic, nic, lam, n0) + type(MGHydrometeorProps), intent(in) :: props + real(r8), intent(in) :: qic + real(r8), intent(inout) :: nic + + real(r8), intent(out) :: lam + real(r8), intent(out), optional :: n0 + + if (qic > qsmall) then + + ! add upper limit to in-cloud number concentration to prevent + ! numerical error + if (limiter_is_on(props%min_mean_mass)) then + nic = min(nic, qic / props%min_mean_mass) + end if + + ! lambda = (c n/q)^(1/d) + lam = (props%shape_coef * nic/qic)**(one/props%eff_dim) + + ! check for slope + ! adjust vars + if (lam < props%lambda_bounds(1)) then + lam = props%lambda_bounds(1) + nic = lam**(props%eff_dim) * qic/props%shape_coef + else if (lam > props%lambda_bounds(2)) then + lam = props%lambda_bounds(2) + nic = lam**(props%eff_dim) * qic/props%shape_coef + end if + + else + lam = zero + end if + + if (present(n0)) n0 = nic * lam + +end subroutine size_dist_param_basic_line + +subroutine size_dist_param_basic_vect(props, qic, nic, lam, mgncol, n0) + + type (mghydrometeorprops), intent(in) :: props + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: qic + real(r8), dimension(mgncol), intent(inout) :: nic + real(r8), dimension(mgncol), intent(out) :: lam + real(r8), dimension(mgncol), intent(out), optional :: n0 + integer :: i + do i=1,mgncol + + if (qic(i) > qsmall) then + + ! add upper limit to in-cloud number concentration to prevent + ! numerical error + if (limiter_is_on(props%min_mean_mass)) then + nic(i) = min(nic(i), qic(i) / props%min_mean_mass) + end if + + ! lambda = (c n/q)^(1/d) + lam(i) = (props%shape_coef * nic(i)/qic(i))**(one/props%eff_dim) + + ! check for slope + ! adjust vars + if (lam(i) < props%lambda_bounds(1)) then + lam(i) = props%lambda_bounds(1) + nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef + else if (lam(i) > props%lambda_bounds(2)) then + lam(i) = props%lambda_bounds(2) + nic(i) = lam(i)**(props%eff_dim) * qic(i)/props%shape_coef + end if + + else + lam(i) = zero + end if + + enddo + + if (present(n0)) n0 = nic * lam + +end subroutine size_dist_param_basic_vect + + +real(r8) elemental function avg_diameter(q, n, rho_air, rho_sub) + ! Finds the average diameter of particles given their density, and + ! mass/number concentrations in the air. + ! Assumes that diameter follows an exponential distribution. + real(r8), intent(in) :: q ! mass mixing ratio + real(r8), intent(in) :: n ! number concentration (per volume) + real(r8), intent(in) :: rho_air ! local density of the air + real(r8), intent(in) :: rho_sub ! density of the particle substance + + avg_diameter = (pi * rho_sub * n/(q*rho_air))**(-oneo3) + +end function avg_diameter + +elemental function var_coef_r8(relvar, a) result(res) + ! Finds a coefficient for process rates based on the relative variance + ! of cloud water. + real(r8), intent(in) :: relvar + real(r8), intent(in) :: a + real(r8) :: res + + res = rising_factorial(relvar, a) / relvar**a + +end function var_coef_r8 + +elemental function var_coef_integer(relvar, a) result(res) + ! Finds a coefficient for process rates based on the relative variance + ! of cloud water. + real(r8), intent(in) :: relvar + integer, intent(in) :: a + real(r8) :: res + + res = rising_factorial(relvar, a) / relvar**a + +end function var_coef_integer + +!======================================================================== +!MICROPHYSICAL PROCESS CALCULATIONS +!======================================================================== +!======================================================================== +! Initial ice deposition and sublimation loop. +! Run before the main loop +! This subroutine written by Peter Caldwell + +subroutine ice_deposition_sublimation(t, qv, qi, ni, & + icldm, rho, dv,qvl, qvi, & + berg, vap_dep, ice_sublim, mgncol) + + !INPUT VARS: + !=============================================== + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t + real(r8), dimension(mgncol), intent(in) :: qv + real(r8), dimension(mgncol), intent(in) :: qi + real(r8), dimension(mgncol), intent(in) :: ni + real(r8), dimension(mgncol), intent(in) :: icldm + real(r8), dimension(mgncol), intent(in) :: rho + real(r8), dimension(mgncol), intent(in) :: dv + real(r8), dimension(mgncol), intent(in) :: qvl + real(r8), dimension(mgncol), intent(in) :: qvi + + !OUTPUT VARS: + !=============================================== + real(r8), dimension(mgncol), intent(out) :: vap_dep !ice deposition (cell-ave value) + real(r8), dimension(mgncol), intent(out) :: ice_sublim !ice sublimation (cell-ave value) + real(r8), dimension(mgncol), intent(out) :: berg !bergeron enhancement (cell-ave value) + + !INTERNAL VARS: + !=============================================== + real(r8) :: ab + real(r8) :: epsi + real(r8) :: qiic + real(r8) :: niic + real(r8) :: lami + real(r8) :: n0i + real(r8) :: tx1 + integer :: i + + do i=1,mgncol + if (qi(i)>=qsmall) then + + !GET IN-CLOUD qi, ni + !=============================================== + tx1 = one / icldm(i) + qiic = qi(i) * tx1 + niic = ni(i) * tx1 + + !Compute linearized condensational heating correction + ab = calc_ab(t(i), qvi(i), xxls) + !Get slope and intercept of gamma distn for ice. + call size_dist_param_basic(mg_ice_props, qiic, niic, lami, n0i) + !Get depletion timescale=1/eps + epsi = (pi+pi)*n0i*rho(i)*Dv(i)/(lami*lami) + + !Compute deposition/sublimation + vap_dep(i) = epsi/ab*(qv(i) - qvi(i)) + + !Make this a grid-averaged quantity + vap_dep(i) = vap_dep(i)*icldm(i) + + !Split into deposition or sublimation. + if (t(i) < tmelt .and. vap_dep(i) > zero) then + ice_sublim(i) = zero + else + ! make ice_sublim negative for consistency with other evap/sub processes + ice_sublim(i) = min(vap_dep(i), zero) + vap_dep(i) = zero + end if + + !sublimation occurs @ any T. Not so for berg. + if (t(i) < tmelt) then + + !Compute bergeron rate assuming cloud for whole step. + berg(i) = max(epsi/ab*(qvl(i) - qvi(i)), zero) + else !T>frz + berg(i) = zero + end if !Tqsmall + enddo +end subroutine ice_deposition_sublimation + +!======================================================================== +! autoconversion of cloud liquid water to rain +! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc +! minimum qc of 1 x 10^-8 prevents floating point error + +subroutine kk2000_liq_autoconversion(microp_uniform, qcic, & + ncic, rho, relvar, prc, nprc, nprc1, mgncol) + + integer, intent(in) :: mgncol + logical, intent(in) :: microp_uniform + + real(r8), dimension(mgncol), intent(in) :: qcic + real(r8), dimension(mgncol), intent(in) :: ncic + real(r8), dimension(mgncol), intent(in) :: rho + + real(r8), dimension(mgncol), intent(in) :: relvar + + real(r8), dimension(mgncol), intent(out) :: prc + real(r8), dimension(mgncol), intent(out) :: nprc + real(r8), dimension(mgncol), intent(out) :: nprc1 + + real(r8), dimension(mgncol) :: prc_coef + integer :: i + + ! Take variance into account, or use uniform value. + if (.not. microp_uniform) then + prc_coef(:) = var_coef(relvar(:), 2.47_r8) + else + prc_coef(:) = one + end if + + do i=1,mgncol + if (qcic(i) >= icsmall) then + + ! nprc is increase in rain number conc due to autoconversion + ! nprc1 is decrease in cloud droplet conc due to autoconversion + + ! assume exponential sub-grid distribution of qc, resulting in additional + ! factor related to qcvar below + ! switch for sub-columns, don't include sub-grid qc + + prc(i) = prc_coef(i) * & + 1350._r8 * qcic(i)**2.47_r8 * (ncic(i)*1.e-6_r8*rho(i))**(-1.79_r8) + nprc(i) = prc(i) * (one/droplet_mass_25um) + nprc1(i) = prc(i)*ncic(i)/qcic(i) + + else + prc(i) = zero + nprc(i) = zero + nprc1(i) = zero + end if + enddo +end subroutine kk2000_liq_autoconversion + + !======================================================================== +subroutine sb2001v2_liq_autoconversion(pgam,qc,nc,qr,rho,relvar,au,nprc,nprc1,mgncol) + ! + ! --------------------------------------------------------------------- + ! AUTO_SB: calculates the evolution of mass- and number mxg-ratio for + ! drizzle drops due to autoconversion. The autoconversion rate assumes + ! f(x)=A*x**(nu_c)*exp(-Bx) in drop MASS x. + + ! Code from Hugh Morrison, Sept 2014 + + ! autoconversion + ! use simple lookup table of dnu values to get mass spectral shape parameter + ! equivalent to the size spectral shape parameter pgam + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent (in) :: pgam + real(r8), dimension(mgncol), intent (in) :: qc ! = qc (cld water mixing ratio) + real(r8), dimension(mgncol), intent (in) :: nc ! = nc (cld water number conc /kg) + real(r8), dimension(mgncol), intent (in) :: qr ! = qr (rain water mixing ratio) + real(r8), dimension(mgncol), intent (in) :: rho ! = rho : density profile + real(r8), dimension(mgncol), intent (in) :: relvar + + real(r8), dimension(mgncol), intent (out) :: au ! = prc autoconversion rate + real(r8), dimension(mgncol), intent (out) :: nprc1 ! = number tendency + real(r8), dimension(mgncol), intent (out) :: nprc ! = number tendency fixed size for rain + + ! parameters for droplet mass spectral shape, + ! used by Seifert and Beheng (2001) + ! warm rain scheme only (iparam = 1) + real(r8), parameter :: dnu(16) = [0._r8,-0.557_r8,-0.430_r8,-0.307_r8, & + -0.186_r8,-0.067_r8,0.050_r8,0.167_r8,0.282_r8,0.397_r8,0.512_r8, & + 0.626_r8,0.739_r8,0.853_r8,0.966_r8,0.966_r8] + + ! parameters for Seifert and Beheng (2001) autoconversion/accretion + real(r8), parameter :: kc = 9.44e9_r8 + real(r8), parameter :: kr = 5.78e3_r8 + real(r8), parameter :: auf = kc / (20._r8*2.6e-7_r8) * 1000._r8 + real(r8) :: dum, dum1, nu, pra_coef, tx1, tx2, tx3, tx4 + integer :: dumi, i + + do i=1,mgncol + + pra_coef = var_coef(relvar(i), 2.47_r8) + if (qc(i) > qsmall) then + dumi = int(pgam(i)) + nu = dnu(dumi) + (dnu(dumi+1)-dnu(dumi))* (pgam(i)-dumi) + + !Anning fixed a bug here for FV3GFS 10/13/2017 + dum = max(one-qc(i)/(qc(i)+qr(i)), zero) + tx1 = dum**0.68_r8 + tx2 = one - tx1 + dum1 = 600._r8 * tx1 * tx2 * tx2 * tx2 ! Moorthi +! dum1 = 600._r8*dum**0.68_r8*(one-dum**0.68_r8)**3 + + tx1 = nu + one + tx2 = 0.001_r8 * rho(i) * qc(i) + tx3 = tx2 * tx2 / (rho(i)*nc(i)*1.e-6_r8) + tx2 = tx3 * tx3 + tx3 = one - dum + au(i) = auf * (nu+two) * (nu+four) * tx2 & + * (one+dum1/(tx3*tx3)) / (tx1*tx1*rho(i)) + +! au(i) = kc/(20._r8*2.6e-7_r8)* & +! (nu+2._r8)*(nu+4._r8)/(nu+1._r8)**2._r8* & +! (rho(i)*qc(i)/1000._r8)**4._r8/(rho(i)*nc(i)/1.e6_r8)**2._r8* & +! (1._r8+dum1/(1._r8-dum)**2)*1000._r8 / rho(i) + + nprc1(i) = au(i) * two / 2.6e-7_r8 * 1000._r8 + nprc(i) = au(i) / droplet_mass_40um + else + au(i) = zero + nprc1(i) = zero + nprc(i) = zero + end if + + enddo + + end subroutine sb2001v2_liq_autoconversion + +!======================================================================== +! Anning Cheng 10/5/2017 add Liu et al. autoconversion + subroutine liu_liq_autoconversion(pgam,qc,nc,qr,rho,relvar, & + au,nprc,nprc1,mgncol) + + + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent (in) :: pgam + real(r8), dimension(mgncol), intent (in) :: qc + real(r8), dimension(mgncol), intent (in) :: nc + real(r8), dimension(mgncol), intent (in) :: qr + real(r8), dimension(mgncol), intent (in) :: rho + real(r8), dimension(mgncol), intent (in) :: relvar + + real(r8), dimension(mgncol), intent (out) :: au + real(r8), dimension(mgncol), intent (out) :: nprc1 + real(r8), dimension(mgncol), intent (out) :: nprc + real(r8) :: xs,lw, nw, beta6 + real(r8), parameter :: dcrit=1.0e-6, miu_disp=1. + integer :: i + + do i=1,mgncol + if (qc(i) > qsmall) then + xs = 1. / (1.+pgam(i)) + beta6 = (1.+3.0*xs)*(1.+4.0*xs)*(1.+5.0*xs) & + / ((1.+xs)*(1.+xs+xs)) + LW = 1.0e-3_r8 * qc(i) * rho(i) + NW = nc(i) * rho(i) * 1.e-6_r8 + + xs = min(20.0, 1.03e16*(LW*LW)/(NW*SQRT(NW))) + au(i) = 1.1e10*beta6*LW*LW*LW & + * (1.-exp(-(xs**miu_disp))) / NW + au(i) = au(i)*1.0e3/rho(i) + au(i) = au(i) * gamma(2.+relvar(i)) & + / (gamma(relvar(i))*(relvar(i)*relvar(i))) + + au(i) = au(i)*dcrit + nprc1(i)= au(i) * two/2.6e-7_r8*1000._r8 + nprc(i) = au(i) / droplet_mass_40um + else + au(i) = zero + nprc1(i) = zero + nprc(i) = zero + end if + enddo + + end subroutine liu_liq_autoconversion + + +!======================================================================== +!SB2001 Accretion V2 + +subroutine sb2001v2_accre_cld_water_rain(qc,nc,qr,rho,relvar,pra,npra,mgncol) + ! + ! --------------------------------------------------------------------- + ! ACCR_SB calculates the evolution of mass mxng-ratio due to accretion + ! and self collection following Seifert & Beheng (2001). + ! + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent (in) :: qc ! = qc (cld water mixing ratio) + real(r8), dimension(mgncol), intent (in) :: nc ! = nc (cld water number conc /kg) + real(r8), dimension(mgncol), intent (in) :: qr ! = qr (rain water mixing ratio) + real(r8), dimension(mgncol), intent (in) :: rho ! = rho : density profile + real(r8), dimension(mgncol), intent (in) :: relvar + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pra ! MMR + real(r8), dimension(mgncol), intent(out) :: npra ! Number + + ! parameters for Seifert and Beheng (2001) autoconversion/accretion + real(r8), parameter :: kc = 9.44e9_r8 + real(r8), parameter :: kr = 5.78e3_r8 + + real(r8) :: dum, dum1, tx1, tx2 + integer :: i + + ! accretion + + do i =1,mgncol + + if (qc(i) > qsmall) then + dum = one - qc(i)/(qc(i)+qr(i)) + tx1 = dum / (dum+5.e-4_r8) + dum1 = tx1 * tx1 + dum1 = dum1 * dum1 + pra(i) = kr*rho(i)*0.001_r8*qc(i)*qr(i)*dum1 + + npra(i) = pra(i) * nc(i) / qc(i) + +! npra(i) = pra(i)*rho(i)*0.001_r8*(nc(i)*rho(i)*1.e-6_r8)/ & +! (qc(i)*rho(i)*0.001_r8)*1.e6_r8 / rho(i) + else + pra(i) = zero + npra(i) = zero + end if + + enddo + + end subroutine sb2001v2_accre_cld_water_rain + +!======================================================================== +! Autoconversion of cloud ice to snow +! similar to Ferrier (1994) + +subroutine ice_autoconversion(t, qiic, lami, n0i, dcs, ac_time, prci, nprci, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t + real(r8), dimension(mgncol), intent(in) :: qiic + real(r8), dimension(mgncol), intent(in) :: lami + real(r8), dimension(mgncol), intent(in) :: n0i + real(r8), intent(in) :: dcs + real(r8), intent(in) :: ac_time + + real(r8), dimension(mgncol), intent(out) :: prci + real(r8), dimension(mgncol), intent(out) :: nprci + + ! Assume autoconversion timescale of 180 seconds. + + ! Average mass of an ice particle. + real(r8) :: m_ip + ! Ratio of autoconversion diameter to average diameter. + real(r8) :: d_rat + integer :: i + + do i=1,mgncol + if (t(i) <= tmelt .and. qiic(i) >= qsmall) then + + d_rat = lami(i)*dcs + + ! Rate of ice particle conversion (number). + nprci(i) = n0i(i)/(lami(i)*ac_time)*exp(-d_rat) + + m_ip = rhoi * pio6 / (lami(i)*lami(i)*lami(i)) + +! m_ip = (rhoi*pi/6._r8) / lami(i)**3 + + ! Rate of mass conversion. + ! Note that this is: + ! m n (d^3 + 3 d^2 + 6 d + 6) + prci(i) = m_ip * nprci(i) * & + (((d_rat + three)*d_rat + six)*d_rat + six) + + else + prci(i) = zero + nprci(i) = zero + end if + enddo +end subroutine ice_autoconversion +!=================================== +! Anning Cheng 10/5/2017 added GMAO ice autoconversion +subroutine gmao_ice_autoconversion(t, qiic, niic, lami, & + n0i, dcs, ac_time, prci, nprci, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t + real(r8), dimension(mgncol), intent(in) :: qiic + real(r8), dimension(mgncol), intent(in) :: niic + real(r8), dimension(mgncol), intent(in) :: lami + real(r8), dimension(mgncol), intent(in) :: n0i + real(r8), intent(in) :: ac_time + real(r8), intent(in) :: dcs + + real(r8), dimension(mgncol), intent(out) :: prci + real(r8), dimension(mgncol), intent(out) :: nprci + + + real(r8) :: m_ip, tx1 + integer :: i + do i=1,mgncol + if (t(i) <= tmelt .and. qiic(i) >= qsmall) then + m_ip = max(min(0.008_r8*(lami(i)*0.01)**0.87_r8, & + 10.0_r8), 0.1_r8) + tx1 = lami(i)*dcs + nprci(i) = (niic(i)/ac_time) & + * (1. - gamma_incomp(m_ip, tx1)) + + prci(i) = (qiic(i)/ac_time) & + * (1. - gamma_incomp(m_ip+3., tx1)) + else + prci(i) = zero + nprci(i) = zero + end if + enddo +end subroutine gmao_ice_autoconversion +!=================================== +! immersion freezing (Bigg, 1953) +!=================================== + +subroutine immersion_freezing(microp_uniform, t, pgam, lamc, & + qcic, ncic, relvar, mnuccc, nnuccc, mgncol) + + integer, intent(in) :: mgncol + logical, intent(in) :: microp_uniform + + ! Temperature + real(r8), dimension(mgncol), intent(in) :: t + + ! Cloud droplet size distribution parameters + real(r8), dimension(mgncol), intent(in) :: pgam + real(r8), dimension(mgncol), intent(in) :: lamc + + ! MMR and number concentration of in-cloud liquid water + real(r8), dimension(mgncol), intent(in) :: qcic + real(r8), dimension(mgncol), intent(in) :: ncic + + ! Relative variance of cloud water + real(r8), dimension(mgncol), intent(in) :: relvar + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: mnuccc ! MMR + real(r8), dimension(mgncol), intent(out) :: nnuccc ! Number + + ! Coefficients that will be omitted for sub-columns + real(r8), dimension(mgncol) :: dum + real(r8) :: tx1 + integer :: i + + if (.not. microp_uniform) then + dum(:) = var_coef(relvar, 2) + else + dum(:) = one + end if + do i=1,mgncol + + if (qcic(i) >= qsmall .and. t(i) < 269.15_r8) then + + tx1 = one / (lamc(i) * lamc(i) * lamc(i)) + nnuccc(i) = pio6*ncic(i)*rising_factorial(pgam(i)+one, 3) * & + bimm*(exp(aimm*(tmelt - t(i)))-one) * tx1 + + mnuccc(i) = dum(i) * nnuccc(i) * pio6 * rhow * & + rising_factorial(pgam(i)+four, 3) * tx1 + + else + mnuccc(i) = zero + nnuccc(i) = zero + end if ! qcic > qsmall and t < 4 deg C + enddo + +end subroutine immersion_freezing + +! contact freezing (-40= qsmall .and. t(i) < 269.15_r8) then + + if (.not. microp_uniform) then + dum = var_coef(relvar(i), four/three) + dum1 = var_coef(relvar(i), oneo3) + else + dum = one + dum1 = one + endif + + tcnt=(270.16_r8-t(i))**1.3_r8 + viscosity = 1.8e-5_r8*(t(i)/298.0_r8)**0.85_r8 ! Viscosity (kg/m/s) + mfp = two*viscosity/ & ! Mean free path (m) + (p(i)*sqrt( 8.0_r8*28.96e-3_r8/(pi*8.314409_r8*t(i)) )) + + ! Note that these two are vectors. + nslip = one+(mfp/rndst(i,:))*(1.257_r8+(0.4_r8*exp(-(1.1_r8*rndst(i,:)/mfp))))! Slip correction factor + + ndfaer = 1.381e-23_r8*t(i)*nslip/(6._r8*pi*viscosity*rndst(i,:)) ! aerosol diffusivity (m2/s) + + tx1 = one / lamc(i) + contact_factor = dot_product(ndfaer,nacon(i,:)*tcnt) * pi * & + ncic(i) * (pgam(i) + one) * tx1 + + mnucct(i) = dum * contact_factor * & + pio3*rhow*rising_factorial(pgam(i)+two, 3) * tx1 * tx1 *tx1 + + nnucct(i) = dum1 * two * contact_factor + + else + + mnucct(i) = zero + nnucct(i) = zero + + end if ! qcic > qsmall and t < 4 deg C + end do + +end subroutine contact_freezing + +! snow self-aggregation from passarelli, 1978, used by reisner, 1998 +!=================================================================== +! this is hard-wired for bs = 0.4 for now +! ignore self-collection of cloud ice + +subroutine snow_self_aggregation(t, rho, asn, rhosn, qsic, nsic, nsagg, mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + real(r8), dimension(mgncol), intent(in) :: rho ! Density + real(r8), dimension(mgncol), intent(in) :: asn ! fall speed parameter for snow + real(r8), intent(in) :: rhosn ! density of snow + + ! In-cloud snow + real(r8), dimension(mgncol), intent(in) :: qsic ! MMR + real(r8), dimension(mgncol), intent(in) :: nsic ! Number + + ! Output number tendency + real(r8), dimension(mgncol), intent(out) :: nsagg + + integer :: i + + do i=1,mgncol + if (qsic(i) >= qsmall .and. t(i) <= tmelt) then + nsagg(i) = -1108._r8*eii/(four*720._r8*rhosn)*asn(i)*qsic(i)*nsic(i)*rho(i)*& + ((qsic(i)/nsic(i))*(one/(rhosn*pi)))**((bs-one)*oneo3) + else + nsagg(i) = zero + end if + enddo +end subroutine snow_self_aggregation + +! accretion of cloud droplets onto snow/graupel +!=================================================================== +! here use continuous collection equation with +! simple gravitational collection kernel +! ignore collisions between droplets/cloud ice +! since minimum size ice particle for accretion is 50 - 150 micron + +subroutine accrete_cloud_water_snow(t, rho, asn, uns, mu, qcic, ncic, qsic, & + pgam, lamc, lams, n0s, psacws, npsacws, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + real(r8), dimension(mgncol), intent(in) :: rho ! Density + real(r8), dimension(mgncol), intent(in) :: asn ! Fallspeed parameter (snow) + real(r8), dimension(mgncol), intent(in) :: uns ! Current fallspeed (snow) + real(r8), dimension(mgncol), intent(in) :: mu ! Viscosity + + ! In-cloud liquid water + real(r8), dimension(mgncol), intent(in) :: qcic ! MMR + real(r8), dimension(mgncol), intent(in) :: ncic ! Number + + ! In-cloud snow + real(r8), dimension(mgncol), intent(in) :: qsic ! MMR + + ! Cloud droplet size parameters + real(r8), dimension(mgncol), intent(in) :: pgam + real(r8), dimension(mgncol), intent(in) :: lamc + + ! Snow size parameters + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: psacws ! Mass mixing ratio + real(r8), dimension(mgncol), intent(out) :: npsacws ! Number concentration + + real(r8) :: dc0 ! Provisional mean droplet size + real(r8) :: dum + real(r8) :: eci ! collection efficiency for riming of snow by droplets + + ! Fraction of cloud droplets accreted per second + real(r8) :: accrete_rate + integer :: i + + ! ignore collision of snow with droplets above freezing + + do i=1,mgncol + if (qsic(i) >= qsmall .and. t(i) <= tmelt .and. qcic(i) >= qsmall) then + + ! put in size dependent collection efficiency + ! mean diameter of snow is area-weighted, since + ! accretion is function of crystal geometric area + ! collection efficiency is approximation based on stoke's law (Thompson et al. 2004) + + dc0 = (pgam(i)+one)/lamc(i) + dum = dc0*dc0*uns(i)*rhow*lams(i)/(9._r8*mu(i)) + eci = dum*dum / ((dum+0.4_r8)*(dum+0.4_r8)) + + eci = max(eci,zero) + eci = min(eci,one) + + ! no impact of sub-grid distribution of qc since psacws + ! is linear in qc + accrete_rate = (pi/four)*asn(i)*rho(i)*n0s(i)*eci*gamma_bs_plus3 / lams(i)**(bs+three) + psacws(i) = accrete_rate*qcic(i) + npsacws(i) = accrete_rate*ncic(i) + else + psacws(i) = zero + npsacws(i) = zero + end if + enddo +end subroutine accrete_cloud_water_snow + +! add secondary ice production due to accretion of droplets by snow +!=================================================================== +! (Hallet-Mossop process) (from Cotton et al., 1986) + +subroutine secondary_ice_production(t, psacws, msacwi, nsacwi, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + + ! Accretion of cloud water to snow tendencies + real(r8), dimension(mgncol), intent(inout) :: psacws ! MMR + + ! Output (ice) tendencies + real(r8), dimension(mgncol), intent(out) :: msacwi ! MMR + real(r8), dimension(mgncol), intent(out) :: nsacwi ! Number + integer :: i + + do i=1,mgncol + if((t(i) < 270.16_r8) .and. (t(i) >= 268.16_r8)) then + nsacwi(i) = 3.5e8_r8*(270.16_r8-t(i))/two*psacws(i) + else if((t(i) < 268.16_r8) .and. (t(i) >= 265.16_r8)) then + nsacwi(i) = 3.5e8_r8*(t(i)-265.16_r8)*oneo3*psacws(i) + else + nsacwi(i) = zero + endif + enddo + + do i=1,mgncol + msacwi(i) = min(nsacwi(i)*mi0, psacws(i)) + psacws(i) = psacws(i) - msacwi(i) + enddo +end subroutine secondary_ice_production + +! accretion of rain water by snow +!=================================================================== +! formula from ikawa and saito, 1991, used by reisner et al., 1998 + +subroutine accrete_rain_snow(t, rho, umr, ums, unr, uns, qric, qsic, & + lamr, n0r, lams, n0s, pracs, npracs, mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + real(r8), dimension(mgncol), intent(in) :: rho ! Density + + ! Fallspeeds + ! mass-weighted + real(r8), dimension(mgncol), intent(in) :: umr ! rain + real(r8), dimension(mgncol), intent(in) :: ums ! snow + ! number-weighted + real(r8), dimension(mgncol), intent(in) :: unr ! rain + real(r8), dimension(mgncol), intent(in) :: uns ! snow + + ! In cloud MMRs + real(r8), dimension(mgncol), intent(in) :: qric ! rain + real(r8), dimension(mgncol), intent(in) :: qsic ! snow + + ! Size distribution parameters + ! rain + real(r8), dimension(mgncol), intent(in) :: lamr + real(r8), dimension(mgncol), intent(in) :: n0r + ! snow + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pracs ! MMR + real(r8), dimension(mgncol), intent(out) :: npracs ! Number + + ! Collection efficiency for accretion of rain by snow + real(r8), parameter :: ecr = one + + ! Ratio of average snow diameter to average rain diameter. + real(r8) :: d_rat + ! Common factor between mass and number expressions + real(r8) :: common_factor + real(r8) :: tx1 + integer :: i + + do i=1,mgncol + if (qric(i) >= icsmall .and. qsic(i) >= icsmall .and. t(i) <= tmelt) then + + common_factor = pi*ecr*rho(i)*n0r(i)*n0s(i)/(lamr(i)**3 * lams(i)) + + d_rat = lamr(i)/lams(i) + + tx1 = 1.2_r8*umr(i)-0.95_r8*ums(i) + pracs(i) = common_factor*pi*rhow* & + sqrt(tx1*tx1 + 0.08_r8*ums(i)*umr(i)) / (lamr(i)*lamr(i)*lamr(i)) * & + ((half*d_rat + two)*d_rat + five) + + tx1 = unr(i)-uns(i) + npracs(i) = common_factor*half * & + sqrt(1.7_r8*tx1*tx1 + 0.3_r8*unr(i)*uns(i)) * & + ((d_rat + one)*d_rat + one) + + else + pracs(i) = zero + npracs(i) = zero + end if + enddo +end subroutine accrete_rain_snow + +! heterogeneous freezing of rain drops +!=================================================================== +! follows from Bigg (1953) + +subroutine heterogeneous_rain_freezing(t, qric, nric, lamr, mnuccr, nnuccr, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + + ! In-cloud rain + real(r8), dimension(mgncol), intent(in) :: qric ! MMR + real(r8), dimension(mgncol), intent(in) :: nric ! Number + real(r8), dimension(mgncol), intent(in) :: lamr ! size parameter + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: mnuccr ! MMR + real(r8), dimension(mgncol), intent(out) :: nnuccr ! Number + real(r8) :: tx1 + integer :: i + + do i=1,mgncol + + if (t(i) < 269.15_r8 .and. qric(i) >= qsmall) then + tx1 = pi / (lamr(i)*lamr(i)*lamr(i)) + nnuccr(i) = nric(i)*bimm* (exp(aimm*(tmelt - t(i)))-one) * tx1 + + mnuccr(i) = nnuccr(i) * 20._r8*rhow * tx1 + + else + mnuccr(i) = zero + nnuccr(i) = zero + end if + enddo +end subroutine heterogeneous_rain_freezing + +! accretion of cloud liquid water by rain +!=================================================================== +! formula from Khrouditnov and Kogan (2000) +! gravitational collection kernel, droplet fall speed neglected + +subroutine accrete_cloud_water_rain(microp_uniform, qric, qcic, & + ncic, relvar, accre_enhan, pra, npra, mgncol) + + logical, intent(in) :: microp_uniform + integer, intent(in) :: mgncol + ! In-cloud rain + real(r8), dimension(mgncol), intent(in) :: qric ! MMR + + ! Cloud droplets + real(r8), dimension(mgncol), intent(in) :: qcic ! MMR + real(r8), dimension(mgncol), intent(in) :: ncic ! Number + + ! SGS variability + real(r8), dimension(mgncol), intent(in) :: relvar + real(r8), dimension(mgncol), intent(in) :: accre_enhan + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pra ! MMR + real(r8), dimension(mgncol), intent(out) :: npra ! Number + + ! Coefficient that varies for subcolumns + real(r8), dimension(mgncol) :: pra_coef + + integer :: i + + if (.not. microp_uniform) then + pra_coef(:) = accre_enhan * var_coef(relvar(:), 1.15_r8) + else + pra_coef(:) = one + end if + + do i=1,mgncol + + if (qric(i) >= qsmall .and. qcic(i) >= qsmall) then + + ! include sub-grid distribution of cloud water + pra(i) = pra_coef(i) * 67._r8*(qcic(i)*qric(i))**1.15_r8 + + npra(i) = pra(i)*ncic(i)/qcic(i) + + else + pra(i) = zero + npra(i) = zero + end if + end do +end subroutine accrete_cloud_water_rain + +! Self-collection of rain drops +!=================================================================== +! from Beheng(1994) + +subroutine self_collection_rain(rho, qric, nric, nragg, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: rho ! Air density + + ! Rain + real(r8), dimension(mgncol), intent(in) :: qric ! MMR + real(r8), dimension(mgncol), intent(in) :: nric ! Number + + ! Output number tendency + real(r8), dimension(mgncol), intent(out) :: nragg + + integer :: i + + do i=1,mgncol + if (qric(i) >= qsmall) then + nragg(i) = -8._r8*nric(i)*qric(i)*rho(i) + else + nragg(i) = zero + end if + enddo +end subroutine self_collection_rain + + +! Accretion of cloud ice by snow +!=================================================================== +! For this calculation, it is assumed that the Vs >> Vi +! and Ds >> Di for continuous collection + +subroutine accrete_cloud_ice_snow(t, rho, asn, qiic, niic, qsic, & + lams, n0s, prai, nprai, mgncol) + + integer, intent(in) :: mgncol + real(r8), dimension(mgncol), intent(in) :: t ! Temperature + real(r8), dimension(mgncol), intent(in) :: rho ! Density + + real(r8), dimension(mgncol), intent(in) :: asn ! Snow fallspeed parameter + + ! Cloud ice + real(r8), dimension(mgncol), intent(in) :: qiic ! MMR + real(r8), dimension(mgncol), intent(in) :: niic ! Number + + real(r8), dimension(mgncol), intent(in) :: qsic ! Snow MMR + + ! Snow size parameters + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: prai ! MMR + real(r8), dimension(mgncol), intent(out) :: nprai ! Number + + ! Fraction of cloud ice particles accreted per second + real(r8) :: accrete_rate + + integer :: i + + do i=1,mgncol + if (qsic(i) >= qsmall .and. qiic(i) >= qsmall .and. t(i) <= tmelt) then + + accrete_rate = (pi/four) * eii * asn(i) * rho(i) * n0s(i) * gamma_bs_plus3 & + / lams(i)**(bs+three) + + prai(i) = accrete_rate * qiic(i) + nprai(i) = accrete_rate * niic(i) + + else + prai(i) = zero + nprai(i) = zero + end if + enddo +end subroutine accrete_cloud_ice_snow + +! calculate evaporation/sublimation of rain and snow +!=================================================================== +! note: evaporation/sublimation occurs only in cloud-free portion of grid cell +! in-cloud condensation/deposition of rain and snow is neglected +! except for transfer of cloud water to snow through bergeron process + +subroutine evaporate_sublimate_precip(t, rho, dv, mu, sc, q, qvl, qvi, & + lcldm, precip_frac, arn, asn, qcic, qiic, qric, qsic, lamr, n0r, lams, n0s, & + pre, prds, am_evp_st, mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t ! temperature + real(r8), dimension(mgncol), intent(in) :: rho ! air density + real(r8), dimension(mgncol), intent(in) :: dv ! water vapor diffusivity + real(r8), dimension(mgncol), intent(in) :: mu ! viscosity + real(r8), dimension(mgncol), intent(in) :: sc ! schmidt number + real(r8), dimension(mgncol), intent(in) :: q ! humidity + real(r8), dimension(mgncol), intent(in) :: qvl ! saturation humidity (water) + real(r8), dimension(mgncol), intent(in) :: qvi ! saturation humidity (ice) + real(r8), dimension(mgncol), intent(in) :: lcldm ! liquid cloud fraction + real(r8), dimension(mgncol), intent(in) :: precip_frac ! precipitation fraction (maximum overlap) + + ! fallspeed parameters + real(r8), dimension(mgncol), intent(in) :: arn ! rain + real(r8), dimension(mgncol), intent(in) :: asn ! snow + + ! In-cloud MMRs + real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid + real(r8), dimension(mgncol), intent(in) :: qiic ! cloud ice + real(r8), dimension(mgncol), intent(in) :: qric ! rain + real(r8), dimension(mgncol), intent(in) :: qsic ! snow + + ! Size parameters + ! rain + real(r8), dimension(mgncol), intent(in) :: lamr + real(r8), dimension(mgncol), intent(in) :: n0r + ! snow + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pre + real(r8), dimension(mgncol), intent(out) :: prds + real(r8), dimension(mgncol), intent(out) :: am_evp_st ! Fractional area where rain evaporates. + + real(r8) :: qclr ! water vapor mixing ratio in clear air + real(r8) :: ab ! correction to account for latent heat + real(r8) :: eps ! 1/ sat relaxation timescale + real(r8) :: tx1, tx2, tx3 + + real(r8), dimension(mgncol) :: dum + + integer :: i + + am_evp_st = 0._r8 + ! set temporary cloud fraction to zero if cloud water + ice is very small + ! this will ensure that evaporation/sublimation of precip occurs over + ! entire grid cell, since min cloud fraction is specified otherwise + do i=1,mgncol + if (qcic(i)+qiic(i) < 1.e-6_r8) then + dum(i) = zero + else + dum(i) = lcldm(i) + end if + enddo + do i=1,mgncol + ! only calculate if there is some precip fraction > cloud fraction + + if (precip_frac(i) > dum(i)) then + + if (qric(i) >= qsmall .or. qsic(i) >= qsmall) then + am_evp_st(i) = precip_frac(i) - dum(i) + + ! calculate q for out-of-cloud region + qclr = (q(i)-dum(i)*qvl(i)) / (one-dum(i)) + end if + + ! evaporation of rain + if (qric(i) >= qsmall) then + + ab = calc_ab(t(i), qvl(i), xxlv) + eps = two*pi*n0r(i)*rho(i)*Dv(i) * & + (f1r/(lamr(i)*lamr(i)) + & + f2r*sqrt(arn(i)*rho(i)/mu(i)) * & + sc(i)**oneo3*gamma_half_br_plus5 & + / (lamr(i)**((five+br)*half))) + + pre(i) = eps*(qclr-qvl(i)) / ab + + ! only evaporate in out-of-cloud region + ! and distribute across precip_frac + pre(i) = min(pre(i)*am_evp_st(i), zero) + pre(i) = pre(i) / precip_frac(i) + else + pre(i) = zero + end if + + ! sublimation of snow + if (qsic(i) >= qsmall) then + ab = calc_ab(t(i), qvi(i), xxls) + eps = two*pi*n0s(i)*rho(i)*Dv(i) * & + ( f1s/(lams(i)*lams(i)) & + + f2s*sqrt(asn(i)*rho(i)/mu(i)) * & + sc(i)**oneo3*gamma_half_bs_plus5 / & + (lams(i)**((five+bs)*half))) + prds(i) = eps*(qclr-qvi(i)) / ab + + ! only sublimate in out-of-cloud region and distribute over precip_frac + prds(i) = min(prds(i)*am_evp_st(i), zero) + prds(i) = prds(i) / precip_frac(i) + else + prds(i) = zero + end if + + else + prds(i) = zero + pre(i) = zero + end if + enddo + +end subroutine evaporate_sublimate_precip + +! bergeron process - evaporation of droplets and deposition onto snow +!=================================================================== + +subroutine bergeron_process_snow(t, rho, dv, mu, sc, qvl, qvi, asn, & + qcic, qsic, lams, n0s, bergs, mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t ! temperature + real(r8), dimension(mgncol), intent(in) :: rho ! air density + real(r8), dimension(mgncol), intent(in) :: dv ! water vapor diffusivity + real(r8), dimension(mgncol), intent(in) :: mu ! viscosity + real(r8), dimension(mgncol), intent(in) :: sc ! schmidt number + real(r8), dimension(mgncol), intent(in) :: qvl ! saturation humidity (water) + real(r8), dimension(mgncol), intent(in) :: qvi ! saturation humidity (ice) + + ! fallspeed parameter for snow + real(r8), dimension(mgncol), intent(in) :: asn + + ! In-cloud MMRs + real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid + real(r8), dimension(mgncol), intent(in) :: qsic ! snow + + ! Size parameters for snow + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: bergs + + real(r8) :: ab ! correction to account for latent heat + real(r8) :: eps ! 1/ sat relaxation timescale + + integer :: i + + do i=1,mgncol + if (qsic(i) >= qsmall.and. qcic(i) >= qsmall .and. t(i) < tmelt) then + ab = calc_ab(t(i), qvi(i), xxls) + eps = two*pi*n0s(i)*rho(i)*Dv(i) * & + (f1s/(lams(i)*lams(i)) + & + f2s*sqrt(asn(i)*rho(i)/mu(i)) * & + sc(i)**oneo3*gamma_half_bs_plus5 / & + (lams(i)**((five+bs)*half))) + bergs(i) = eps*(qvl(i)-qvi(i)) / ab + else + bergs(i) = zero + end if + enddo +end subroutine bergeron_process_snow + +!======================================================================== +!UTILITIES +!======================================================================== + +pure function no_limiter() + real(r8) :: no_limiter + + no_limiter = transfer(limiter_off, no_limiter) + +end function no_limiter + +pure function limiter_is_on(lim) + real(r8), intent(in) :: lim + logical :: limiter_is_on + + limiter_is_on = transfer(lim, limiter_off) /= limiter_off + +end function limiter_is_on + +FUNCTION gamma_incomp(muice, x) + + real(r8) :: gamma_incomp + REAL(r8), intent(in) :: muice, x + REAL(r8) :: xog, kg, alfa, auxx + alfa = min(max(muice+1., 1.), 20._r8) + + xog = log(alfa -0.3068_r8) + kg = 1.44818*(alfa**0.5357_r8) + auxx = max(min(kg*(log(x)-xog), 30._r8), -30._r8) + gamma_incomp = one / (one +exp(-auxx)) + gamma_incomp = max(gamma_incomp, 1.0e-20) + +END FUNCTION gamma_incomp + + +end module micro_mg_utils diff --git a/gfsphysics/physics/moninedmf.f b/gfsphysics/physics/moninedmf.f index 0a25d2d17..32838e9d0 100755 --- a/gfsphysics/physics/moninedmf.f +++ b/gfsphysics/physics/moninedmf.f @@ -1073,35 +1073,35 @@ subroutine moninedmf(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & !! Following Han et al. (2015) \cite han_et_al_2015 , turbulence dissipation contributes to the tendency of temperature in the following way. First, turbulence dissipation is calculated by equation 17 of Han et al. (2015) \cite han_et_al_2015 for the PBL and equation 16 for the surface layer. if(dspheat) then ! - do k = 1,km1 - do i = 1,im - diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k) -! diss(i,k) = dku(i,k)*shr2(i,k) + do k = 1,km1 + do i = 1,im + diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k) +! diss(i,k) = dku(i,k)*shr2(i,k) + enddo enddo - enddo ! ! add dissipative heating at the first model layer ! !> Next, the temperature tendency is updated following equation 14. - do i = 1,im - tem = govrth(i)*sflux(i) - tem1 = tem + stress(i)*spd1(i)/zl(i,1) - tem2 = 0.5 * (tem1+diss(i,1)) - tem2 = max(tem2, 0.) - ttend = tem2 / cp - tau(i,1) = tau(i,1)+0.5*ttend - enddo + do i = 1,im + tem = govrth(i)*sflux(i) + tem1 = tem + stress(i)*spd1(i)/zl(i,1) + tem2 = 0.5 * (tem1+diss(i,1)) + tem2 = max(tem2, 0.) + ttend = tem2 / cp + tau(i,1) = tau(i,1)+0.5*ttend + enddo ! ! add dissipative heating above the first model layer ! - do k = 2,km1 - do i = 1,im - tem = 0.5 * (diss(i,k-1)+diss(i,k)) - tem = max(tem, 0.) - ttend = tem / cp - tau(i,k) = tau(i,k) + 0.5*ttend + do k = 2,km1 + do i = 1,im + tem = 0.5 * (diss(i,k-1)+diss(i,k)) + tem = max(tem, 0.) + ttend = tem / cp + tau(i,k) = tau(i,k) + 0.5*ttend + enddo enddo - enddo ! endif ! diff --git a/gfsphysics/physics/moninshoc.f b/gfsphysics/physics/moninshoc.f index ca4c1a11e..d0d0b7dc3 100644 --- a/gfsphysics/physics/moninshoc.f +++ b/gfsphysics/physics/moninshoc.f @@ -40,14 +40,13 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, ! ! locals ! - integer i,iprt,is,k,kk,km1,kmpbl - integer kx1(im) + integer i,iprt,is,k,kk,km1,kmpbl,kp1 ! logical pblflg(im), sfcflg(im), flg(im) real(kind=kind_phys), dimension(im) :: evap, heat, phih, phim &, rbdn, rbup, sflux, z0, crb, zol, thermal - &, stress, beta, tx1, tx2 + &, stress, beta, tx1 ! real(kind=kind_phys), dimension(im,km) :: theta, thvx, zl, a1, ad real(kind=kind_phys), dimension(im,km-1):: xkzo, xkzmo, al, au @@ -57,18 +56,19 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, real(kind=kind_phys) zi(im,km+1), a2(im,km*(ntrac+1)) ! real(kind=kind_phys) dsdz2, dsdzq, dsdzt, dsig, dt2, rdt - &, dtodsd, dtodsu, rdz, tem, tem1, ptem + &, dtodsd, dtodsu, rdz, tem, tem1 &, ttend, utend, vtend, qtend &, spdk2, rbint, ri, zol1, robn, bvf2 ! - real(kind=kind_phys), parameter :: gravi=1.0/grav, zolcr=0.2, - & zolcru=-0.5, rimin=-100., sfcfrac=0.1, - & crbcon=0.25, crbmin=0.15, crbmax=0.35, - & qmin=1.e-8, zfmin=1.e-8, qlmin=1.e-12, - & aphi5=5., aphi16=16., f0=1.e-4 - &, cont=cp/grav, conq=hvap/grav,conw=1.0/grav - &, dkmin=0.0, dkmax=1000., xkzminv=0.3 - &, gocp=grav/cp, prmin=0.25, prmax=4.0 + real(kind=kind_phys), parameter :: gravi=1.0/grav, zolcr=0.2, + & zolcru=-0.5, rimin=-100., sfcfrac=0.1, + & crbcon=0.25, crbmin=0.15, crbmax=0.35, + & qmin=1.e-8, zfmin=1.e-8, qlmin=1.e-12, + & aphi5=5., aphi16=16., f0=1.e-4 + &, cont=cp/grav, conq=hvap/grav, conw=1.0/grav + &, dkmin=0.0, dkmax=1000. +! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 + &, gocp=grav/cp, prmin=0.25, prmax=4.0 &, vk=0.4, cfac=6.5 ! !----------------------------------------------------------------------- @@ -77,7 +77,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, ! if (ix < im) stop ! - if (lprnt) write(0,*)' in moninshoc tsea=',tsea(ipr) +! if (lprnt) write(0,*)' in moninshoc tsea=',tsea(ipr) dt2 = delt rdt = 1. / dt2 km1 = km - 1 @@ -102,31 +102,18 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, ! Setup backgrond diffision do i=1,im prnum(i,km) = 1.0 - kx1(i) = 1 tx1(i) = 1.0 / prsi(i,1) - tx2(i) = tx1(i) enddo do k = 1,km1 do i=1,im xkzo(i,k) = 0.0 xkzmo(i,k) = 0.0 if (k < kinver(i)) then -! vertical background diffusivity - ptem = prsi(i,k+1) * tx1(i) - tem1 = 1.0 - ptem - tem1 = tem1 * tem1 * 10.0 - xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) - -! vertical background diffusivity for momentum - if (ptem >= xkzm_s) then - xkzmo(i,k) = xkzm_m - kx1(i) = k + 1 - else - if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) - tem1 = 1.0 - prsi(i,k+1) * tx2(i) - tem1 = tem1 * tem1 * 5.0 - xkzmo(i,k) = xkzm_m * min(1.0, exp(-tem1)) - endif +! vertical background diffusivity for heat and momentum + tem1 = 1.0 - prsi(i,k+1) * tx1(i) + tem1 = min(1.0, exp(-tem1 * tem1 * 10.0)) + xkzo(i,k) = xkzm_h * tem1 + xkzmo(i,k) = xkzm_m * tem1 endif enddo enddo @@ -137,16 +124,16 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, ! ! diffusivity in the inversion layer is set to be xkzminv (m^2/s) ! - do k = 1,kmpbl - do i=1,im - if(zi(i,k+1) > 250.) then - tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 > 1.e-5) then - xkzo(i,k) = min(xkzo(i,k),xkzminv) - endif - endif - enddo - enddo +! do k = 1,kmpbl +! do i=1,im +! if(zi(i,k+1) > 250.) then +! tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) +! if(tem1 > 1.e-5) then +! xkzo(i,k) = min(xkzo(i,k),xkzminv) +! endif +! endif +! enddo +! enddo ! ! do i = 1,im @@ -170,6 +157,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, enddo enddo ! +! if (lprnt) write(0,*)' heat=',heat(ipr),' evap=',evap(ipr) do i = 1,im sflux(i) = heat(i) + evap(i)*fv*theta(i,1) if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. @@ -305,29 +293,30 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, ! compute Prandtl number above boundary layer ! do k = 1, km1 + kp1 = k + 1 do i=1,im if(k >= kpbl(i)) then rdz = rdzt(i,k) - tem = u1(i,k)-u1(i,k+1) - tem1 = v1(i,k)-v1(i,k+1) + tem = u1(i,k) - u1(i,kp1) + tem1 = v1(i,k) - v1(i,kp1) tem = (tem*tem + tem1*tem1) * rdz * rdz - bvf2 = (0.5*grav)*(thvx(i,k+1)-thvx(i,k))*rdz - & / (t1(i,k)+t1(i,k+1)) + bvf2 = (0.5*grav)*(thvx(i,kp1)-thvx(i,k))*rdz + & / (t1(i,k)+t1(i,kp1)) ri = max(bvf2/tem,rimin) if(ri < 0.) then ! unstable regime - prnum(i,k) = 1.0 + prnum(i,kp1) = 1.0 else - prnum(i,k) = min(1.0 + 2.1*ri, prmax) + prnum(i,kp1) = min(1.0 + 2.1*ri, prmax) endif elseif (k > 1) then - prnum(i,k) = prnum(i,1) + prnum(i,kp1) = prnum(i,1) endif ! -! prnum(i,k) = 1.0 - prnum(i,k) = max(prmin, min(prmax, prnum(i,k))) - tem = tkh(i,k+1) * prnum(i,k) +! prnum(i,kp1) = 1.0 + prnum(i,kp1) = max(prmin, min(prmax, prnum(i,kp1))) + tem = tkh(i,kp1) * prnum(i,kp1) dku(i,k) = max(min(tem+xkzmo(i,k), dkmax), xkzmo(i,k)) - dkt(i,k) = max(min(tkh(i,k+1)+xkzo(i,k), dkmax), xkzo(i,k)) + dkt(i,k) = max(min(tkh(i,kp1)+xkzo(i,k), dkmax), xkzo(i,k)) enddo enddo ! @@ -338,6 +327,8 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, a1(i,1) = t1(i,1) + beta(i) * heat(i) a2(i,1) = q1(i,1,1) + beta(i) * evap(i) enddo +! if (lprnt) write(0,*)' a1=',a1(ipr,1),' beta=',beta(ipr) +! &,' heat=',heat(ipr), ' t1=',t1(ipr,1) if(ntrac > 2) then do k = 2, ntrac-1 @@ -392,6 +383,8 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, ttend = (a1(i,k)-t1(i,k)) * rdt qtend = (a2(i,k)-q1(i,k,1)) * rdt tau(i,k) = tau(i,k) + ttend +! if(lprnt .and. i==ipr .and. k<11) write(0,*)' tau=',tau(ipr,k) +! &,' ttend=',ttend,' a1=',a1(ipr,k),' t1=',t1(ipr,k) 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 diff --git a/gfsphysics/physics/physcons.f90 b/gfsphysics/physics/physcons.f90 index 652188e3d..bc975ce3b 100644 --- a/gfsphysics/physics/physcons.f90 +++ b/gfsphysics/physics/physcons.f90 @@ -154,17 +154,20 @@ module physcons ! ! integer, parameter :: max_lon=16000, max_lat=8000, min_lon=192, min_lat=94 ! integer, parameter :: max_lon=5000, max_lat=2500, min_lon=192, min_lat=94 ! current opr - integer, parameter :: max_lon=5000, max_lat=2000, min_lon=192, min_lat=94 ! current opr +! integer, parameter :: max_lon=5000, max_lat=2000, min_lon=192, min_lat=94 ! current opr +! integer, parameter :: max_lon=8000, max_lat=4000, min_lon=192, min_lat=94 ! current opr ! real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9999 ! current opr - real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9999999 ! new +! real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9999999 ! new ! real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9900 + + real(kind=kind_phys), parameter:: rlapse = 0.65e-2 real(kind=kind_phys), parameter:: cb2mb = 10.0, pa2mb = 0.01 ! for wsm6 real(kind=kind_phys),parameter:: rhowater = 1000. ! density of water (kg/m^3) real(kind=kind_phys),parameter:: rhosnow = 100. ! density of snow (kg/m^3) real(kind=kind_phys),parameter:: rhoair = 1.28 ! density of air near surface (kg/m^3) - real(kind=kind_phys) :: dxmax, dxmin, dxinv + real(kind=kind_phys) :: dxmax, dxmin, dxinv, rhc_max !........................................! end module physcons ! diff --git a/gfsphysics/physics/radiation_clouds.f b/gfsphysics/physics/radiation_clouds.f index 6d24dffdf..0651cde98 100644 --- a/gfsphysics/physics/radiation_clouds.f +++ b/gfsphysics/physics/radiation_clouds.f @@ -140,6 +140,7 @@ ! convective cloud cover and water for radiation ! ! ! ! jul 2014 s. moorthi - merging with gfs version ! +! feb 2017 a. cheng - add odepth output, effective radius input ! ! ! !!!!! ========================================================== !!!!! !!!!! end descriptions !!!!! @@ -254,7 +255,7 @@ module module_radiation_clouds ! real (kind=kind_phys), parameter :: gfac=1.0e5/con_g & &, gord=con_g/con_rd !> number of fields in cloud array - integer, parameter, public :: NF_CLDS = 9 + integer, parameter, public :: NF_CLDS = 11 !> number of cloud vertical domains integer, parameter, public :: NK_CLDS = 3 @@ -501,6 +502,7 @@ subroutine progcld1 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk, IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & + & effrl,effri,effrr,effrs,effr_in, & & clouds,clds,mtop,mbot & ! --- outputs: & ) @@ -583,10 +585,11 @@ subroutine progcld1 & ! --- inputs integer, intent(in) :: IX, NLAY, NLP1 - logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2, effr_in real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov + & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, & + & effrl, effri, effrr, effrs real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk @@ -625,22 +628,41 @@ subroutine progcld1 & enddo ! clouds(:,:,:) = 0.0 - do k = 1, NLAY - do i = 1, IX - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron - tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) - clwf(i,k) = 0.0 + if(effr_in) then + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = effrl (i,k) + rei (i,k) = effri (i,k) + rer (i,k) = effrr (i,k) + res (i,k) = effrs (i,k) + tem2d (i,k) = min(1.0, max(0.0,(con_ttp-tlyr(i,k))*0.05)) + clwf(i,k) = 0.0 + enddo enddo - enddo + else + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron + tem2d (i,k) = min(1.0, max(0.0, (con_ttp-tlyr(i,k))*0.05)) + clwf(i,k) = 0.0 + enddo + enddo + endif ! if ( lcrick ) then do i = 1, IX @@ -699,13 +721,15 @@ subroutine progcld1 & !> -# Compute effective liquid cloud droplet radius over land. - do i = 1, IX - if (nint(slmsk(i)) == 1) then - do k = 1, NLAY - rew(i,k) = 5.0 + 5.0 * tem2d(i,k) - enddo - endif - enddo + if(.not. effr_in) then + do i = 1, IX + if (nint(slmsk(i)) == 1) then + do k = 1, NLAY + rew(i,k) = 5.0 + 5.0 * tem2d(i,k) + enddo + endif + enddo + endif if (uni_cld) then ! use unified sgs clouds generated outside do k = 1, NLAY @@ -852,29 +876,31 @@ subroutine progcld1 & !> -# Compute effective ice cloud droplet radius following Heymsfield !! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. - do k = 1, NLAY - do i = 1, IX - tem2 = tlyr(i,k) - con_ttp - - if (cip(i,k) > 0.0) then - tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) - - if (tem2 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + if(.not.effr_in) then + do k = 1, NLAY + do i = 1, IX + tem2 = tlyr(i,k) - con_ttp + + if (cip(i,k) > 0.0) then + tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) + + if (tem2 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif +! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) + rei(i,k) = max(10.0, min(rei(i,k), 150.0)) +! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) endif -! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) - rei(i,k) = max(10.0, min(rei(i,k), 150.0)) -! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) - endif + enddo enddo - enddo + endif ! do k = 1, NLAY @@ -887,7 +913,7 @@ subroutine progcld1 & ! clouds(i,k,6) = 0.0 clouds(i,k,7) = rer(i,k) ! clouds(i,k,8) = 0.0 - clouds(i,k,9) = rei(i,k) + clouds(i,k,9) = res(i,k) enddo enddo @@ -1389,7 +1415,7 @@ subroutine progcld2 & clouds(i,k,7) = rer(i,k) ! clouds(i,k,8) = csp(i,k) !ncar scheme clouds(i,k,8) = csp(i,k) * rsden(i,k) !fu's scheme - clouds(i,k,9) = rei(i,k) + clouds(i,k,9) = res(i,k) enddo enddo @@ -1820,7 +1846,7 @@ subroutine progcld3 & ! clouds(i,k,6) = 0.0 clouds(i,k,7) = rer(i,k) ! clouds(i,k,8) = 0.0 - clouds(i,k,9) = rei(i,k) + clouds(i,k,9) = res(i,k) enddo enddo @@ -2114,7 +2140,7 @@ subroutine progcld4 & ! clouds(i,k,6) = 0.0 clouds(i,k,7) = rer(i,k) ! clouds(i,k,8) = 0.0 - clouds(i,k,9) = rei(i,k) + clouds(i,k,9) = res(i,k) enddo enddo @@ -2147,7 +2173,7 @@ subroutine progcld4o & ! --- inputs: & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & & xlat,xlon,slmsk, & - & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & + & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & & IX, NLAY, NLP1, & ! --- outputs: & clouds,clds,mtop,mbot & @@ -2859,8 +2885,9 @@ end subroutine progcld5 !> @{ !----------------------------------- subroutine progclduni & - & ( plyr,plvl,tlyr,tvly,clw,ciw, & ! --- inputs: - & xlat,xlon,slmsk, IX, NLAY, NLP1, cldcov, & + & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: + & xlat,xlon,slmsk, IX, NLAY, NLP1, cldtot, & + & effrl,effri,effrr,effrs,effr_in, & & clouds,clds,mtop,mbot & ! --- outputs: & ) @@ -2892,14 +2919,20 @@ subroutine progclduni & ! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! ! tlyr (IX,NLAY) : model layer mean temperature in k ! ! tvly (IX,NLAY) : model layer virtual temperature in k ! -! clw (IX,NLAY) : layer cloud liquid water amount ! -! ciw (IX,NLAY) : layer cloud ice water amount ! +! ccnd (IX,NLAY) : layer cloud condensate amount ! +! ncnd : number of layer cloud condensate types ! ! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! ! range, otherwise see in-line comment ! ! xlon (IX) : grid longitude in radians (not used) ! ! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! +! cldtot : unified cloud fracrion from moist physics ! +! effrl (ix,nlay) : effective radius for liquid water ! +! effri (ix,nlay) : effective radius for ice water ! +! effrr (ix,nlay) : effective radius for rain water ! +! effrs (ix,nlay) : effective radius for snow water ! +! effr_in : logical - if .true. use input effective radii ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -2935,10 +2968,12 @@ subroutine progclduni & implicit none ! --- inputs - integer, intent(in) :: IX, NLAY, NLP1 + integer, intent(in) :: IX, NLAY, NLP1, ncnd + logical, intent(in) :: effr_in - real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, clw, ciw, cldcov + real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr,& + & tlyr, tvly, cldtot, effrl, effri, effrr, effrs real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk @@ -2951,15 +2986,15 @@ subroutine progclduni & integer, dimension(:,:), intent(out) :: mtop,mbot ! --- local variables: - real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & - & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d -! & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d, clwf + real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, cwp, cip, & + & crp, csp, rew, rei, res, rer, delp, tem2d + real (kind=kind_phys), dimension(IX,NLAY,ncnd) :: cndf real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1) real (kind=kind_phys) :: tem1, tem2, tem3 - integer :: i, k, id, nf + integer :: i, k, id, nf, n ! !===> ... begin here @@ -2973,40 +3008,59 @@ subroutine progclduni & enddo ! clouds(:,:,:) = 0.0 - do k = 1, NLAY - do i = 1, IX - cldtot(i,k) = 0.0 - cldcnv(i,k) = 0.0 - cwp (i,k) = 0.0 - cip (i,k) = 0.0 - crp (i,k) = 0.0 - csp (i,k) = 0.0 - rew (i,k) = reliq_def ! default liq radius to 10 micron - rei (i,k) = reice_def ! default ice radius to 50 micron - rer (i,k) = rrain_def ! default rain radius to 1000 micron - res (i,k) = rsnow_def ! default snow radius to 250 micron - tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) -! clwf(i,k) = 0.0 + if (effr_in) then + do k = 1, NLAY + do i = 1, IX + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = effrl (i,k) + rei (i,k) = effri (i,k) + rer (i,k) = effrr (i,k) + res (i,k) = effrs (i,k) + tem2d (i,k) = min( 1.0, max( 0.0,(con_ttp-tlyr(i,k))*0.05)) + enddo enddo - enddo + else + do k = 1, NLAY + do i = 1, IX + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron + tem2d (i,k) = min(1.0, max(0.0, (con_ttp-tlyr(i,k))*0.05)) + enddo + enddo + endif ! -! if ( lcrick ) then -! do i = 1, IX -! clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) -! clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) -! enddo -! do k = 2, NLAY-1 -! do i = 1, IX -! clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) -! enddo -! enddo -! else -! do k = 1, NLAY -! do i = 1, IX -! clwf(i,k) = clw(i,k) -! enddo -! enddo -! endif + do n=1,ncnd + do k = 1, NLAY + do i = 1, IX + cndf(i,k,n) = ccnd(i,k,n) + enddo + enddo + enddo + if ( lcrick ) then + do n=1,ncnd + do i = 1, IX + cndf(i,1,n) = 0.75*ccnd(i,1,n) + 0.25*ccnd(i,2,n) + cndf(i,nlay,n) = 0.75*ccnd(i,nlay,n) + 0.25*ccnd(i,nlay-1,n) + enddo + do k = 2, NLAY-1 + do i = 1, IX + cndf(i,K,n) = 0.25 * (ccnd(i,k-1,n) + ccnd(i,k+1,n)) & + & + 0.5 * ccnd(i,k,n) + enddo + enddo + enddo + endif !> -# Find top pressure for each cloud domain for given latitude. ! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; @@ -3026,44 +3080,67 @@ subroutine progclduni & !> -# Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . if ( ivflip == 0 ) then ! input data from toa to sfc - do k = 1, NLAY - do i = 1, IX - delp(i,k) = plvl(i,k+1) - plvl(i,k) - tem1 = gfac * delp(i,k) - cip(i,k) = ciw(i,k) * tem1 - cwp(i,k) = clw(i,k) * tem1 + if (ncnd == 2) then + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k+1) - plvl(i,k) + tem1 = gfac * delp(i,k) + cwp(i,k) = cndf(i,k,1) * tem1 + cip(i,k) = cndf(i,k,2) * tem1 + enddo enddo - enddo + elseif (ncnd == 4 .or. ncnd == 5) then + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k+1) - plvl(i,k) + tem1 = gfac * delp(i,k) + cwp(i,k) = cndf(i,k,1) * tem1 + cip(i,k) = cndf(i,k,2) * tem1 + crp(i,k) = cndf(i,k,3) * tem1 + csp(i,k) = cndf(i,k,4) * tem1 + enddo + enddo + endif else ! input data from sfc to toa - do k = 1, NLAY - do i = 1, IX - delp(i,k) = plvl(i,k) - plvl(i,k+1) - tem1 = gfac * delp(i,k) - cip(i,k) = ciw(i,k) * tem1 - cwp(i,k) = clw(i,k) * tem1 + if (ncnd == 2) then + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k) - plvl(i,k+1) + tem1 = gfac * delp(i,k) + cwp(i,k) = cndf(i,k,1) * tem1 + cip(i,k) = cndf(i,k,2) * tem1 + enddo enddo - enddo + elseif (ncnd == 4 .or. ncnd == 5) then + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k) - plvl(i,k+1) + tem1 = gfac * delp(i,k) + cwp(i,k) = cndf(i,k,1) * tem1 + cip(i,k) = cndf(i,k,2) * tem1 + crp(i,k) = cndf(i,k,3) * tem1 + csp(i,k) = cndf(i,k,4) * tem1 + enddo + enddo + endif + endif ! end_if_ivflip !> -# Compute effective liquid cloud droplet radius over land. - do i = 1, IX - if (nint(slmsk(i)) == 1) then - do k = 1, NLAY - rew(i,k) = 5.0 + 5.0 * tem2d(i,k) - enddo - endif - enddo - do k = 1, NLAY + if(.not. effr_in) then do i = 1, IX - cldtot(i,k) = cldcov(i,k) + if (nint(slmsk(i)) == 1) then + do k = 1, NLAY + rew(i,k) = 5.0 + 5.0 * tem2d(i,k) + enddo + endif enddo - enddo + endif do k = 1, NLAY do i = 1, IX if (cldtot(i,k) < climit) then - cldtot(i,k) = 0.0 cwp(i,k) = 0.0 cip(i,k) = 0.0 crp(i,k) = 0.0 @@ -3089,29 +3166,31 @@ subroutine progclduni & !> -# Compute effective ice cloud droplet radius following Heymsfield !! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. - do k = 1, NLAY - do i = 1, IX - tem2 = tlyr(i,k) - con_ttp + if(.not. effr_in) then + do k = 1, NLAY + do i = 1, IX + tem2 = tlyr(i,k) - con_ttp - if (cip(i,k) > 0.0) then - tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) + if (cip(i,k) > 0.0) then + tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) - if (tem2 < -50.0) then - rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 - elseif (tem2 < -40.0) then - rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 - elseif (tem2 < -30.0) then - rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 - else - rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + if (tem2 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif +! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) + rei(i,k) = max(10.0, min(rei(i,k), 150.0)) +! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) endif -! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) -! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) - rei(i,k) = max(10.0, min(rei(i,k), 150.0)) -! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) - endif + enddo enddo - enddo + endif ! do k = 1, NLAY @@ -3121,10 +3200,10 @@ subroutine progclduni & clouds(i,k,3) = rew(i,k) clouds(i,k,4) = cip(i,k) clouds(i,k,5) = rei(i,k) -! clouds(i,k,6) = 0.0 + clouds(i,k,6) = crp(i,k) clouds(i,k,7) = rer(i,k) -! clouds(i,k,8) = 0.0 - clouds(i,k,9) = rei(i,k) + clouds(i,k,8) = csp(i,k) + clouds(i,k,9) = res(i,k) enddo enddo diff --git a/gfsphysics/physics/radlw_main.f b/gfsphysics/physics/radlw_main.f index e60a54a82..f4307d8b3 100644 --- a/gfsphysics/physics/radlw_main.f +++ b/gfsphysics/physics/radlw_main.f @@ -229,6 +229,8 @@ ! cloud-snow optical property scheme. ! ! nov 2012, yu-tai hou -- modified control parameters thru ! ! module 'physparam'. ! +! FEB 2017 A.Cheng - add odpth output, effective radius input ! +! ! ! ! !!!!! ============================================================== !!!!! !!!!! end descriptions !!!!! @@ -641,8 +643,8 @@ subroutine lwrad & real (kind=kind_phys), dimension(npts,nlay), intent(in) :: plyr, & & tlyr, qlyr, olyr - real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: gasvmr - real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: clouds + real (kind=kind_phys), dimension(npts,nlay,9), intent(in):: gasvmr + real (kind=kind_phys), dimension(npts,nlay,11) :: clouds real (kind=kind_phys), dimension(npts), intent(in) :: sfemis, & & sfgtmp @@ -1044,6 +1046,10 @@ subroutine lwrad & cldfmc = f_zero taucld = f_zero endif + do k = 1, nlay + clouds(iplon,k,11) = taucld(6,k) & + & + taucld(7,k) + taucld(8,k) + end do ! if (lprnt) then ! print *,' after cldprop' @@ -4672,8 +4678,8 @@ subroutine taugb05 jmo3p = jmo3 + 1 if (specparm < 0.125) then - p0 = fs - f_one - p40 = p0**4 + p0 = fs - f_one + p40 = p0**4 fk00 = p40 fk10 = f_one - p0 - 2.0*p40 fk20 = p0 + p40 @@ -4685,8 +4691,8 @@ subroutine taugb05 id200 = ind0 + 2 id210 = ind0 +11 elseif (specparm > 0.875) then - p0 = -fs - p40 = p0**4 + p0 = -fs + p40 = p0**4 fk00 = p40 fk10 = f_one - p0 - 2.0*p40 fk20 = p0 + p40 @@ -4718,8 +4724,8 @@ subroutine taugb05 fac210 = fk20 * fac10(k) if (specparm1 < 0.125) then - p1 = fs1 - f_one - p41 = p1**4 + p1 = fs1 - f_one + p41 = p1**4 fk01 = p41 fk11 = f_one - p1 - 2.0*p41 fk21 = p1 + p41 @@ -4731,8 +4737,8 @@ subroutine taugb05 id201 = ind1 + 2 id211 = ind1 +11 elseif (specparm1 > 0.875) then - p1 = -fs1 - p41 = p1**4 + p1 = -fs1 + p41 = p1**4 fk01 = p41 fk11 = f_one - p1 - 2.0*p41 fk21 = p1 + p41 diff --git a/gfsphysics/physics/radsw_main.f b/gfsphysics/physics/radsw_main.f index 6897c02de..f151e002b 100644 --- a/gfsphysics/physics/radsw_main.f +++ b/gfsphysics/physics/radsw_main.f @@ -402,6 +402,7 @@ !! This model is provided as is without any express or implied warranties. !! (http://www.rtweb.aer.com/) !! @{ +! FEB 2017 A.Cheng - add odpth output, effective radius input ! !========================================! module module_radsw_main ! !........................................! @@ -780,7 +781,7 @@ subroutine swrad & real (kind=kind_phys), dimension(npts,4), intent(in) :: sfcalb real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: gasvmr - real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: clouds + real (kind=kind_phys), dimension(npts,nlay,11):: clouds real (kind=kind_phys), dimension(npts,nlay,nbdsw,3),intent(in):: & & aerosols @@ -1149,7 +1150,9 @@ subroutine swrad & enddo enddo endif ! end if_zcf1_block - + do k = 1, nlay + clouds(j1,k,10) = taucw(k,10) + end do !> -# Call setcoef() to compute various coefficients needed in !! radiative transfer calculations. call setcoef & diff --git a/gfsphysics/physics/rascnvv2.f b/gfsphysics/physics/rascnvv2.f index 2dfccfc78..ce4dec6f1 100644 --- a/gfsphysics/physics/rascnvv2.f +++ b/gfsphysics/physics/rascnvv2.f @@ -1,8 +1,8 @@ module module_ras USE MACHINE , ONLY : kind_phys - use physcons, grav => con_g, cp => con_cp, alhl => con_hvap & - &, alhf => con_hfus, rgas => con_rd, rkap => con_rocp & - &, nu => con_FVirt, pi => con_pi + use physcons, grav => con_g, cp => con_cp, alhl => con_hvap& + &, alhf => con_hfus, rgas => con_rd, rkap => con_rocp& + &, nu => con_FVirt, pi => con_pi implicit none SAVE ! @@ -64,7 +64,7 @@ module module_ras ! ! PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=1.0E-2) PARAMETER (ALMIN1=0.00E-6, ALMIN2=0.00E-5, ALMAX=1.0E-2) -! PARAMETER (ALMIN1=0.00E-6, ALMIN2=4.00E-5, ALMAX=1.0E-2) +! PARAMETER (ALMIN1=1.00E-5, ALMIN2=2.00E-5, ALMAX=1.0E-2) !cnt PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=5.0E-3) ! ! real(kind=kind_phys), parameter :: BLDMAX = 200.0 @@ -240,7 +240,8 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & &, nrcm, rhc, ud_mf, dd_mf, det_mf, dlqfac & &, lprnt, ipr, kdt, revap & &, QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3 & - &, CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,ncld) + &, CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE, & + & mp_phys) ! &, lprnt, ipr, kdt, fscav, ctei_r, ctei_rm) ! !********************************************************************* @@ -268,7 +269,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! ! input ! - Integer IM, IX, k, ncrnd, me, trac, ipr, nrcm, ncld, kdt + Integer IM, IX, k, ncrnd, me, trac, ipr, nrcm, mp_phys, kdt integer, dimension(im) :: kbot, ktop, kcnv, kpbl, lmh ! real(kind=kind_phys), dimension(ix,k) :: tin, qin, uin, vin & @@ -335,7 +336,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & endif if (lprnt) write(0,*)' in RAS fscav=',fscav_,' ccwfac=', - & ccwfac(ipr),' ncld=',ncld + & ccwfac(ipr),' mp_phys=',mp_phys ! km1 = k - 1 kp1 = k + 1 @@ -362,7 +363,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & endif ! !!!!! initialization for microphysics ACheng - if(ncld == 2) then + if(mp_phys == 10) then do l=1,K do i=1,im QLCN(i,l) = 0.0 @@ -838,12 +839,12 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & det_mf(ipt,ll) = det_mf(ipt,ll) + flx(ib) ! Anning Cheng for microphysics 11/14/2015 - if (ncld == 2) then - if (lprint) write(0,*)' ib=',ib,' flx=',flx(ib),' ll=',ll - &,' ud_mf=',ud_mf(ipt,:) + if (mp_phys == 10) then +! if (lprint) write(0,*)' ib=',ib,' flx=',flx(ib),' ll=',ll +! &,' ud_mf=',ud_mf(ipt,:) CNV_MFD(ipt,ll) = CNV_MFD(ipt,ll) + flx(ib)/dt - if (lprint) write(0,*)' ib=',ib,' CNV_MFD=',CNV_MFD(ipt,ll) - &,' ll=',ll,' kp1=',kp1 +! if (lprint) write(0,*)' ib=',ib,' CNV_MFD=',CNV_MFD(ipt,ll) +! &,' ll=',ll,' kp1=',kp1 ! CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) ! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) + flx(ib)* @@ -888,7 +889,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & vin(ipt,ll) = uvi(l,trac+2) ! V momentum !! for 2M microphysics, always output these variables - if (ncld == 2) then + if (mp_phys == 10) then qli(l) = max(qli(l),0.) qii(l) = max(qii(l),0.) if (advcld) then @@ -1696,47 +1697,47 @@ SUBROUTINE CLOUD( & QOS = QOL(KD) QIS = CIL(KD) QLS = CLL(KD) + cnvflg = HBL > HSU .and. abs(tx1) > 1.0e-4 ! if (lprnt) print *,' ii=',ii,' cnvflg=',cnvflg,' hsu=',hsu ! &,' hbl=',hbl,' tx1=',tx1,' hsd=',hsd - !*********************************************************************** + ST1 = HALF*(HSU + HSD) - ST1 = HALF*(HSU + HSD) - IF (cnvflg) THEN + IF (cnvflg) THEN ! ! STANDARD CASE: ! CLOUD CAN BE NEUTRALLY BOUYANT AT MIDDLE OF LEVEL KD W/ +VE LAMBDA. ! EPP < .25 IS REQUIRED TO HAVE REAL ROOTS. ! - clp = 1.0 - st2 = hbl - hsu - -! if(lprnt) print *,' tx2=',tx2,' tx1=',tx1,' st2=',st2 -! - if (tx2 == 0.0) then - alm = - st2 / tx1 - if (alm > almax) alm = -100.0 - else - x00 = tx2 + tx2 - epp = tx1 * tx1 - (x00+x00)*st2 - if (epp > 0.0) then - x00 = 1.0 / x00 - tem = sqrt(epp) - tem1 = (-tx1-tem)*x00 - tem2 = (-tx1+tem)*x00 - if (tem1 > almax) tem1 = -100.0 - if (tem2 > almax) tem2 = -100.0 - alm = max(tem1,tem2) + clp = 1.0 + st2 = hbl - hsu + +! if(lprnt) print *,' tx2=',tx2,' tx1=',tx1,' st2=',st2 +! + if (tx2 == 0.0) then + alm = - st2 / tx1 + if (alm > almax) alm = -100.0 + else + x00 = tx2 + tx2 + epp = tx1 * tx1 - (x00+x00)*st2 + if (epp > 0.0) then + x00 = 1.0 / x00 + tem = sqrt(epp) + tem1 = (-tx1-tem)*x00 + tem2 = (-tx1+tem)*x00 + if (tem1 > almax) tem1 = -100.0 + if (tem2 > almax) tem2 = -100.0 + alm = max(tem1,tem2) ! if (lprnt) print *,' tem1=',tem1,' tem2=',tem2,' alm=',alm ! &,' tx1=',tx1,' tem=',tem,' epp=',epp,' x00=',x00,' st2=',st2 - endif - endif + endif + endif ! if (lprnt) print *,' almF=',alm,' ii=',ii,' qw00=',qw00 ! &,' qi00=',qi00 @@ -1745,11 +1746,11 @@ SUBROUTINE CLOUD( & ! NON-ENTRAINIG CLOUD DETRAINS IN LOWER HALF OF TOP LAYER. ! NO CLOUDS ARE ALLOWED TO DETRAIN BELOW THE TOP LAYER. ! - ELSEIF ( (HBL <= HSU) .AND. & - & (HBL > ST1 ) ) THEN - ALM = ZERO -! CLP = (HBL-ST1) / (HSU-ST1) ! commented on Jan 16, 2010 - ENDIF + ELSEIF ( (HBL <= HSU) .AND. & + & (HBL > ST1 ) ) THEN + ALM = ZERO +! CLP = (HBL-ST1) / (HSU-ST1) ! commented on Jan 16, 2010 + ENDIF ! cnvflg = .TRUE. IF (ALMIN1 > 0.0) THEN @@ -1757,7 +1758,7 @@ SUBROUTINE CLOUD( & ELSE LOWEST = KD == KB1 IF ( (ALM > ZERO) .OR. & - & (.NOT. LOWEST .AND. ALM == ZERO) ) cnvflg = .FALSE. + & (.NOT. LOWEST .AND. ALM == ZERO) ) cnvflg = .FALSE. ENDIF ! !===> IF NO SOUNDING MEETS SECOND CONDITION, RETURN @@ -1996,16 +1997,16 @@ SUBROUTINE CLOUD( & ! ST1 = 0.5 * (HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) ! & + HST(KD1) - LTL(KD1)*NU*(QST(KD1)-QOL(KD1))) ! - ST1 = HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) - ST2 = LTL(KD) * VTF(KD) + ST1 = HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) + ST2 = LTL(KD) * VTF(KD) TEM5 = (QLS + QIS) * eta(kd1) ST1 = HALF * (TX1-ETA(KD1)*ST1-ST2*(DET-TEM5))*DLB(KD) ! ! if (lprnt) print *,' st1=',st1,' st2=',st2,' ltl=',ltl(kd) ! *,ltl(kd1),' qos=',qos,qol(kd1) - WFN = WFN + ST1 - AKM = AKM - min(ST1,ZERO) ! Commented on 08/26/02 - does not include top + WFN = WFN + ST1 + AKM = AKM - min(ST1,ZERO) ! Commented on 08/26/02 - does not include top ! BUY(KD) = ST1 / (ETA(KD1)*qrb(kd)) @@ -2546,7 +2547,7 @@ SUBROUTINE CLOUD( & ! if (lprnt) print *,' clfr0=',clf(tem),' tem=',tem,' tem1=',tem1 -! clfrac = max(ZERO, min(ONE, rknob*clf(tem)*tem1)) +! clfrac = max(ZERO, min(ONE, rknob*clf(tem)*tem1)) ! clfrac = max(ZERO, min(0.25, rknob*clf(tem)*tem1)) clfrac = max(ZERO, min(half, rknob*clf(tem)*tem1)) diff --git a/gfsphysics/physics/set_soilveg.f b/gfsphysics/physics/set_soilveg.f index 7ad7cb90f..5a1be23af 100644 --- a/gfsphysics/physics/set_soilveg.f +++ b/gfsphysics/physics/set_soilveg.f @@ -45,14 +45,14 @@ subroutine set_soilveg(me,isot,ivet,nlunit) c----------------------------- rgltbl =(/30.0, 30.0, 30.0, 30.0, 30.0, 65.0, & 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, - & 100.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + & 100.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) hstbl =(/41.69, 54.53, 51.93, 47.35, 47.35, 54.53, & 36.35, 42.00, 42.00, 42.00, 42.00, 36.35, - & 42.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) + & 42.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) ! changed for version 2.6 on june 2nd 2003 ! data snupx /0.080, 0.080, 0.080, 0.080, 0.080, 0.080, ! & 0.040, 0.040, 0.040, 0.040, 0.025, 0.040, @@ -387,13 +387,13 @@ subroutine set_soilveg(me,isot,ivet,nlunit) DO I = 1,DEFINED_SOIL if (satdk(i) /= 0.0 .and. bb(i) > 0.0) then - SATDW(I) = BB(I)*SATDK(I)*(SATPSI(I)/MAXSMC(I)) - F11(I) = ALOG10(SATPSI(I)) + BB(I)*ALOG10(MAXSMC(I)) + 2.0 - REFSMC1 = MAXSMC(I)*(5.79E-9/SATDK(I)) + SATDW(I) = BB(I)*SATDK(I)*(SATPSI(I)/MAXSMC(I)) + F11(I) = LOG10(SATPSI(I)) + BB(I)*LOG10(MAXSMC(I)) + 2.0 + REFSMC1 = MAXSMC(I)*(5.79E-9/SATDK(I)) & **(1.0/(2.0*BB(I)+3.0)) - REFSMC(I) = REFSMC1 + (MAXSMC(I)-REFSMC1) / SMHIGH - WLTSMC1 = MAXSMC(I) * (200.0/SATPSI(I))**(-1.0/BB(I)) - WLTSMC(I) = WLTSMC1 - SMLOW * WLTSMC1 + REFSMC(I) = REFSMC1 + (MAXSMC(I)-REFSMC1) / SMHIGH + WLTSMC1 = MAXSMC(I) * (200.0/SATPSI(I))**(-1.0/BB(I)) + WLTSMC(I) = WLTSMC1 - SMLOW * WLTSMC1 ! ---------------------------------------------------------------------- ! CURRENT VERSION DRYSMC VALUES THAT EQUATE TO WLTSMC. diff --git a/gfsphysics/physics/sfcsub.F b/gfsphysics/physics/sfcsub.F index df5883ef6..86d6a1117 100644 --- a/gfsphysics/physics/sfcsub.F +++ b/gfsphysics/physics/sfcsub.F @@ -1411,7 +1411,8 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & irtvet,irtsot,irtalf &, irtvmn,irtvmx,irtslp,irtabs, - & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me) + & 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 @@ -1433,7 +1434,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! interpolate climatology but fixing initial anomaly ! - if(fh.gt.0.0.and.fntsfa(1:8).ne.' '.and.lanom) then + if(fh > 0.0 .and. fntsfa(1:8) /= ' ' .and. lanom) then call anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) endif ! @@ -3333,9 +3334,9 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, !cggg end enddo - kmami=1 - if (me == 0 .and. num_threads == 1) - & call maxmin(gauout(i1_t),len_thread,kmami) +! kmami=1 +! if (me == 0 .and. num_threads == 1) +! & call maxmin(gauout(i1_t),len_thread,kmami) else ! nearest neighbor interpolation ! @@ -3511,8 +3512,8 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, deallocate (ifill) endif ! - kmami=1 - if (me .eq. 0) call maxmin(gauout,len,kmami) +! kmami = 1 +! if (me == 0) call maxmin(gauout,len,kmami) ! return end subroutine la2ga @@ -3670,9 +3671,10 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, !clu [+1l] add irt() for vmn, vmx, slp, abs &, irtvmn,irtvmx,irtslp,irtabs &, imsk, jmsk, slmskh, outlat, outlon - &, gaus, blno, blto, me) + &, gaus, blno, blto, me, lanom) use machine , only : kind_io8,kind_io4 implicit none + logical lanom integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, !cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, @@ -3717,24 +3719,24 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, irttsf = 1 if(fntsfa(1:8).ne.' ') then call fixrda(lugb,fntsfa,kpdtsf,slmask, - & iy,im,id,ih,fh,tsfanl,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto - &, outlat, outlon, me) + & iy,im,id,ih,fh,tsfanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) irttsf = iret - if(iret.eq.1) then + if(iret == 1) then write(6,*) 't surface analysis read error' call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then - print *,'old t surface analysis provided, indicating proper', - & ' file name is given. no error suspected.' - write(6,*) 'forecast guess will be used' + elseif(iret == -1) then + if (me == 0) then + print *,'old t surface analysis provided, indicating proper' + &, ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' endif else - if (me .eq. 0) print *,'t surface analysis provided.' + if (me == 0) print *,'t surface analysis provided.' endif else - if (me .eq. 0) then + if (me == 0) then ! print *,'************************************************' print *,'no tsf analysis available. climatology used' endif @@ -3742,25 +3744,27 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, ! ! tsf0 ! -! if(fntsfa(1:8).ne.' ') then -! call fixrda(lugb,fntsfa,kpdtsf,slmask, -! & iy,im,id,ih,0.,tsfan0,len,iret -! &, imsk, jmsk, slmskh, gaus,blno, blto -! &, outlat, outlon, me) -! if(iret.eq.1) then -! write(6,*) 't surface at ft=0 analysis read error' -! call abort -! elseif(iret.eq.-1) then -! write(6,*) 'could not find t surface analysis at ft=0' -! call abort -! else -! print *,'t surface analysis at ft=0 found.' -! endif -! else -! do i=1,len -! tsfan0(i)=-999.9 -! enddo -! endif + if(fntsfa(1:8).ne.' ' .and. lanom) then + call fixrda(lugb,fntsfa,kpdtsf,slmask, + & iy,im,id,ih,0.,tsfan0,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + if(iret == 1) then + write(6,*) 't surface at ft=0 analysis read error' + call abort + elseif(iret == -1) then + if (me == 0) then + write(6,*) 'could not find t surface analysis at ft=0' + endif + call abort + else + print *,'t surface analysis at ft=0 found.' + endif + else + do i=1,len + tsfan0(i)=-999.9 + enddo + endif ! ! albedo ! @@ -6863,7 +6867,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & tg3(:), alb(:,:,:), alf(:,:), & vet(:), sot(:), tsf2(:), & veg(:,:), stc(:,:,:) - &, vmn(:), vmx(:), slp(:), abs(:) + &, vmn(:), vmx(:), slp(:), absm(:) ! integer mon1s, mon2s, sea1s, sea2s, sea1, sea2, hyr1, hyr2 data first/.true./ @@ -6871,7 +6875,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, ! save first, tsf, sno, zor, wet, ais, acn, scv, smc, tg3, & alb, alf, vet, sot, tsf2, veg, stc, - & vmn, vmx, slp, abs, + & vmn, vmx, slp, absm, & mon1s, mon2s, sea1s, sea2s, dayhf, k1, k2, m1, m2, & landice_cat ! @@ -6927,7 +6931,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & tg3(len), alb(len,4,2), alf(len,2), & vet(len), sot(len), tsf2(len), !clu [+1l] add vmn, vmx, slp, abs - & vmn(len), vmx(len), slp(len), abs(len), + & vmn(len), vmx(len), slp(len), absm(len), & veg(len,2), stc(len,lsoil,2)) ! ! get tsf climatology for the begining of the forecast @@ -7233,7 +7237,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, if(fnabsc(1:8).ne.' ') then kpd7=-1 call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmask, - & abs,len,iret + & absm,len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) if (me .eq. 0) write(6,*) 'climatological snoalb read in.' @@ -7823,25 +7827,25 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, ! if(fnvmnc(1:8).ne.' ') then do i=1,len - vmnclm(i) = vmn(i) + vmnclm(i) = vmn(i) enddo endif ! if(fnvmxc(1:8).ne.' ') then do i=1,len - vmxclm(i) = vmx(i) + vmxclm(i) = vmx(i) enddo endif ! if(fnslpc(1:8).ne.' ') then do i=1,len - slpclm(i) = slp(i) + slpclm(i) = slp(i) enddo endif ! if(fnabsc(1:8).ne.' ') then do i=1,len - absclm(i) = abs(i) + absclm(i) = absm(i) enddo endif !clu ---------------------------------------------------------------------- @@ -8000,16 +8004,16 @@ subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, call abort endif ! - if (me .eq. 0) then - write(6,*) ' maxmin of input as is' - kmami=1 - call maxmin(data(1,1),ijmax,kmami) - endif +! if (me == 0) then +! write(6,*) ' maxmin of input as is' +! kmami=1 +! call maxmin(data(1,1),ijmax,kmami) +! endif ! call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) - if (me .eq. 0) then - write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' - write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat + if (me == 0) then + write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' + write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat endif call subst(data,imax,jmax,dlon,dlat,ijordr) ! @@ -8308,16 +8312,16 @@ subroutine fixrda(lugb,fngrib,kpds5,slmask, endif ! 80 continue - if (me .eq. 0) then - write(6,*) ' maxmin of input as is' - kmami=1 - call maxmin(data(1,1),ijmax,kmami) - endif +! if (me == 0) then +! write(6,*) ' maxmin of input as is' +! kmami=1 +! call maxmin(data(1,1),ijmax,kmami) +! endif ! call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) - if (me .eq. 0) then - write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' - write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat + if (me == 0) then + write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' + write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat endif call subst(data,imax,jmax,dlon,dlat,ijordr) ! diff --git a/gfsphysics/physics/sflx.f b/gfsphysics/physics/sflx.f index 20b4b60f5..08e10402a 100644 --- a/gfsphysics/physics/sflx.f +++ b/gfsphysics/physics/sflx.f @@ -5430,8 +5430,8 @@ subroutine wdfcnd & ! ! --- ... calc the ratio of the actual to the max psbl soil h2o content - factr1 = 0.2 / smcmax - factr2 = smc / smcmax + factr1 = min(1.0, max(0.0, 0.2/smcmax)) + factr2 = min(1.0, max(0.0, smc/smcmax)) ! --- ... prep an expntl coef and calc the soil water diffusivity diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index ee6be2e32..590ddd39d 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -15,8 +15,8 @@ module FV3GFS_io_mod ! !--- FMS/GFDL modules use block_control_mod, only: block_control_type - use mpp_mod, only: mpp_error, mpp_pe, mpp_root_pe, & - mpp_chksum, NOTE, FATAL + use mpp_mod, only: mpp_error, mpp_pe, mpp_root_pe, & + mpp_chksum, NOTE, FATAL use fms_mod, only: file_exist, stdout use fms_io_mod, only: restart_file_type, free_restart_type, & register_restart_field, & @@ -71,9 +71,9 @@ module FV3GFS_io_mod !-RAB type data_subtype - real(kind=kind_phys), dimension(:), pointer :: var2 => NULL() + real(kind=kind_phys), dimension(:), pointer :: var2 => NULL() real(kind=kind_phys), dimension(:), pointer :: var21 => NULL() - real(kind=kind_phys), dimension(:,:), pointer :: var3 => NULL() + real(kind=kind_phys), dimension(:,:), pointer :: var3 => NULL() end type data_subtype !--- data type definition for use with GFDL FMS diagnostic manager until write component is working type gfdl_diag_type diff --git a/io/module_write_nemsio.F90 b/io/module_write_nemsio.F90 index 0fda90cf1..54e79d886 100644 --- a/io/module_write_nemsio.F90 +++ b/io/module_write_nemsio.F90 @@ -302,10 +302,10 @@ subroutine write_nemsio(fieldbundle, filename, nf_hours, & ! !** OPEN NEMSIO FILE ! - if(mype==0) print *,'in write_nemsio,bf nemsio_open, filename=',trim(filename), & - 'idate=',idate,'nfour=',NF_HOURS,NF_MINUTES,NF_SECONDS, 'mybdl=',mybdl,& - 'dim=',im,jm,lm,'nmeta=',nmeta,'idrt=',idrt,'nsoil=',nsoil, & - 'ntrac=',ntrac,'nrec=',nrec(mybdl),'extrameta=',extrameta(mybdl), & + if(mype==0) print *,'in write_nemsio,bf nemsio_open, filename=',trim(filename), & + 'idate=',idate,'nfour=',NF_HOURS,NF_MINUTES,NF_SECONDS, 'mybdl=',mybdl, & + 'dim=',im,jm,lm,'nmeta=',nmeta,'idrt=',idrt,'nsoil=',nsoil, & + 'ntrac=',ntrac,'nrec=',nrec(mybdl),'extrameta=',extrameta(mybdl), & 'vcoord=',vcoord(1:5,1,1),'nfhours=',nf_hours,nf_minutes,nfseconds,nfsecond_den, & 'idsl=',idsl(mybdl),'idvc=',idvc(mybdl),idvm(mybdl) ! 'nmetavari=',nmetavari(mybdl),'nmetavarc=',nmetavarc(mybdl) @@ -318,28 +318,28 @@ subroutine write_nemsio(fieldbundle, filename, nf_hours, & if(mype==0) then nfseconds = nf_seconds*nfsecond_den + nfsecond_num - call nemsio_open(nemsiofile,trim(FILENAME),'write',rc, & - modelname="FV3GFS", gdatatype="bin4", & - idate=idate,nfhour=nf_hours, nfminute=nf_minutes, & - nfsecondn=nfseconds, nfsecondd=nfsecond_den, & - dimx=im,dimy=jm,dimz=lm, nmeta=nmeta,idrt=idrt, & - nsoil=nsoil,ntrac=ntrac,nrec=nrec(mybdl), ncldt=ncld, & - idsl=idsl(mybdl),idvc=idvc(mybdl), idvm=idvm(mybdl), & - vcoord=vcoord, lon=lon1d,lat=lat1d, & + call nemsio_open(nemsiofile,trim(FILENAME),'write',rc, & + modelname="FV3GFS", gdatatype="bin4", & + idate=idate,nfhour=nf_hours, nfminute=nf_minutes, & + nfsecondn=nfseconds, nfsecondd=nfsecond_den, & + dimx=im,dimy=jm,dimz=lm, nmeta=nmeta,idrt=idrt, & + nsoil=nsoil,ntrac=ntrac,nrec=nrec(mybdl), ncldt=ncld, & + idsl=idsl(mybdl),idvc=idvc(mybdl), idvm=idvm(mybdl), & + vcoord=vcoord, lon=lon1d,lat=lat1d, & extrameta=extrameta(mybdl),recname=RECNAME(1:nrec(mybdl),mybdl), & - reclevtyp=RECLEVTYP(1:nrec(mybdl),mybdl), & - reclev=RECLEV(1:nrec(mybdl),mybdl), & - nmetavari=nmetavari(mybdl), nmetavarr=nmetavarr4(mybdl), & + reclevtyp=RECLEVTYP(1:nrec(mybdl),mybdl), & + reclev=RECLEV(1:nrec(mybdl),mybdl), & + nmetavari=nmetavari(mybdl), nmetavarr=nmetavarr4(mybdl), & nmetavarc=nmetavarc(mybdl), nmetaaryi=nmetaaryi(mybdl), & - variname=variname(1:nmetavari(mybdl),mybdl), & - varival=varival(1:nmetavari(mybdl),mybdl), & - varrname=varr4name(1:nmetavarr4(mybdl),mybdl), & - varrval=varr4val(1:nmetavarr4(mybdl),mybdl), & - varcname=varcname(1:nmetavarc(mybdl),mybdl), & - varcval=varcval(1:nmetavarc(mybdl),mybdl), & - aryiname=aryiname(1:nmetaaryi(mybdl),mybdl), & - aryilen=aryilen(1:nmetaaryi(mybdl),mybdl), & - aryival=aryival(1:maxval(aryilen(1:nmetaaryi(mybdl),mybdl)),& + variname=variname(1:nmetavari(mybdl),mybdl), & + varival=varival(1:nmetavari(mybdl),mybdl), & + varrname=varr4name(1:nmetavarr4(mybdl),mybdl), & + varrval=varr4val(1:nmetavarr4(mybdl),mybdl), & + varcname=varcname(1:nmetavarc(mybdl),mybdl), & + varcval=varcval(1:nmetavarc(mybdl),mybdl), & + aryiname=aryiname(1:nmetaaryi(mybdl),mybdl), & + aryilen=aryilen(1:nmetaaryi(mybdl),mybdl), & + aryival=aryival(1:maxval(aryilen(1:nmetaaryi(mybdl),mybdl)), & 1:nmetaaryi(mybdl),mybdl) ) if(rc/=0) print *,'nemsio_open, file=',trim(filename),' iret=',rc @@ -522,7 +522,7 @@ subroutine write_nemaio_final() if(allocated(lon1d)) deallocate(lon1d) if(allocated(lat1d)) deallocate(lat1d) if(allocated(vcoord)) deallocate(vcoord) - if(allocated(idsl)) deallocate(idsl, idvc,idvm) + if(allocated(idsl)) deallocate(idsl, idvc,idvm) deallocate(irecv) deallocate(idisp) deallocate(fieldcount) diff --git a/io/module_wrt_grid_comp.F90 b/io/module_wrt_grid_comp.F90 index 990e44016..ac407c3e7 100644 --- a/io/module_wrt_grid_comp.F90 +++ b/io/module_wrt_grid_comp.F90 @@ -833,7 +833,7 @@ subroutine wrt_initialize(wrt_comp, imp_state_write, exp_state_write, clock, rc) ,rc =RC) call ESMF_TimeGet(time=wrt_int_state%IO_BASETIME,yy=date(1),mm=date(2),dd=date(3),h=date(4), & - m=date(5),s=date(6),rc=rc) + m=date(5),s=date(6),rc=rc) if(wrt_int_state%mype == lead_write_task) print *,'in wrt initial, io_baseline time=',date,'rc=',rc idate(1:6) = date(1:6) idate(7) = 1 diff --git a/module_fcst_grid_comp.F90 b/module_fcst_grid_comp.F90 index 0bb48c81f..50725d9c4 100644 --- a/module_fcst_grid_comp.F90 +++ b/module_fcst_grid_comp.F90 @@ -12,39 +12,39 @@ module module_fcst_grid_comp ! !--------------------------------------------------------------------------------- ! - use time_manager_mod, only: time_type, set_calendar_type, set_time, & - set_date, days_in_month, month_name, & - operator(+), operator (<), operator (>), & - operator (/=), operator (/), operator (==),& - operator (*), THIRTY_DAY_MONTHS, JULIAN, & - NOLEAP, NO_CALENDAR, date_to_string, & - get_date - - use atmos_model_mod, only: atmos_model_init, atmos_model_end, & - update_atmos_model_dynamics, & - update_atmos_radiation_physics, & - update_atmos_model_state, & - atmos_data_type, atmos_model_restart - - use constants_mod, only: constants_init - use fms_mod, only: open_namelist_file, file_exist, check_nml_error, & - error_mesg, fms_init, fms_end, close_file, & - write_version_number, uppercase - - use mpp_mod, only: mpp_init, mpp_pe, mpp_root_pe, mpp_npes, mpp_get_current_pelist, & - mpp_set_current_pelist, stdlog, mpp_error, NOTE, FATAL, WARNING - use mpp_mod, only: mpp_clock_id, mpp_clock_begin, mpp_clock_end, mpp_sync - - use mpp_io_mod, only: mpp_open, mpp_close, MPP_NATIVE, MPP_RDONLY, MPP_DELETE - - use mpp_domains_mod, only: mpp_get_global_domain, mpp_global_field, CORNER - use memutils_mod, only: print_memuse_stats - use sat_vapor_pres_mod,only: sat_vapor_pres_init - - use diag_manager_mod, only: diag_manager_init, diag_manager_end, & - get_base_date, diag_manager_set_time_end - - use data_override_mod, only: data_override_init + use time_manager_mod, only: time_type, set_calendar_type, set_time, & + set_date, days_in_month, month_name, & + operator(+), operator (<), operator (>), & + operator (/=), operator (/), operator (==),& + operator (*), THIRTY_DAY_MONTHS, JULIAN, & + NOLEAP, NO_CALENDAR, date_to_string, & + get_date + + use atmos_model_mod, only: atmos_model_init, atmos_model_end, & + update_atmos_model_dynamics, & + update_atmos_radiation_physics, & + update_atmos_model_state, & + atmos_data_type, atmos_model_restart + + use constants_mod, only: constants_init + use fms_mod, only: open_namelist_file, file_exist, check_nml_error, & + error_mesg, fms_init, fms_end, close_file, & + write_version_number, uppercase + + use mpp_mod, only: mpp_init, mpp_pe, mpp_root_pe, mpp_npes, mpp_get_current_pelist, & + mpp_set_current_pelist, stdlog, mpp_error, NOTE, FATAL, WARNING + use mpp_mod, only: mpp_clock_id, mpp_clock_begin, mpp_clock_end, mpp_sync + + use mpp_io_mod, only: mpp_open, mpp_close, MPP_NATIVE, MPP_RDONLY, MPP_DELETE + + use mpp_domains_mod, only: mpp_get_global_domain, mpp_global_field, CORNER + use memutils_mod, only: print_memuse_stats + use sat_vapor_pres_mod, only: sat_vapor_pres_init + + use diag_manager_mod, only: diag_manager_init, diag_manager_end, & + get_base_date, diag_manager_set_time_end + + use data_override_mod, only: data_override_init use fv_nggps_diags_mod, only: fv_dyn_bundle_setup use fv3gfs_io_mod, only: fv_phys_bundle_setup @@ -553,7 +553,7 @@ subroutine fcst_run(fcst_comp, importState, exportState,clock,rc) call ESMF_ClockGet(clock, advanceCount=NTIMESTEP_ESMF, rc=rc) na = NTIMESTEP_ESMF - if(mype==0) print *,'in fcst run, na=',na +! if(mype==0) print *,'in fcst run, na=',na ! !----------------------------------------------------------------------- ! *** call fcst integration subroutines @@ -590,7 +590,7 @@ subroutine fcst_run(fcst_comp, importState, exportState,clock,rc) ! WRITE(0,*)"PASS: fcstRUN, na=",na ENDIF ! - if(mype==0) print *,'fcst _run time is ', mpi_wtime()-tbeg1 +! if(mype==0) print *,'fcst _run time is ', mpi_wtime()-tbeg1 ! !----------------------------------------------------------------------- !