diff --git a/CMakeLists.txt b/CMakeLists.txt index d599faa5c..d9e5b7b36 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -129,15 +129,31 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ./physics/cu_gf_sh.F90 PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -r8 -ftz") # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files (following FV3/gfsphysics/makefile) + # for bit-for-bit reproducibility with non-CCPP builds. These may go in the future once the CCPP solution + # is fully accepted. set(CMAKE_Fortran_FLAGS_LOPT ${CMAKE_Fortran_FLAGS}) - string(REPLACE "xHost" "xCORE-AVX-I" + string(REPLACE "-xHOST" "-xCORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT "${CMAKE_Fortran_FLAGS_LOPT}") - string(REPLACE "xCORE-AVX2" "xCORE-AVX-I" + string(REPLACE "-xCORE-AVX2" "-xCORE-AVX-I" CMAKE_Fortran_FLAGS_LOPT "${CMAKE_Fortran_FLAGS_LOPT}") SET_SOURCE_FILES_PROPERTIES(./physics/radiation_aerosols.f PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT} -r8 -ftz") + # Force consistent results of math calculations for MG microphysics; + # in Debug/Bitforbit) mode; without this flag, the results of the + # intrinsic gamma function are different for the non-CCPP and CCPP + # version (on Theia with Intel 18). Note this is only required with + # dynamic CCPP builds (hybrid, standalone), not with static CCPP builds. + if (${CMAKE_BUILD_TYPE} MATCHES "Debug") + SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90 + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -fimf-arch-consistency=true") + elseif (${CMAKE_BUILD_TYPE} MATCHES "Bitforbit") + SET_SOURCE_FILES_PROPERTIES(./physics/micro_mg2_0.F90 + ./physics/micro_mg3_0.F90 + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS} -fimf-arch-consistency=true") + endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") else (PROJECT STREQUAL "CCPP-FV3") SET_SOURCE_FILES_PROPERTIES(./physics/module_bfmicrophysics.f ./physics/rascnvv2.f ./physics/sflx.f ./physics/sfc_diff.f ./physics/sfc_diag.f PROPERTIES COMPILE_FLAGS -r8) SET_SOURCE_FILES_PROPERTIES(./physics/module_nst_model.f90 ./physics/calpreciptype.f90 PROPERTIES COMPILE_FLAGS "-r8 -free") diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index 2f1352031..db677ce06 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -6,7 +6,11 @@ module GFS_diagtoscreen public GFS_diagtoscreen_init, GFS_diagtoscreen_run, GFS_diagtoscreen_finalize -#define PRINT_SUM + public print_my_stuff, chksum_int, chksum_real + +#define PRINT_CHKSUM +!#define PRINT_SUM + interface print_var module procedure print_logic_0d module procedure print_int_0d @@ -18,10 +22,10 @@ module GFS_diagtoscreen end interface integer, parameter :: ISTART = 1 - integer, parameter :: IEND = 11 + integer, parameter :: IEND = 9999999 integer, parameter :: KSTART = 1 - integer, parameter :: KEND = 11 + integer, parameter :: KEND = 9999999 contains @@ -86,7 +90,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, integer, intent(out) :: errflg !--- local variables - integer :: impi, iomp, ierr + integer :: impi, iomp, ierr, n integer :: mpirank, mpisize, mpicomm integer :: omprank, ompsize @@ -115,7 +119,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, !$OMP BARRIER #endif #ifdef MPI - call MPI_BARRIER(mpicomm,ierr) +! call MPI_BARRIER(mpicomm,ierr) #endif do impi=0,mpisize-1 @@ -230,6 +234,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, Tbd%blkno, 'Tbd%phy_fctd' , Tbd%phy_fctd) call print_var(mpirank,omprank, Tbd%blkno, 'Tbd%phy_f2d' , Tbd%phy_f2d) call print_var(mpirank,omprank, Tbd%blkno, 'Tbd%phy_f3d' , Tbd%phy_f3d) + do n=1,size(Tbd%phy_f3d(1,1,:)) + call print_var(mpirank,omprank, Tbd%blkno, 'Tbd%phy_f3d_n' , Tbd%phy_f3d(:,:,n)) + end do call print_var(mpirank,omprank, Tbd%blkno, 'Tbd%blkno' , Tbd%blkno) ! Diag (incomplete) call print_var(mpirank,omprank, Tbd%blkno, 'Diag%topfsw%upfxc', Diag%topfsw%upfxc) @@ -410,7 +417,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, #endif end do #ifdef MPI - call MPI_BARRIER(mpicomm,ierr) +! call MPI_BARRIER(mpicomm,ierr) #endif end do @@ -418,7 +425,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, !$OMP BARRIER #endif #ifdef MPI - call MPI_BARRIER(mpicomm,ierr) +! call MPI_BARRIER(mpicomm,ierr) #endif end subroutine GFS_diagtoscreen_run @@ -431,7 +438,7 @@ subroutine print_logic_0d(mpirank,omprank,blkno,name,var) character(len=*), intent(in) :: name logical, intent(in) :: var - write(0,'(2a,3i4,1x,l)') 'XXX: ', trim(name), mpirank, omprank, blkno, var + write(0,'(2a,3i6,1x,l)') 'XXX: ', trim(name), mpirank, omprank, blkno, var end subroutine print_logic_0d @@ -443,7 +450,7 @@ subroutine print_int_0d(mpirank,omprank,blkno,name,var) character(len=*), intent(in) :: name integer, intent(in) :: var - write(0,'(2a,3i4,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, var + write(0,'(2a,3i6,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, var end subroutine print_int_0d @@ -460,10 +467,12 @@ subroutine print_int_1d(mpirank,omprank,blkno,name,var) integer :: i #ifdef PRINT_SUM - write(0,'(2a,3i4,3i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) + write(0,'(2a,3i6,3i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_int(size(var),var), minval(var), maxval(var) #else do i=ISTART,min(IEND,size(var(:))) - write(0,'(2a,3i4,i6,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) + write(0,'(2a,3i6,i6,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) end do #endif @@ -479,7 +488,7 @@ subroutine print_real_0d(mpirank,omprank,blkno,name,var) character(len=*), intent(in) :: name real(kind_phys), intent(in) :: var - write(0,'(2a,3i4,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, var + write(0,'(2a,3i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, var end subroutine print_real_0d @@ -496,10 +505,12 @@ subroutine print_real_1d(mpirank,omprank,blkno,name,var) integer :: i #ifdef PRINT_SUM - write(0,'(2a,3i4,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) + write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),var), minval(var), maxval(var) #else do i=ISTART,min(IEND,size(var(:))) - write(0,'(2a,3i4,i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) + write(0,'(2a,3i6,i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) end do #endif @@ -518,11 +529,13 @@ subroutine print_real_2d(mpirank,omprank,blkno,name,var) integer :: k, i #ifdef PRINT_SUM - write(0,'(2a,3i4,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) + write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) #else do i=ISTART,min(IEND,size(var(:,1))) do k=KSTART,min(KEND,size(var(1,:))) - write(0,'(2a,3i4,2i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, var(i,k) + write(0,'(2a,3i6,2i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, var(i,k) end do end do #endif @@ -542,12 +555,14 @@ subroutine print_real_3d(mpirank,omprank,blkno,name,var) integer :: k, i, l #ifdef PRINT_SUM - write(0,'(2a,3i4,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) + write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) #else do i=ISTART,min(IEND,size(var(:,1,1))) do k=KSTART,min(KEND,size(var(1,:,1))) do l=1,size(var(1,1,:)) - write(0,'(2a,3i4,3i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, l, var(i,k,l) + write(0,'(2a,3i6,3i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, l, var(i,k,l) end do end do end do @@ -555,6 +570,82 @@ subroutine print_real_3d(mpirank,omprank,blkno,name,var) end subroutine print_real_3d + function chksum_int(N, var) result(hash) + implicit none + integer, intent(in) :: N + integer, dimension(1:N), intent(in) :: var + integer*8, dimension(1:N) :: int_var + integer*8 :: a, b, i, hash + integer*8, parameter :: mod_adler=65521 + + a=1 + b=0 + i=1 + hash = 0 + int_var = TRANSFER(var, a, N) + + do i= 1, N + a = MOD(a + int_var(i), mod_adler) + b = MOD(b+a, mod_adler) + end do + + hash = ior(b * 65536, a) + + end function chksum_int + + function chksum_real(N, var) result(hash) + use machine, only: kind_phys + implicit none + integer, intent(in) :: N + real(kind_phys), dimension(1:N), intent(in) :: var + integer*8, dimension(1:N) :: int_var + integer*8 :: a, b, i, hash + integer*8, parameter :: mod_adler=65521 + + a=1 + b=0 + i=1 + hash = 0 + int_var = TRANSFER(var, a, N) + + do i= 1, N + a = MOD(a + int_var(i), mod_adler) + b = MOD(b+a, mod_adler) + end do + + hash = ior(b * 65536, a) + + end function chksum_real + + function print_my_stuff(mpitoprint,omptoprint) result(flag) +#ifdef MPI + use mpi +#endif +#ifdef OPENMP + use omp_lib +#endif + implicit none + integer, intent(in) :: mpitoprint, omptoprint + logical :: flag + integer :: ompthread, mpirank, ierr +#ifdef MPI + call MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) +#else + mpirank = 0 +#endif +#ifdef OPENMP + ompthread = OMP_GET_THREAD_NUM() +#else + ompthread = 0 +#endif + + if (mpitoprint==mpirank .and. omptoprint==ompthread) then + flag = .true. + else + flag = .false. + end if + end function print_my_stuff + end module GFS_diagtoscreen diff --git a/physics/cldmacro.F b/physics/cldmacro.F new file mode 100644 index 000000000..084db5da5 --- /dev/null +++ b/physics/cldmacro.F @@ -0,0 +1,2343 @@ + module cldmacro +!======================================================================= +! Anning Cheng 2/18/2016 replaced GEO condensation scheme +! with those from 2M microphysics + use wv_saturation, only: + & epsqs,ttrice,hlatv,hlatf,pcf,rgasv +! & ,vqsatd2_water_single, +! & vqsatd2_ice_single,vqsatd2_single + use funcphys, only : fpvs, fpvsl, fpvsi +! use GEOS_UtilsMod, only:QSAT=>GEOS_Qsat, DQSAT=>GEOS_DQsat, +! & QSATLQ=>GEOS_QsatLQU, QSATIC=>GEOS_QsatICE +#ifdef GEOS5 + use MAPL_ConstantsMod, only: MAPL_TICE , MAPL_CP , MAPL_GRAV , + & MAPL_ALHS , MAPL_ALHL , MAPL_ALHF , MAPL_RGAS , MAPL_H2OMW, + & MAPL_AIRMW, MAPL_RVAP , MAPL_PI , MAPL_R8 , MAPL_R4 + use MAPL_BaseMod, only: MAPL_UNDEF +#endif +#ifdef NEMS_GSM + use physcons, MAPL_TICE => con_t0c, MAPL_GRAV => con_g, + & MAPL_CP => con_cp, MAPL_ALHL => con_hvap, + & MAPL_ALHF => con_hfus, MAPL_PI => con_pi, + & MAPL_RGAS => con_rd, MAPL_RVAP => con_rv +#endif + + + implicit none + + +! save + private + + PUBLIC MACRO_CLOUD + PUBLIC UPDATE_CLD + public meltfrz_inst + public fix_up_clouds_2M + PUBLIC CLOUD_PTR_STUBS + +!! Some parameters set by PHYSPARAMS + + integer :: NSMAX, DISABLE_RAD, ICEFRPWR, pdfflag + &, FR_LS_WAT, FR_LS_ICE, FR_AN_WAT, FR_AN_ICE + + real :: CNV_BETA + real :: ANV_BETA + real :: LS_BETA + real :: RH00 + real :: C_00 + real :: LWCRIT + real :: C_ACC + real :: C_EV_R + real :: C_EV_S + real :: CLDVOL2FRC + real :: RHSUP_ICE + real :: SHR_EVAP_FAC + real :: MIN_CLD_WATER + real :: CLD_EVP_EFF + real :: LS_SDQV2 + real :: LS_SDQV3 + real :: LS_SDQVT1 + real :: ANV_SDQV2 + real :: ANV_SDQV3 + real :: ANV_SDQVT1 + real :: ANV_TO_LS + real :: N_WARM + real :: N_ICE + real :: N_ANVIL + real :: N_PBL + real :: ANV_ICEFALL_C + real :: LS_ICEFALL_C + real :: REVAP_OFF_P + real :: CNVENVFC + real :: WRHODEP + real :: T_ICE_ALL + real :: CNVICEPARAM + real :: CNVDDRFC + real :: ANVDDRFC + real :: LSDDRFC +! 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, parameter :: T_ICE_MAX = MAPL_TICE + real, parameter :: RHO_W = 1.0e3 + real, parameter :: MIN_CLD_FRAC = 1.0e-8 + real, parameter :: MAPL_ALHS = MAPL_ALHL+MAPL_ALHF + + real, parameter :: alhlbcp = MAPL_ALHL/MAPL_CP + &, alhfbcp = MAPL_ALHF/MAPL_CP + &, alhsbcp = alhlbcp+alhfbcp + + + real, parameter :: PI_0 = 4.*atan(1.) + real omeps, trinv, t_ice_denom + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + contains + + + subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_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 + &, QIW_AN_dev, ANVFRC_dev, CLDFRC_dev + &, PRECU_dev, CUARF_dev, SNRCU_dev + &, PHYSPARAMS, SCLMFDFR, QST3_dev + &, DZET_dev, QDDF3_dev, RHX_dev + &, REV_CN_dev, RSU_CN_dev, ACLL_CN_dev + &, ACIL_CN_dev,PFL_CN_dev, PFI_CN_dev + &, PDFL_dev, PDFI_dev + &, ALPHT_dev, CFPDF_dev, DQRL_dev + &, VFALLSN_CN_dev + &, VFALLRN_CN_dev, CNV_FICE_dev + &, CNV_NDROP_dev, CNV_NICE_dev, SCICE_dev + &, NCPL_dev, NCPI_dev, PFRZ_dev + &, QRAIN_CN, QSNOW_CN + &, 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 ) :: FRLAND_dev + real, intent(in ), dimension(IRUN, LM) :: RMFDTR_dev + real, intent(in ), dimension(IRUN, LM) :: QLWDTR_dev + real, intent(inout), dimension(IRUN, LM) :: QRN_CU_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 + real, intent(inout), dimension(IRUN, LM) :: QLW_AN_dev + real, intent(inout), dimension(IRUN, LM) :: QIW_LS_dev + real, intent(inout), dimension(IRUN, LM) :: QIW_AN_dev + real, intent(inout), dimension(IRUN, LM) :: ANVFRC_dev + real, intent(inout), dimension(IRUN, LM) :: CLDFRC_dev + real, intent( out), dimension(IRUN ) :: PRECU_dev + real, intent( out), dimension(IRUN ) :: CUARF_dev + real, intent( out), dimension(IRUN ) :: SNRCU_dev + real, intent(in ), dimension(58 ) :: PHYSPARAMS + real, intent(in ) :: SCLMFDFR + real, intent(in ), dimension(IRUN, LM) :: QST3_dev + real, intent(in ), dimension(IRUN, LM) :: DZET_dev + real, intent(in ), dimension(IRUN, LM) :: QDDF3_dev + real, intent( out), dimension(IRUN, LM) :: RHX_dev + real, intent( out), dimension(IRUN, LM) :: REV_CN_dev + real, intent( out), dimension(IRUN, LM) :: RSU_CN_dev + real, intent( out), dimension(IRUN, LM) :: ACLL_CN_dev + real, intent( out), dimension(IRUN, LM) :: ACIL_CN_dev + real, intent( out), dimension(IRUN,0:LM) :: PFL_CN_dev + real, intent( out), dimension(IRUN,0:LM) :: PFI_CN_dev + real, intent( out), dimension(IRUN, LM) :: PDFL_dev + real, intent( out), dimension(IRUN, LM) :: PDFI_dev + real, intent( out), dimension(IRUN, LM) :: ALPHT_dev + real, intent( out), dimension(IRUN, LM) :: CFPDF_dev + real, intent( out), dimension(IRUN, LM) :: DQRL_dev + real, intent( out), dimension(IRUN, LM) :: VFALLSN_CN_dev + real, intent( out), dimension(IRUN, LM) :: VFALLRN_CN_dev + real, intent(inout), dimension(IRUN, LM) :: CNV_FICE_dev + real, intent(inout), dimension(IRUN, LM) :: CNV_NDROP_dev + real, intent(inout), dimension(IRUN, LM) :: CNV_NICE_dev + real, intent(inout), dimension(IRUN, LM) :: SCICE_dev + real, intent(inout), dimension(IRUN, LM) :: NCPL_dev + real, intent(inout), dimension(IRUN, LM) :: NCPI_dev + real, intent(out), dimension(IRUN, LM) :: PFRZ_dev + real, intent(out), dimension(IRUN, LM) :: QRAIN_CN + real, intent(out), dimension(IRUN, LM) :: QSNOW_CN + + real, dimension(IRUN, LM) :: FRZ_PP_dev + integer, intent(in), dimension(IRUN) :: KCBL + logical lprnt + integer ipr + + +! GPU The GPUs need to know how big local arrays are during compile-time +! as the GPUs cannot allocate memory themselves. This command resets +! this a priori size to LM for the CPU. + + + integer :: I , J , K , L + + integer :: FRACTION_REMOVAL + + 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 + &, 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 +! + real, parameter :: RL_cub = 1.0e-15, RI_cub = 6.4e-14 +! + + omeps = 1. - epsqs + dti = 1.0 /dt + trinv = 1.0/ttrice + + CNV_BETA = PHYSPARAMS(1) + ANV_BETA = PHYSPARAMS(2) + LS_BETA = PHYSPARAMS(3) + RH00 = PHYSPARAMS(4) + C_00 = PHYSPARAMS(5) + LWCRIT = PHYSPARAMS(6) + C_ACC = PHYSPARAMS(7) + C_EV_R = PHYSPARAMS(8) + C_EV_S = PHYSPARAMS(56) + CLDVOL2FRC = PHYSPARAMS(9) + RHSUP_ICE = PHYSPARAMS(10) + SHR_EVAP_FAC = PHYSPARAMS(11) + MIN_CLD_WATER = PHYSPARAMS(12) + CLD_EVP_EFF = PHYSPARAMS(13) + NSMAX = INT( PHYSPARAMS(14) ) + LS_SDQV2 = PHYSPARAMS(15) + LS_SDQV3 = PHYSPARAMS(16) + LS_SDQVT1 = PHYSPARAMS(17) + ANV_SDQV2 = PHYSPARAMS(18) + ANV_SDQV3 = PHYSPARAMS(19) + ANV_SDQVT1 = PHYSPARAMS(20) + ANV_TO_LS = PHYSPARAMS(21) + N_WARM = PHYSPARAMS(22) + N_ICE = PHYSPARAMS(23) + N_ANVIL = PHYSPARAMS(24) + N_PBL = PHYSPARAMS(25) + DISABLE_RAD = INT( PHYSPARAMS(26) ) + ANV_ICEFALL_C = PHYSPARAMS(28) + LS_ICEFALL_C = PHYSPARAMS(29) + REVAP_OFF_P = PHYSPARAMS(30) + CNVENVFC = PHYSPARAMS(31) + WRHODEP = PHYSPARAMS(32) + T_ICE_ALL = PHYSPARAMS(33) + MAPL_TICE + CNVICEPARAM = PHYSPARAMS(34) + ICEFRPWR = INT( PHYSPARAMS(35) + .001 ) + CNVDDRFC = PHYSPARAMS(36) + ANVDDRFC = PHYSPARAMS(37) + LSDDRFC = PHYSPARAMS(38) +! 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) ) + fr_an_ice = INT( PHYSPARAMS(50) ) + MIN_RL = PHYSPARAMS(51) + MIN_RI = PHYSPARAMS(52) + MAX_RL = PHYSPARAMS(53) + MAX_RI = PHYSPARAMS(54) + RI_ANV = PHYSPARAMS(55) + pdfflag = INT(PHYSPARAMS(57)) + + + 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 + PRN_CU_above = 0. + 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 + + if (K == 1) then + TOT_PREC_UPD = 0. + AREA_UPD_PRC = 0. + end if + + if (K == LM ) then + PRECU_dev(I) = 0. + SNRCU_dev(I) = 0. + CUARF_dev(I) = 0. + end if + + QRN_CU_1D = 0. + QSN_CU = 0. + VFALL = 0. + + PFL_CN_dev(I,K) = 0. + PFI_CN_dev(I,K) = 0. + + IF (K == 1) THEN + PFL_CN_dev(I,0) = 0. + 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 + ACLL_CN_dev(I,K) = 0.0 + ACIL_CN_dev(I,K) = 0.0 + PDFL_dev(I,K) = 0.0 + PDFI_dev(I,K) = 0.0 + ALPHT_dev(I,K) = 0.0 + CFPDF_dev(I,K) = 0.0 + DQRL_dev(I,K) = 0.0 + VFALLSN_CN_dev(I,K) = 0.0 + VFALLRN_CN_dev(I,K) = 0.0 + 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 + + QRAIN_CN(I,K) = 0.0 + 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 = TH_dev(I,K) + FRZ_PP_dev(I,K) = 0.00 + + +! NOT USED??? - Moorthi +! TOTAL_WATER = (QIW_AN_dev(I,K) + QLW_AN_dev(I,K) +! & + QIW_LS_dev(I,K) + QLW_LS_dev(I,K))*MASS +! & + QLWDTR_dev(I,K)*DT + + +! update of number concentration due to convective detrainment + + if (TEMP < T_ICE_ALL) then + fQi = 1.0 + elseif (TEMP > T_ICE_MAX) then + fQi = 0.0 + else + fQi = CNV_FICE_dev(I,K) + end if + tx1 = (1.0-fQi)*QLWDTR_dev(I,K) + if (tx1 > 0.0 .and. CNV_NDROP_dev(I,K) <= 0.0) then + CNV_NDROP_dev(I,K) = tx1 / ( 1.333 * MAPL_PI *RL_cub*997.0) + end if + + tx1 = fQi*QLWDTR_dev(I,K) + if (tx1 > 0.0 .and. CNV_NICE_dev(I,K) <= 0.0) then + CNV_NICE_dev(I,K) = tx1 / ( 1.333 * MAPL_PI *RI_cub*500.0) + end if + + tx1 = iMASS*DT + NCPL_dev(I,K) = max(NCPL_dev(I,K)+CNV_NDROP_dev(I,K)*tx1,0.0) + NCPI_dev(I,K) = max(NCPI_dev(I,K)+CNV_NICE_dev(I,K)*tx1,0.0) + + + TEND = RMFDTR_dev(I,K)*iMASS * SCLMFDFR + 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) ) +! 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 + +!================================ + + + 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) ) + + +!=============Collect convective precip============== + +!*********************** begin of if(false)******************************** + if(.false.) then + QTMP1 = 0. + QTMP2 = 0. + QTMP3 = 0. + QRN_ALL = 0. + QSN_ALL = 0. + + if ( TEMP < MAPL_TICE ) then +! QTMP2 = QRN_CU_1D + QSN_CU = QRN_CU_1D + QRN_CU_1D = 0. + TEMP = TEMP + QSN_CU * ALHFbCP + end if + + AREA_UPD_PRC_tolayer = 0.0 + + + TOT_PREC_UPD = TOT_PREC_UPD + ((QRN_CU_1D + QSN_CU) * MASS) + AREA_UPD_PRC = AREA_UPD_PRC + (CNV_UPDFRC_dev(I,K)* + & (QRN_CU_1D + QSN_CU )* MASS) + + if ( TOT_PREC_UPD > 0.0 ) AREA_UPD_PRC_tolayer = + & MAX( AREA_UPD_PRC/TOT_PREC_UPD, 1.E-6 ) + + AREA_UPD_PRC_tolayer = CNV_BETA * AREA_UPD_PRC_tolayer + + IF (K == LM) THEN + if (TOT_PREC_UPD > 0.0) AREA_UPD_PRC = MAX( AREA_UPD_PRC/ + & TOT_PREC_UPD, 1.E-6 ) + AREA_UPD_PRC = CNV_BETA * AREA_UPD_PRC + CUARF_dev(I) = MIN( AREA_UPD_PRC, 1.0 ) + END IF + + + CALL MICRO_AA_BB_3 (TEMP,PP_dev(I,K),QST3_dev(I,K),AA3,BB3) + + + QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) + QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) + QTOT = QTMP1 + QTMP2 + + call PRECIP3 (K, LM, DT, FRLAND_dev(I), RHCRIT, QRN_CU_1D, + & QSN_CU, QTMP1, QTMP2, TEMP, Q_dev(I,K), mass, + & imass, PP_dev(I,K), DZET_dev(I,K), + & QDDF3_dev(I,K), AA3,BB3,AREA_UPD_PRC_tolayer, + & PRECU_dev(I), SNRCU_dev(I), PRN_CU_above, + & PSN_CU_above, EVAP_DD_CU_above, + & SUBL_DD_CU_above, REV_CN_dev(I,K), + & RSU_CN_dev(I,K), ACLL_CN_dev(I,K), + & ACIL_CN_dev(I,K), PFL_CN_dev(I,K), + & PFI_CN_dev(I,K), VFALLRN, VFALLSN, + & FRZ_PP_dev(I,K), CNVENVFC, CNVDDRFC, + & ANVFRC_dev(I,k), CLDFRC_dev(I,k), + & PP_dev(I,KCBL(I)),i) + + VFALLSN_CN_dev(I,K) = VFALLSN + VFALLRN_CN_dev(I,K) = VFALLRN + + if (.not. use_autoconv_timescale) then + if (VFALLSN .NE. 0.) then + QSN_ALL = QSN_ALL + PFI_CN_dev(I,K)/VFALLSN + end if + if (VFALLRN .NE. 0.) then + QRN_ALL = QRN_ALL + PFL_CN_dev(I,K)/VFALLRN + end if + end if + +! if (.true.) then + + tx1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) + IF (tx1 > 1.e-20 ) THEN + QTMP3 = 1.0 / tx1 + ELSE + QTMP3 = 0.0 + END IF + tx1 = QTMP1 * QTMP3 + QLW_LS_dev(I,K) = QLW_LS_dev(I,K) * tx1 + QLW_AN_dev(I,K) = QLW_AN_dev(I,K) * tx1 + NCPL_dev(I, K) = NCPL_dev(I,K) * tx1 + + tx1 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) + IF (tx1 > 1.0e-20 ) THEN + QTMP3 = 1.0 / tx1 + ELSE + QTMP3 = 0.0 + END IF + tx1 = QTMP2 * QTMP3 + QIW_LS_dev(I,K) = QIW_LS_dev(I,K) * tx1 + QIW_AN_dev(I,K) = QIW_AN_dev(I,K) * tx1 + NCPI_dev(I, K) = NCPI_dev(I,K) * tx1 + + + QTMP3 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) + & + QLW_LS_dev(I,K) + QLW_AN_dev(I,K) + + If (QTOT > 0.0) then + tx1 = QTMP3/QTOT + CLDFRC_dev(I,k) = CLDFRC_dev(I,k)*tx1 + ANVFRC_dev(I,k) = ANVFRC_dev(I,k)*tx1 + end if + +! end if + + + tx1 = (MAPL_RGAS*0.01) * temp / PP_dev(I,K) + + QRAIN_CN(I,K) = QRN_ALL * tx1 + QSNOW_CN(I,K) = QSN_ALL * tx1 + QRN_CU_dev(I,K) = QRN_CU_1D + + TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) + + IF ( TOTFRC > 1.00 ) THEN + tx1 = 1.0 / TOTFRC + CLDFRC_dev(I,k) = CLDFRC_dev(I,k) * tx1 + ANVFRC_dev(I,k) = ANVFRC_dev(I,k) * tx1 + END IF + + TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) + + 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 + + end do K_LOOP + + + end do RUN_LOOP + + END SUBROUTINE MACRO_CLOUD + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! P R O C E S S S U B R O U T I N E S !! +!! * * * * * !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! P R O C E S S S U B R O U T I N E S !! +!! * * * * * !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! P R O C E S S S U B R O U T I N E S !! +!! * * * * * !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine pdf_spread (K, LM, PP, ALPHA, ALPHT_DIAG, FRLAND, rhc) + + integer, intent(in) :: k,lm + real, intent(in) :: PP, FRLAND, rhc + + real, intent(out) :: ALPHA, ALPHT_DIAG + +! real, parameter :: slope = 20.0, slope_up = 20.0 + real, parameter :: slope = 0.02, slope_up = 0.02 + + real :: aux1, aux2, maxalpha + +! maxalpha = 1.0 - minrhcrit + maxalpha = 1.0 - rhc + + 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 / (1.0+exp(aux1+aux1)) + else + 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 + + ALPHT_DIAG = ALPHA + + end subroutine pdf_spread + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine fix_up_clouds_2M( QV, TE, QLC, QIC, CF, QLA, QIA, AF, + & NL, NI ) + + real, intent(inout) :: TE,QV,QLC,CF,QLA,AF,QIC,QIA, NL, NI + + real, parameter :: qmin = 1.0e-11, cfmin = 1.0e-4 + &, nmin = 1.0e-3, RL_cub = 1.0e-15 + &, RI_cub = 6.4e-14 + +! if(.false.) then +! if (AF < cfmin) then +! QV = QV + QLA + QIA +! TE = TE - ALHLbCP*QLA - ALHSbCP*QIA +! AF = 0. +! QLA = 0. +! QIA = 0. + + +! if ( CF < cfmin) then +! QV = QV + QLC + QIC +! TE = TE - ALHLbCP*QLC - ALHSbCP*QIC +! CF = 0. +! QLC = 0. +! QIC = 0. +! end if +! end if +! end if + +! Anning make some changes here +! if (AFqmin) AF=cfmin +! if(CFqmin) CF=cfmin + + + if (QLC < qmin .and. QLC > 0.) then + QV = QV + QLC + TE = TE - ALHLbCP*QLC + QLC = 0. + end if + + if (QIC < qmin .and. QIC > 0.) then + QV = QV + QIC + TE = TE - ALHSbCP*QIC + QIC = 0. + end if + + + if (QLA < qmin .and. QLA > 0.) then + QV = QV + QLA + TE = TE - ALHLbCP*QLA + QLA = 0. + end if + + if (QIA < qmin .and. QIA > 0.) then + QV = QV + QIA + TE = TE - ALHSbCP*QIA + QIA = 0. + end if + + + if (QLA+QIA < qmin .and. QLA+QIA > 0.) then + QV = QV + QLA + QIA + TE = TE - ALHLbCP*QLA - ALHSbCP*QIA + AF = 0. + QLA = 0. + QIA = 0. + end if + + if (QLC+QIC < qmin .and. QLC+QIC > 0. ) then + QV = QV + QLC + QIC + TE = TE - ALHLbCP*QLC - ALHSbCP*QIC + CF = 0. + QLC = 0. + QIC = 0. + end if + + if ((QLA+QLC) <= qmin) then + NL = 0.0 + end if + + if ((QIA+QIC) <= qmin) then + NI = 0.0 + end if + +! make sure N > 0 if Q >0 + if (QLA+QLC > qmin .and. NL <= nmin) then + NL = max((QLA+QLC)/( 1.333 * MAPL_PI *RL_cub*997.0), nmin) + end if + + if (QIA+QIC > qmin .and. NI <= nmin) then + NI = max((QIA+QIC)/( 1.333 * MAPL_PI *RI_cub*500.0), nmin) + end if + + + 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) +! & SCICE, NI, NL, NCnuc) + + integer, intent(in) :: irun, lm, pdfshape + real, intent(in) :: DT + 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, NL, SCICE + + 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 + + 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) + !Anning do not let empty cloud exist + 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 +!================================================ +! First find the cloud fraction that would correspond to the current +! condensate +! QSLIQ = QSATLQ( TE , PL*100.0 , DQ=DQx ) +! QSICE = QSATIC( TE , PL*100.0 , DQ=DQx ) +! call vqsatd2_water_single(TE(i,k),PL(i,k)*100.0, +! & 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 ) +! 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.) + + end if + +! if (TE(i,k) > T_ICE_ALL) SCICE(i,k) = 1.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 + + CFALL = max(CFo, 0.0) + CFALL = min(CFo, 1.0) + + CF(i,k) = CFALL*(1.0-FQA) + AF(i,k) = CFALL*FQA + + +! 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 ) + + !Anning do not let empty cloud exist + 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 + + + end subroutine update_cld + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, + & QCi, QAi, TE, CF, AF, SCICE, NI, NL, i, k) + + real, intent(in) :: DT,ALPHA,PL + integer, intent(in) :: pdfshape + real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF, NI, NL, + & SCICE + + integer, parameter :: nmax=20 + + real :: QCO, QVO, CFO, QAO, TAU + real :: QT, QMX, QMN, DQ, QVtop, sigmaqt1, sigmaqt2, qsnx + + 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 + &, dQAi, dQAl, dQCi, dQCl + + 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 + + QC = QCl + QCi + QA = QAl + QAi + QT = QC + QA + QV + CFALL = AF + CF + FQA = 0.0 + fQi = 0.0 + tmpARR = 0.0 + 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.0 / (1.0-AF) + + TEo = TE + +! + 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.) + + 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 + 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.0 ) QAx = QA/AF + + QT = QCx + QVx + + TEp = TEo + QSn = QSx + TEn = TEo + CFn = CFx + QVn = QVx + QCn = QCx + DQS = DQSx + + do n=1,nmax + + QVp = QVn + QCp = QCn + CFp = CFn + TEp = TEn +! fQip= fQi + + if(pdfflag < 2) then + sigmaqt1 = ALPHA*QSn + sigmaqt2 = ALPHA*QSn + elseif(pdfflag == 2) then + sigmaqt1 = ALPHA*QSn + sigmaqt2 = ALPHA*QSn + elseif(pdfflag == 4) then + sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) + endif + + qsnx = qsn*SCICE + 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) + + DQCALL = QCn - QCp + CF = CFn * ( 1.0-AF) + +! call Bergeron_iter (DT, PL, TEp, QT, QCi, QAi, QCl, QAl, +! & CF, AF, NL, NI, DQCALL, fQi) + + if ( AF > 0. ) then + QAo = QAx + else + QAo = 0. + end if + + + ALHX = (1.0-fQi)*alhlbcp + fQi*alhsbcp + + if(pdfflag == 1) then + QCn = QCp + (QCn- QCp) + & / (1.0 - (CFn*(ALPHA-1.0) - QCn/QSn) *DQS*ALHX) + elseif(pdfflag == 2) then + if (n < nmax) QCn = QCp + ( QCn - QCp ) * 0.5 + endif + + QVn = QVp - (QCn - QCp) + 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 + +! 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.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 + DQS = 0.0 + endif + + enddo + + CFo = CFn + CF = CFn + QCo = QCn +! QVo = QVn +! TEo = TEn +! TE = TEn + + if ( AF < 1.0 ) then + CF = CFo * ( 1.0-AF) + QCo = QCo * ( 1.0-AF) + QAo = QAo * AF + else + CF = 0.0 + QAo = QA + QC + QCo = 0.0 + QT = QAo + QV + QAo = MAX(QT-QSx, 0.0) + end if + + dQCl = 0.0 + dQCi = 0.0 + dQAl = 0.0 + dQAi = 0.0 + +!large scale QCx is not in envi + + QCx = QCo - QC +! Anning Cheng prevented unstable here + if (QCx < -1.e-3) QCx = -1.e-3 + if (QCx < 0.0) then + dQCl = max(QCx, -QCl) + dQCi = max(QCx-dQCl, -QCi) + else + dQCi = QCx * fQi + dQCl = QCx - dQCi + end if + +!Anvil QAx is not in anvil + QAx = QAo - QA +! Anning Cheng prevented unstable here + if(QAx < -1.e-3) QAx = -1.e-3 + + if (QAx < 0.0) then + dQAl = max(QAx, -QAl) + dQAi = max(QAx-dQAl, -QAi) + else + dQAi = QAx * fQi + dQAl = QAx - dQAi + end if + +! if(.false.) then !Anning turn it off causing unstable +! if ( AF < 1.e-5 ) then +! dQAi = -QAi +! dQAl = -QAl +! end if +! if ( CF < 1.e-5 ) then +! dQCi = -QCi +! dQCl = -QCl +! end if +! end if + + QAi = QAi + dQAi + QAl = QAl + dQAl + QCi = QCi + dQCi + QCl = QCl + dQCl + QV = QV - ( dQAi+dQCi+dQAl+dQCl) + + + TE = TE + (alhlbcp * (dQAi+dQCi+dQAl+dQCl) + & + alhfbcp * (dQAi+dQCi)) + + + + if ( QAo <= 0. ) then + QV = QV + QAi + QAl + TE = TE - alhsbcp*QAi - alhlbcp*QAl + QAi = 0. + QAl = 0. + AF = 0. + end if + + CALL fix_up_clouds_2M(QV, TE, QCl, QCi, CF, QAl, QAi, AF, NL, NI) + + end subroutine hystpdf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine pdffrac (flag,qtmean,sigmaqt1,sigmaqt2,qstar,clfrac) + implicit none + + integer flag + + real :: qtmean, sigmaqt1, sigmaqt2, qstar, clfrac + + real :: qtmode, qtmin, qtmax, qtmedian, aux + + if(flag == 1) then + aux = qtmean + sigmaqt1 - qstar + if (aux < 0.0) then + clfrac = 0. + else + if(sigmaqt1 > 0.0) then + clfrac = min(0.5*aux/sigmaqt1, 1.0) + else + clfrac = 1. + endif + endif + elseif(flag == 2) then + qtmode = qtmean + (sigmaqt1-sigmaqt2)/3. + qtmin = min(qtmode-sigmaqt1,0.) + qtmax = qtmode + sigmaqt2 + if(qtmax < qstar) then + clfrac = 0. + elseif ( (qtmode <= qstar).and.(qstar < qtmax) ) then + clfrac = (qtmax-qstar)*(qtmax-qstar) / + & ((qtmax-qtmin)*(qtmax-qtmode)) + elseif ( (qtmin <= qstar).and.(qstar < qtmode) ) then + clfrac = 1. - ((qstar-qtmin)*(qstar-qtmin) + & /( (qtmax-qtmin)*(qtmode-qtmin))) + elseif ( qstar <= qtmin ) then + clfrac = 1. + endif + 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)) + else + clfrac = 0.0 + end if + endif + + return + end subroutine pdffrac + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine pdfcondensate (flag,qtmean4,sigmaqt14,sigmaqt24, + & qstar4,condensate4, clfrac4) + implicit none + + integer flag + + real qtmean4, sigmaqt14, sigmaqt24, qstar4, condensate4, clfrac4 + + real *8 :: qtmode, qtmin, qtmax, constA, constB, cloudf + &, term1, term2, term3 + &, qtmean, sigmaqt1, sigmaqt2, qstar, condensate + &, qtmedian, aux, clfrac, tx1 + + qtmean = dble(qtmean4) + sigmaqt1 = dble(sigmaqt14) + sigmaqt2 = dble(sigmaqt24) + qstar = dble(qstar4) + clfrac = dble(clfrac4) + + if(flag == 1) then + if(qtmean+sigmaqt1 < qstar) then + condensate = 0.d0 + elseif(qstar > qtmean-sigmaqt1) then + if(sigmaqt1 > 0.d0) then + tx1 = min(qtmean+sigmaqt1-qstar, 2.d0*sigmaqt1) + condensate = tx1*tx1 / (4.d0*sigmaqt1) + else + condensate = qtmean - qstar + endif + else + condensate = qtmean - qstar + endif + elseif(flag == 2) then + qtmode = qtmean + (sigmaqt1-sigmaqt2)/3.d0 + qtmin = min(qtmode-sigmaqt1,0.d0) + qtmax = qtmode + sigmaqt2 + if ( qtmax < qstar ) then + condensate = 0.d0 + elseif ( qtmode <= qstar .and. qstar < qtmax ) then + constB = 2.d0 / ( (qtmax - qtmin)*(qtmax-qtmode) ) + cloudf = (qtmax-qstar)*(qtmax-qstar) * 0.5d0 * constB + term1 = (qstar*qstar*qstar)/3.d0 + term2 = (qtmax*qstar*qstar)/2.d0 + term3 = (qtmax*qtmax*qtmax)/6.d0 + condensate = constB * (term1-term2+term3) - qstar*cloudf + elseif ( qtmin <= qstar .and. qstar < qtmode ) then + constA = 2.d0 / ((qtmax-qtmin)*(qtmode-qtmin)) + cloudf = 1.d0 - (qstar-qtmin)*(qstar-qtmin)*0.5d0*constA + term1 = qstar*qstar*qstar/3.d0 + term2 = qtmin*qstar*qstar/2.d0 + term3 = qtmin*qtmin*qtmin/6.d0 + condensate = qtmean - (constA*(term1-term2+term3)) + & - qstar*cloudf + elseif ( qstar <= qtmin ) then + condensate = qtmean - qstar + endif + + elseif(flag == 4) then + + if (qtmean > 1.0e-20) then + aux = 0.5*sigmaqt1*sigmaqt1 + qtmedian = qtmean*exp(-aux) + aux = (aux + log(qtmedian/qstar))/(sqrt(2.0)*sigmaqt1) + aux = min(max(aux, -20.0), 20.0) + aux = 1.0 + dble(erf_app(sngl(aux))) + condensate = (0.5*qtmean*aux/qstar - clfrac) * qstar + condensate= min(condensate, qtmean) + else + condensate = 0.0 + end if + + endif + condensate4 = real(condensate) + + return + end subroutine pdfcondensate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine cnvsrc( DT, ICEPARAM, SCLMFDFR, MASS, iMASS, PL, + & TE, QV, DCF, DMF, QLA, QIA, CF, AF, QS, + & NL, NI, CNVFICE, CNVNDROP, CNVNICE) + + real, intent(in) :: DT, ICEPARAM, SCLMFDFR, MASS, iMASS, QS + &, DMF,PL, DCF, CF + real, intent(inout) :: TE, AF,QV, QLA, QIA, NI, NL + &, CNVFICE, CNVNDROP, CNVNICE + + real :: TEND,QVx,QCA,fQi + + integer, parameter :: STRATEGY = 3 + real, parameter :: RL_cub = 1.0e-15, RI_cub = 6.4e-14 + &, minrhx = 0.001 + + fQi = 0.0 + + if (TE < T_ICE_ALL) then + fQi = 1.0 + elseif (TE > T_ICE_MAX) then + fQi = 0.0 + else + fQi = CNVFICE + end if + + +! TEND = DCF*iMASS + +! QLA = QLA + (1.0-fQi)* TEND*DT +! QIA = QIA + fQi * TEND*DT + + + if ( ( (1.0-fQi)*DCF > 0.0) .and. (CNVNDROP <= 0.0)) then + CNVNDROP = (1.0-fQi)*DCF/( 1.333 * MAPL_PI *RL_cub*997.0) + end if + + if ((fQi*DCF > 0.0) .and. (CNVNICE <= 0.0)) then + CNVNICE = fQi*DCF/( 1.333 * MAPL_PI *RI_cub*500.0) + end if + + NL = max(NL + CNVNDROP*iMASS*DT, 0.0) + NI = max(NI + CNVNICE*iMASS*DT, 0.0) + +! TE = TE + (alhsbcp-alhlbcp) * fQi * TEND * DT + +! QCA = QLA + QIA + + TEND = DMF*iMASS * SCLMFDFR + AF = min(AF + TEND*DT, 1.0) + + if ( AF < 1.0 ) then + QVx = ( QV - QS * AF )/(1.-AF) + else + QVx = QS + end if + +! if (STRATEGY == 1) then +! if ( (( QVx - minrhx*QS ) < 0.0 ) .and. (AF > 0.) ) then +! AF = (QV - minrhx*QS )/( QS*(1.0-minrhx) ) +! end if +! if ( AF < 0. ) then +! AF = 0. +! QV = QV + QLA + QIA +! TE = TE - (alhlbcp*QLA + alhsbcp*QIA) +! QLA = 0. +! QIA = 0. +! end if +! else if (STRATEGY == 2) then +! if ( (( QVx - minrhx*QS ) < 0.0 ) .and. (AF > 0.) ) then +! QV = QV + (1.-AF)*( minrhx*QS - QVx ) +! QCA = QCA - (1.-AF)*( minrhx*QS - QVx ) +! TE = TE - (1.-AF)*( minrhx*QS - QVx )* alhlbcp +! end if +! end if + + end subroutine cnvsrc + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine PRECIP3( K,LM , DT , FRLAND , RHCR3 , QPl , QPi , + & QCl , QCi , TE , QV , mass , imass , PL , dZE , QDDF3 , AA , BB , + & AREA , RAIN , SNOW , PFl_above , PFi_above , EVAP_DD_above, + & SUBL_DD_above, REVAP_DIAG , RSUBL_DIAG , ACRLL_DIAG , + & ACRIL_DIAG , PFL_DIAG , PFI_DIAG , VFALLRN , VFALLSN , FRZ_DIAG , + & ENVFC,DDRFC, AF, CF, PCBL,i ) + + + integer, intent(in) :: K,LM,i + + real, intent(in ) :: DT + + real, intent(inout) :: QV,QPl,QPi,QCl,QCi,TE + + real, intent(in ) :: mass,imass + real, intent(in ) :: PL + real, intent(in ) :: AA,BB + real, intent(in ) :: RHCR3 + real, intent(in ) :: dZE + real, intent(in ) :: QDDF3 + real, intent( out) :: RAIN,SNOW + real, intent(in ) :: AREA + real, intent(in ) :: FRLAND + + real, intent(inout) :: PFl_above, PFi_above + real, intent(inout) :: EVAP_DD_above, SUBL_DD_above + + real, intent( out) :: REVAP_DIAG + real, intent( out) :: RSUBL_DIAG + real, intent( out) :: ACRLL_DIAG,ACRIL_DIAG + real, intent( out) :: PFL_DIAG, PFI_DIAG + real, intent(inout) :: FRZ_DIAG + real, intent( out) :: VFALLSN, VFALLRN + + real, intent(in ) :: ENVFC,DDRFC + + real, intent(in ) :: AF,CF, PCBL + + + real :: PFi,PFl,QS,dQS,ENVFRAC + real,save :: TKo,QKo,QSTKo,DQSTKo,RH_BOX,T_ED,QPlKo,QPiKo + real :: Ifactor,RAINRAT0,SNOWRAT0 + real :: FALLRN,FALLSN,VEsn,VErn,NRAIN,NSNOW,Efactor + + real :: TinLAYERrn,DIAMrn,DROPRAD + real :: TinLAYERsn,DIAMsn,FLAKRAD,pl100 + + real :: EVAP,SUBL,ACCR,MLTFRZ,EVAPx,SUBLx + real :: EVAP_DD,SUBL_DD,DDFRACT + real :: LANDSEAF + + real :: tmpARR, CFR, aux + + real, parameter :: TRMV_L = 1.0 + + real :: TAU_FRZ, TAU_MLT, QSICE, DQSI + + integer :: NS, NSMX, itr,L + + logical, parameter :: taneff = .true. + + real, parameter :: B_SUB = 1.00 + real esl,esi, esn,desdt,weight,tc,hlatsb,hlatvp,hltalt,tterm, + & gam + logical lflg + + + pl100=pl*100 + if(taneff) then + aux = min(max((pl- PCBL)/10.0, -20.0), 20.0) + aux = 1.0/(1.0+exp(-aux)) + envfrac = ENVFC + (1.0-ENVFC)*aux + envfrac = min(envfrac,1.) + else + ENVFRAC = ENVFC + endif + + CFR= AF+CF + if ( CFR < 0.99) then + tmpARR = 1./(1.-CFR) + else + tmpARR = 0.0 + end if + + + IF ( AREA > 0. ) THEN + Ifactor = 1./ ( AREA ) + ELSE + Ifactor = 1.00 + END if + + Ifactor = MAX( Ifactor, 1.) + + PFL_DIAG = 0. + PFI_DIAG = 0. + ACRIL_DIAG = 0. + ACRLL_DIAG = 0. + REVAP_DIAG = 0. + RSUBL_DIAG = 0. + + +! dQS = DQSAT( TE, PL, QSAT = QS ) +! call vqsatd2_single( TE, pl*100., esl,QS,DQS) + esn=min(fpvs(TE),pl100) + QS= min(epsqs*esn/(pl100-omeps*esn),1.) +! TKO is not defined yet here Anning Cheng + TKO = TE +! QSICE = QSATIC( min(TKo, T_ICE_MAX), PL*100.0 , DQ=DQSI ) +! call vqsatd2_ice_single(min(TKo, T_ICE_MAX),PL*100.0, +! & esl,QSICE,DQSI) + esi=min(fpvsi(TKo),pl100) + QSICE= min(epsqs*esi/(pl100-omeps*esi),1.) + hltalt = hlatv + hlatf + desdt = hltalt*esi/(rgasv*TKo*TKo) + if (QSICE < 1.0) then + gam = hltalt*QSICE*pl100*desdt/(MAPL_CP*esi + & * (pl100 - omeps*esi)) + else + gam = 0.0 + endif + DQSI = (MAPL_CP/hltalt)*gam + + + DDFRACT = DDRFC + + IF (K == 1) THEN + PFl = QPl*MASS + PFi = QPi*MASS + + EVAP_DD = 0. + SUBL_DD = 0. + + VFALLRN = 0.0 + VFALLSN = 0.0 + ELSE + QPl = QPl + PFl_above * iMASS + PFl = 0.00 + QPi = QPi + PFi_above * iMASS + PFi = 0.00 + + + ACCR = B_SUB * C_ACC * ( QPl*MASS ) *QCl + + ACCR = MIN( ACCR , QCl ) + + QPl = QPl + ACCR + QCl = QCl - ACCR + + ACRLL_DIAG = ACCR / DT + + + ACCR = B_SUB * C_ACC * ( QPi*MASS ) *QCl + + ACCR = MIN( ACCR , QCl ) + + QPi = QPi + ACCR + QCl = QCl - ACCR + + TE = TE + alhfbcp*ACCR + + ACRIL_DIAG = ACCR / DT + + RAINRAT0 = Ifactor*QPl*MASS/DT + SNOWRAT0 = Ifactor*QPi*MASS/DT + + call MARSHPALMQ2(RAINRAT0,PL,DIAMrn,NRAIN,FALLrn,VErn) + call MARSHPALMQ2(SNOWRAT0,PL,DIAMsn,NSNOW,FALLsn,VEsn) + + IF ( FRLAND < 0.1 ) THEN + + END IF + + VFALLRN = FALLrn + VFALLSN = FALLsn + + TinLAYERrn = dZE / ( max(FALLrn,0.)+0.01 ) + TinLAYERsn = dZE / ( max(FALLsn,0.)+0.01 ) + + TAU_FRZ = 5000. + + MLTFRZ = 0.0 + IF ( (TE > MAPL_TICE ) .and. (TE <= MAPL_TICE+5. ) ) THEN + MLTFRZ = TinLAYERsn * QPi *( TE - MAPL_TICE ) / TAU_FRZ + MLTFRZ = MIN( QPi , MLTFRZ ) + TE = TE - alhfbcp*MLTFRZ + QPl = QPl + MLTFRZ + QPi = QPi - MLTFRZ + END IF + FRZ_DIAG = FRZ_DIAG - MLTFRZ / DT + + MLTFRZ = 0.0 + IF ( TE > MAPL_TICE+5. ) THEN + MLTFRZ = QPi + TE = TE - alhfbcp*MLTFRZ + QPl = QPl + MLTFRZ + QPi = QPi - MLTFRZ + END IF + FRZ_DIAG = FRZ_DIAG - MLTFRZ / DT + + MLTFRZ = 0.0 + if ( K >= LM-1 ) THEN + IF ( TE > MAPL_TICE+0. ) THEN + MLTFRZ = QPi + TE = TE - alhfbcp*MLTFRZ + QPl = QPl + MLTFRZ + QPi = QPi - MLTFRZ + END IF + endif + FRZ_DIAG = FRZ_DIAG - MLTFRZ / DT + + + MLTFRZ = 0.0 + IF ( TE <= MAPL_TICE ) THEN + TE = TE + alhfbcp*QPl + QPi = QPl + QPi + MLTFRZ = QPl + QPl = 0. + END IF + FRZ_DIAG = FRZ_DIAG + MLTFRZ / DT + + + QKo = QV + TKo = TE + QPlKo = QPl + QPiKo = QPi + + do itr = 1,3 + +! DQSTKo = DQSAT ( TKo , PL,QSAT=QSTko ) +! call vqsatd2_single(TKo, pl*100., esl,QSTko,DQSTKo) + esn=min(fpvs(TKo),pl100) + QSTko= min(epsqs*esn/(pl100-omeps*esn),1.) + tc = TKo - MAPL_TICE + lflg = (tc >= -ttrice .and. tc < 0.) + weight = min(-tc*trinv,1.0) + hlatsb = hlatv + weight*hlatf + hlatvp = hlatv - 2369.0*tc + if (TKo < 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)))) + else + tterm = 0. + end if + desdt = hltalt*esn/(rgasv*TKo*TKo) + tterm*trinv + DQSTKo=(epsqs + omeps*QSTko)/(pl100 - omeps*esn)*desdt + +! QSICE = QSATIC( min(TKo, T_ICE_MAX), PL*100.0 , DQ=DQSI ) +! call vqsatd2_ice_single(min(TKo, T_ICE_MAX),PL*100.0, +! & esl,QSICE,DQSI) + esi=min(fpvsi(TKo),pl100) + QSICE= min(epsqs*esi/(pl100-omeps*esi),1.) + hltalt = hlatv + hlatf + desdt = hltalt*esi/(rgasv*TKo*TKo) + if (QSICE < 1.0) then + gam = hltalt*QSICE*pl100*desdt/(MAPL_CP*esi + & * (pl100 - omeps*esi)) + else + gam = 0.0 + endif + DQSI = (MAPL_CP/hltalt)*gam + + QSTKo = MAX( QSTKo , 1.0e-7 ) + QSICE = MAX( QSICE , 1.0e-7 ) + + if (tmpARR > 0.0) then + QKo =(QKo -QSTKo*CFR)*tmpARR + RH_BOX = QKo/QSTKo + else + RH_BOX = QKo/QSTKo + end if + + IF ( RH_BOX < RHCR3 ) THEN + Efactor = RHO_W * ( AA + BB ) / (RHCR3 - RH_BOX ) + else + Efactor = 9.99e9 + end if + + + LANDSEAF = 1.00 + + + if ( ( RH_BOX < RHCR3 ) .AND. ( DIAMrn > 0.00 ) .AND. + & ( PL > 100.) .AND. ( PL < REVAP_OFF_P ) ) then + DROPRAD = 0.5*DIAMrn + T_ED = Efactor * DROPRAD**2 + T_ED = T_ED * ( 1.0 + DQSTKo*alhlbcp ) + + EVAP = QPl*(1.0 - EXP( -C_EV_R * VErn * LANDSEAF *ENVFRAC* + & TinLAYERrn / T_ED ) ) + ELSE + EVAP = 0.0 + END if + + + + if (tmpARR > 0.0) then + QKo = (QKo -QSICE*CFR)*tmpARR + RH_BOX = QKo/QSICE + else + RH_BOX = QKo/QSICE + end if + IF ( RH_BOX < RHCR3 ) THEN + Efactor = 0.5*RHO_W * ( AA+BB ) / (RHCR3-RH_BOX ) + else + Efactor = 9.99e9 + end if + + + if ( ( RH_BOX < RHCR3 ) .AND. ( DIAMsn > 0.00 ) .AND. + & ( PL > 100. ) .AND. ( PL < REVAP_OFF_P ) ) then + FLAKRAD = 0.5*DIAMsn + T_ED = Efactor * FLAKRAD**2 + T_ED = T_ED * ( 1.0 + DQSI*alhsbcp) + SUBL = QPi*(1.0 - EXP( -C_EV_S * VEsn * LANDSEAF * ENVFRAC + & * TinLAYERsn / T_ED ) ) + + ELSE + SUBL = 0.0 + END IF + + if (itr == 1) then + EVAPx = EVAP + SUBLx = SUBL + else + EVAP = (EVAP+EVAPx) /2.0 + SUBL = (SUBL+SUBLx) /2.0 + endif + + EVAP = EVAP*(1.-CFR) + SUBL = SUBL*(1.-CFR) +! Anning prevent negative QPi and QPl + SUBL = min(QPi, max(SUBL,0.)) + EVAP = min(QPl, max(EVAP,0.)) + + + QKo =QKo + EVAP + SUBL + TKo = TKo - EVAP * alhlbcp - SUBL * alhsbcp + + enddo + QPi = QPi - SUBL + QPl = QPl - EVAP + + + EVAP_DD = EVAP_DD_above + DDFRACT*EVAP*MASS + EVAP = EVAP - DDFRACT*EVAP + SUBL_DD = SUBL_DD_above + DDFRACT*SUBL*MASS + SUBL = SUBL - DDFRACT*SUBL + + + QV = QV + EVAP + SUBL + TE = TE - EVAP * alhlbcp - SUBL * alhsbcp + + REVAP_DIAG = EVAP / DT + RSUBL_DIAG = SUBL / DT + + PFl = QPl*MASS + PFi = QPi*MASS + + PFL_DIAG = PFl/DT + PFI_DIAG = PFi/DT + end if + + + + EVAP = QDDF3*EVAP_DD/MASS + SUBL = QDDF3*SUBL_DD/MASS +! Anning prevent negative QPi and QPl + SUBL = min(QPi, max(SUBL,0.)) + EVAP = min(QPl, max(EVAP,0.)) + QV = QV + EVAP + SUBL + TE = TE - EVAP * alhlbcp - SUBL * alhsbcp + REVAP_DIAG = REVAP_DIAG + EVAP / DT + RSUBL_DIAG = RSUBL_DIAG + SUBL / DT + + IF (K == LM) THEN + RAIN = PFl/DT + SNOW = PFi/DT + END IF + + QPi = 0. + QPl = 0. + + PFl_above = PFl + PFi_above = Pfi + + EVAP_DD_above = EVAP_DD + SUBL_DD_above = SUBL_DD + + end subroutine precip3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine MARSHPALMQ2(RAIN,PR,DIAM3,NTOTAL,W,VE) + + real, intent(in ) :: RAIN,PR + real, intent(out) :: DIAM3,NTOTAL,W,VE + + real :: RAIN_DAY,LAMBDA,A,B,SLOPR,DIAM1 + + real, parameter :: N0 = 0.08 + + INTEGER :: IQD + + real :: RX(8) , D3X(8) + + + + RX = (/ 0. , 5. , 20. , 80. , 320. , 1280., 4*1280., 16*1280. /) + D3X = (/ 0.019, 0.032, 0.043, 0.057, 0.076, 0.102, 0.137 , + & 0.183 /) + + RAIN_DAY = RAIN * 3600. *24. + + IF ( RAIN_DAY <= 0.00 ) THEN + DIAM1 = 0.00 + DIAM3 = 0.00 + NTOTAL= 0.00 + W = 0.00 + END IF + + DO IQD = 1,7 + IF ( (RAIN_DAY <= RX(IQD+1)) .AND. (RAIN_DAY > RX(IQD))) THEN + SLOPR =( D3X(IQD+1)-D3X(IQD) ) / ( RX(IQD+1)-RX(IQD)) + DIAM3 = D3X(IQD) + (RAIN_DAY-RX(IQD))*SLOPR + END IF + END DO + + IF ( RAIN_DAY >= RX(8) ) THEN + DIAM3=D3X(8) + END IF + + NTOTAL = 0.019*DIAM3 + + DIAM3 = 0.664 * DIAM3 + + W = (2483.8 * DIAM3 + 80.)*SQRT(1000./PR) + + VE = MAX( 0.99*W/100. , 1.000 ) + + DIAM1 = 3.0*DIAM3 + + DIAM1 = DIAM1/100. + DIAM3 = DIAM3/100. + W = W/100. + NTOTAL = NTOTAL*1.0e6 + + end subroutine MARSHPALMQ2 +!========================================================== + + subroutine MICRO_AA_BB_3(TEMP,PR,Q_SAT,AA,BB) + + real, intent(in ) :: TEMP,Q_SAT + real, intent(in ) :: PR + real, intent(out) :: AA,BB + + real :: E_SAT + + real, parameter :: EPSILON = 0.622 + real, parameter :: K_COND = 2.4e-2 + real, parameter :: DIFFU = 2.2e-5 + + E_SAT = 100.* PR * Q_SAT /( (EPSILON) + (1.0-(EPSILON))*Q_SAT ) + + AA = ( GET_ALHX3(TEMP)**2 ) / ( K_COND*MAPL_RVAP*(TEMP**2) ) + + + BB = MAPL_RVAP*TEMP / ( DIFFU*(1000./PR)*E_SAT ) + + end subroutine MICRO_AA_BB_3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function LDRADIUS3(PL,TE,QCL,NN) RESULT(RADIUS) + + real, intent(in) :: TE,PL,NN,QCL + real :: RADIUS + + real :: MUU,RHO + + + RHO = 100.*PL / (MAPL_RGAS*TE ) + MUU = QCL * RHO + RADIUS = MUU/(NN*RHO_W*(4./3.)*MAPL_PI) + RADIUS = RADIUS**(1./3.) + + + end function LDRADIUS3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function ICE_FRACTION (TEMP) RESULT(ICEFRCT) + real, intent(in) :: TEMP + real :: ICEFRCT + + ICEFRCT = 0.00 + if ( TEMP <= T_ICE_ALL ) then + ICEFRCT = 1.000 + else if ( (TEMP > T_ICE_ALL) .AND. (TEMP <= T_ICE_MAX) ) then + ICEFRCT = 1.00 - ( TEMP - T_ICE_ALL ) / ( T_ICE_MAX - + & T_ICE_ALL ) + end if + ICEFRCT = MIN(ICEFRCT,1.00) + ICEFRCT = MAX(ICEFRCT,0.00) + + ICEFRCT = ICEFRCT**ICEFRPWR + + end function ICE_FRACTION + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function GET_ALHX3(T) RESULT(ALHX3) + + real, intent(in) :: T + real :: ALHX3 + + real :: T_X + + T_X = T_ICE_MAX + + if ( T < T_ICE_ALL ) then + ALHX3=MAPL_ALHS + end if + + if ( T > T_X ) then + ALHX3=MAPL_ALHL + end if + + if ( (T <= T_X) .and. (T >= T_ICE_ALL) ) then + ALHX3 = MAPL_ALHS + (MAPL_ALHL-MAPL_ALHS) + & *( T - T_ICE_ALL )/( T_X - T_ICE_ALL ) + end if + + end function GET_ALHX3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + real function ICEFRAC(T,T_TRANS,T_FREEZ) + + real, intent(in) :: T + real, intent(in),optional :: T_TRANS + real, intent(in),optional :: T_FREEZ + + real :: T_X,T_F + + if (present( T_TRANS )) then + T_X = T_TRANS + else + T_X = T_ICE_MAX + endif + if (present( T_FREEZ )) then + T_F = T_FREEZ + else + T_F = T_ICE_ALL + endif + + + if ( T < T_F ) ICEFRAC=1.000 + + if ( T > T_X ) ICEFRAC=0.000 + + if ( T <= T_X .and. T >= T_F ) then + ICEFRAC = 1.00 - ( T - T_F ) /( T_X - T_F ) + endif + + end function ICEFRAC + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!Parititions DQ into ice and liquid. Follows Morrison and Gettelman, 2008 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine Bergeron_iter ( DTIME , PL , TE , QV , QILS , QICN , + & QLLS , QLCN , CF , AF , NL , NI , DQALL , FQI ) + + real , intent(in ) :: DTIME, PL, TE + real , intent(inout ) :: DQALL + real , intent(in) :: QV, QLLS, QLCN, QICN, QILS + real , intent(in) :: CF, AF, NL, NI + real, intent (out) :: FQI + real :: DC, TEFF,QCm,DEP, QC, QS, RHCR, DQSL, DQSI, QI, TC, DIFF, + & DENAIR, DENICE, AUX, DCF, QTOT, LHCORR, QL, DQI, DQL, QVINC, + & QSLIQ, CFALL, new_QI, new_QL, QSICE, fQI_0, QS_0, DQS_0, FQA, + & NIX + real esl,esi, esn,desdt,weight,hlatsb,hlatvp,hltalt,tterm, + & gam,pl100 + + + pl100=pl*100 + DIFF = 0.0 + DEP=0.0 + QI = QILS + QICN + QL = QLLS +QLCN + QTOT=QI+QL + FQA = 0.0 + if (QTOT .gt. 0.0) FQA = (QICN+QILS)/QTOT + NIX= (1.0-FQA)*NI + + DQALL=DQALL/DTIME + CFALL= min(CF+AF, 1.0) + TC=TE-273.0 + fQI_0 = fQI + + + + if (TE .ge. T_ICE_MAX) then + FQI = 0.0 + elseif(TE .le. T_ICE_ALL) then + FQI = 1.0 + else + + + FQI = 0.0 + if (QILS .le. 0.0) return + + QVINC= QV +! QSLIQ = QSATLQ( TE , PL*100.0 , DQ=DQSL ) +! call vqsatd2_water_single(TE,PL*100.0,esl,QSLIQ,DQSL) + esl=min(fpvsl(TE),pl100) + QSLIQ= min(epsqs*esl/(pl100-omeps*esl),1.) + +! QSICE = QSATIC( TE , PL*100.0 , DQ=DQSI ) +! call vqsatd2_ice_single(TE,PL*100.0,esl,QSICE,DQSI) + esi=min(fpvsi(TE),pl100) + QSICE= min(epsqs*esi/(pl100-omeps*esi),1.) + hltalt = hlatv + hlatf + desdt = hltalt*esi/(rgasv*TE*TE) + if (QSICE < 1.0) then + gam = hltalt*QSICE*pl100*desdt/(MAPL_CP*esi + & * (pl100 - omeps*esi)) + else + gam = 0.0 + endif + DQSI = (MAPL_CP/hltalt)*gam + + + + + QVINC =MIN(QVINC, QSLIQ) + + DIFF=(0.211*1013.25/(PL+0.1))*(((TE+0.1)/273.0)**1.94)*1e-4 + DENAIR = PL*100.0/MAPL_RGAS/TE + DENICE = 1000.0*(0.9167 - 1.75e-4*TC -5.0e-7*TC*TC) + LHcorr = ( 1.0 + DQSI*alhsbcp) + + if ((NIX .gt. 1.0) .and. (QILS .gt. 1.0e-10)) then + DC = max((QILS/(NIX*DENICE*MAPL_PI))**(0.333), 20.0e-6) + else + DC = 20.0e-6 + end if + + + TEFF= NIX*DENAIR*2.0*MAPL_PI*DIFF*DC/LHcorr + + DEP=0.0 + if ((TEFF .gt. 0.0) .and. (QILS .gt. 1.0e-14)) then + AUX =max(min(DTIME*TEFF, 20.0), 0.0) + DEP=(QVINC-QSICE)*(1.0-EXP(-AUX))/DTIME + end if + + DEP=MAX(DEP, -QILS/DTIME) + + DQI = 0.0 + DQL = 0.0 + FQI=0.0 + + if (DQALL .ge. 0.0) then + + if (DEP .gt. 0.0) then + DQI = min(DEP, DQALL + QLLS/DTIME) + DQL = DQALL - DQI + else + DQL=DQALL + DQI = 0.0 + end if + end if + + + if (DQALL .lt. 0.0) then + DQL = max(DQALL, -QLLS/DTIME) + DQI = max(DQALL - DQL, -QILS/DTIME) + end if + + if (DQALL .ne. 0.0) FQI=max(min(DQI/DQALL, 1.0), 0.0) + end if + end subroutine Bergeron_iter + + + +!============================================================================= +! Subroutine Pfreezing: calculates the probability of finding a supersaturated parcel in the grid cell +!SC_ICE is the effective freezing point for ice (Barahona & Nenes. 2009) +! Modified 02/19/15. in situ nucleation only occurs in the non_convective part of the grid cell + + + 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, sigmaqt1, sigmaqt2, qsnx, esl, esi,pl100 + + pl100 = pl*100 + + QA = QAl + QAi + QC = QCl + QCi + CFALL = AF + + 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 + + QCx = QC*tmpARR + QVx = ( QV - QSn*CFALL )*tmpARR +! QVx = QV*tmpARR + + qt = QCx + QVx + + CFio = 0.0 + + QSn = QSn*SC_ICE + + 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 == 4) then + sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) + endif + + call pdffrac(pdfflag,qt,sigmaqt1,sigmaqt2,qsn,CFio) + + PF = min(max(CFio*(1.0-CFALL), 0.0), 0.999) + + + end subroutine Pfreezing + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Instantaneous freezing of condensate!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine meltfrz_inst(IM, LM, TE, QCL, QAL, QCI, QAI, NL, NI) + + integer, intent(in) :: IM, LM + real , intent(inout), dimension(:,:) :: TE,QCL,QCI, QAL, QAI, + & NI, NL + + real , dimension(im,lm) :: fQi,dQil, DQmax, QLTOT, QITOT, FQAL, + & FQAI, dNil, FQA + + QITOT = QCI+QAI + QLTOT = QCL + QAL + FQA = 0.0 + + where (QITOT+QLTOT > 0.0) + FQA= (QAI+QAL)/(QITOT+QLTOT) + end where + + dQil = 0.0 + dNil = 0.0 + DQmax = 0.0 + + where( TE <= T_ICE_ALL ) + DQmax = (T_ICE_ALL - TE)/(alhsbcp-alhlbcp) + dQil = min(QLTOT , DQmax) + end where + + where ((dQil <= DQmax) .and. (dQil > 0.0)) + dNil = NL + end where + + where ((dQil > DQmax) .and. (dQil > 0.0)) + dNil = NL*DQmax/dQil + end where + + dQil = max( 0., dQil ) +! Anning for moisture conservation 11/22/2016 +! QITOT = max(QITOT + dQil, 0.0) +! QLTOT = max(QLTOT - dQil, 0.0) + dQil = min(QLTOT,dQil) + QITOT = QITOT + dQil + QLTOT = QLTOT - dQil + NL = NL - dNil + NI = NI + dNil + TE = TE + (alhsbcp-alhlbcp)*dQil + + dQil = 0.0 + dNil = 0.0 + DQmax = 0.0 + + + where( TE > T_ICE_MAX ) + DQmax = (TE-T_ICE_MAX) / (alhsbcp-alhlbcp) + dQil = min(QITOT, DQmax) + endwhere + + where ((dQil .le. DQmax) .and. (dQil .gt. 0.0)) + dNil = NI + end where + where ((dQil .gt. DQmax) .and. (dQil .gt. 0.0)) + dNil = NI*DQmax/dQil + end where + dQil = max( 0., dQil ) +! Anning for moisture conservation 11/22/2016 +! QLTOT = max(QLTOT+ dQil, 0.) +! QITOT = max(QITOT - dQil, 0.) + dQil = min(QITOT,dQil) + QITOT = QITOT - dQil + QLTOT = QLTOT + dQil + NL = NL + dNil + NI = NI - dNil + + TE = TE - (alhsbcp-alhlbcp)*dQil + + QCI = QITOT*(1.0-FQA) + QAI = QITOT*FQA + QCL = QLTOT*(1.0-FQA) + QAL = QLTOT*FQA + + end subroutine meltfrz_inst + + + +!====================================== + subroutine cloud_ptr_stubs ( + & SMAXL, SMAXI, WSUB, CCN01, CCN04, CCN1, NHET_NUC, NLIM_NUC, SO4, + & ORG, BCARBON, DUST, SEASALT, NCPL_VOL, NCPI_VOL, NRAIN, NSNOW, + & CDNC_NUC, INC_NUC, SAT_RAT, QSTOT, QRTOT, CLDREFFS, CLDREFFR, + & DQVDT_micro,DQIDT_micro, DQLDT_micro, DTDT_micro, RL_MASK, + & RI_MASK, KAPPA, SC_ICE, CFICE, CFLIQ, RHICE, RHLIQ, RAD_CF, + & RAD_QL, RAD_QI, RAD_QS, RAD_QR, RAD_QV, CLDREFFI, CLDREFFL, + & NHET_IMM, NHET_DEP, NHET_DHF, DUST_IMM, DUST_DEP, DUST_DHF, SCF, + & SCF_ALL, SIGW_GW, SIGW_CNV, SIGW_TURB, SIGW_RC, RHCmicro, + & DNHET_IMM, NONDUST_IMM, NONDUST_DEP, BERG, BERGSO, MELT, + & DNHET_CT, DTDT_macro, QCRES, DT_RASP, FRZPP_LS, SNOWMELT_LS, + & QIRES, AUTICE, PFRZ, DNCNUC, DNCHMSPLIT, DNCSUBL, DNCAUTICE, + & DNCACRIS, DNDCCN, DNDACRLS, DNDEVAPC, DNDACRLR, DNDAUTLIQ) +! & DNDCNV, DNCCNV) + + + + real , pointer , dimension(:,:,:) :: SMAXL,SMAXI, WSUB, CCN01, + & CCN04, CCN1, NHET_NUC, NLIM_NUC, SO4, ORG, BCARBON, DUST, + & SEASALT, NCPL_VOL, NCPI_VOL, NRAIN, NSNOW, CDNC_NUC, INC_NUC, + & SAT_RAT, QSTOT, QRTOT, CLDREFFS, CLDREFFR, DQVDT_micro, + &DQIDT_micro, DQLDT_micro, DTDT_micro, RL_MASK, RI_MASK, KAPPA, + & SC_ICE, CFICE, CFLIQ, RHICE, RHLIQ, ALPH, RAD_CF, RAD_QL, RAD_QI, + & RAD_QS, RAD_QR, RAD_QV, CLDREFFI, CLDREFFL, NHET_IMM, NHET_DEP, + & NHET_DHF, DUST_IMM, DUST_DEP, DUST_DHF, SCF, SCF_ALL, SIGW_GW, + & SIGW_CNV, SIGW_TURB, SIGW_RC, RHCmicro, DNHET_IMM, NONDUST_IMM, + & NONDUST_DEP, BERG, BERGSO, MELT, DNHET_CT, DTDT_macro, QCRES, + & DT_RASP, FRZPP_LS, SNOWMELT_LS, QIRES, AUTICE, PFRZ, DNCNUC, + & DNCHMSPLIT, DNCSUBL, DNCAUTICE, DNCACRIS, DNDCCN, DNDACRLS, + & DNDEVAPC, DNDACRLR, DNDAUTLIQ +! & DNDEVAPC, DNDACRLR, DNDAUTLIQ, DNDCNV, DNCCNV + + +!DONIF + + IF( ASSOCIATED(SMAXL) ) SMAXL = 0. + IF( ASSOCIATED(SMAXI) ) SMAXI = 0. + IF( ASSOCIATED(WSUB) ) WSUB = 0. + IF( ASSOCIATED(CCN01) ) CCN01 = 0. + IF( ASSOCIATED(CCN04) ) CCN04 = 0. + IF( ASSOCIATED(CCN1) ) CCN1 = 0. + IF( ASSOCIATED(NHET_NUC) ) NHET_NUC = 0. + IF( ASSOCIATED(NLIM_NUC) ) NLIM_NUC = 0. + IF( ASSOCIATED(SO4) ) SO4 = 0. + IF( ASSOCIATED(ORG) ) ORG = 0. + IF( ASSOCIATED(BCARBON) ) BCARBON = 0. + IF( ASSOCIATED(DUST) ) DUST = 0. + IF( ASSOCIATED(SEASALT) ) SEASALT = 0. + IF( ASSOCIATED(NCPL_VOL) ) NCPL_VOL = 0. + IF( ASSOCIATED(NCPI_VOL) ) NCPI_VOL = 0. + + IF( ASSOCIATED(NRAIN) ) NRAIN = 0. + IF( ASSOCIATED(NSNOW) ) NSNOW = 0. + IF( ASSOCIATED(CDNC_NUC) ) CDNC_NUC = 0. + IF( ASSOCIATED(INC_NUC) ) INC_NUC = 0. + IF( ASSOCIATED(SAT_RAT) ) SAT_RAT = 0. + IF( ASSOCIATED(QSTOT) ) QSTOT = 0. + IF( ASSOCIATED(QRTOT) ) QRTOT = 0. + + IF( ASSOCIATED(DQVDT_micro) ) DQVDT_micro = 0. + IF( ASSOCIATED(DQIDT_micro) ) DQIDT_micro = 0. + IF( ASSOCIATED(DQLDT_micro) ) DQLDT_micro = 0. + IF( ASSOCIATED(DTDT_micro) ) DTDT_micro = 0. + IF( ASSOCIATED(DTDT_macro) ) DTDT_macro = 0. + + IF( ASSOCIATED(RL_MASK) ) RL_MASK = 0. + IF( ASSOCIATED(RI_MASK) ) RI_MASK = 0. + IF( ASSOCIATED(KAPPA) ) KAPPA = 0. + IF( ASSOCIATED(SC_ICE)) SC_ICE = 0. + IF( ASSOCIATED(RHICE) ) RHICE = 0. + IF( ASSOCIATED(RHLIQ) ) RHLIQ = 0. + IF( ASSOCIATED(CFICE) ) CFICE = 0. + IF( ASSOCIATED(CFLIQ) ) CFLIQ = 0. + IF( ASSOCIATED(ALPH) ) ALPH = 0. + + + IF( ASSOCIATED(RAD_CF) ) RAD_CF = 0. + IF( ASSOCIATED(RAD_QL) ) RAD_QL = 0. + IF( ASSOCIATED(RAD_QI) ) RAD_QI = 0. + IF( ASSOCIATED(RAD_QS) ) RAD_QS = 0. + IF( ASSOCIATED(RAD_QR) ) RAD_QR = 0. + IF( ASSOCIATED(RAD_QV) ) RAD_QV = 0. + IF( ASSOCIATED(CLDREFFI) ) CLDREFFI = 0. + IF( ASSOCIATED(CLDREFFL) ) CLDREFFL = 0. + IF( ASSOCIATED(CLDREFFS) ) CLDREFFS = 0. + IF( ASSOCIATED(CLDREFFR) ) CLDREFFR = 0. + + IF( ASSOCIATED(NHET_IMM) ) NHET_IMM = 0. + IF( ASSOCIATED(NHET_DEP) ) NHET_DEP = 0. + IF( ASSOCIATED(NHET_DHF) ) NHET_DHF = 0. + IF( ASSOCIATED(DUST_IMM) ) DUST_IMM = 0. + IF( ASSOCIATED(DUST_DEP) ) DUST_DEP = 0. + IF( ASSOCIATED(DUST_DHF) ) DUST_DHF = 0. + IF( ASSOCIATED(NONDUST_IMM) ) NONDUST_IMM = 0. + IF( ASSOCIATED(NONDUST_DEP) ) NONDUST_DEP = 0. + + + IF( ASSOCIATED(SCF) ) SCF = 0. + IF( ASSOCIATED(SCF_ALL) ) SCF_ALL = 0. + IF( ASSOCIATED(SIGW_GW) ) SIGW_GW = 0. + IF( ASSOCIATED(SIGW_CNV) ) SIGW_CNV = 0. + IF( ASSOCIATED(SIGW_TURB) ) SIGW_TURB = 0. + IF( ASSOCIATED(SIGW_RC) ) SIGW_RC = 0. + IF( ASSOCIATED(RHCmicro) ) RHCmicro = 0. + IF( ASSOCIATED(DNHET_IMM) ) DNHET_IMM = 0. + IF( ASSOCIATED(BERG) ) BERG = 0. + IF( ASSOCIATED(BERGSO)) BERGSO = 0. + IF( ASSOCIATED(MELT) ) MELT = 0. + IF( ASSOCIATED(DNHET_CT) ) DNHET_CT = 0. + IF( ASSOCIATED(DT_RASP) ) DT_RASP = 0. + + IF( ASSOCIATED(QCRES) ) QCRES = 0. + IF( ASSOCIATED(QIRES) ) QIRES = 0. + IF( ASSOCIATED(AUTICE) ) AUTICE = 0. + IF( ASSOCIATED(FRZPP_LS) ) FRZPP_LS = 0. + IF( ASSOCIATED(SNOWMELT_LS) ) SNOWMELT_LS = 0. + IF( ASSOCIATED(PFRZ) ) PFRZ = 0. + + IF( ASSOCIATED(DNCNUC) ) DNCNUC = 0. + IF( ASSOCIATED(DNCSUBL) ) DNCSUBL = 0. + IF( ASSOCIATED(DNCHMSPLIT) ) DNCHMSPLIT = 0. + IF( ASSOCIATED(DNCAUTICE) ) DNCAUTICE = 0. + IF( ASSOCIATED(DNCACRIS) ) DNCACRIS = 0. + IF( ASSOCIATED(DNDCCN) ) DNDCCN = 0. + IF( ASSOCIATED(DNDACRLS) ) DNDACRLS = 0. + IF( ASSOCIATED(DNDACRLR) ) DNDACRLR = 0. + IF( ASSOCIATED(DNDEVAPC) ) DNDEVAPC = 0. + IF( ASSOCIATED(DNDAUTLIQ) ) DNDAUTLIQ = 0. +! IF( ASSOCIATED(DNDCNV) ) DNDCNV = 0. +! IF( ASSOCIATED(DNCCNV) ) DNCCNV = 0. + + end subroutine cloud_ptr_stubs + +!C======================================================================= +!C +!C *** REAL FUNCTION erf (overwrites previous versions) +!C *** THIS SUBROUTINE CALCULATES THE ERROR FUNCTION USING A +!C *** POLYNOMIAL APPROXIMATION +!C +!C======================================================================= +!C + REAL FUNCTION erf_app(x) + REAL :: x + REAL*8:: AA(4), axx, y + DATA AA /0.278393d0,0.230389d0,0.000972d0,0.078108d0/ + + y = dabs(dble(x)) + axx = 1.d0 + y*(AA(1)+y*(AA(2)+y*(AA(3)+y*AA(4)))) + axx = axx*axx + axx = axx*axx + axx = 1.d0 - (1.d0/axx) + if(x.le.0.) then + erf_app = sngl(-axx) + else + erf_app = sngl(axx) + endif + RETURN + END FUNCTION + + end module cldmacro diff --git a/physics/cs_conv_aw_adj.F90 b/physics/cs_conv_aw_adj.F90 new file mode 100644 index 000000000..7092db4b1 --- /dev/null +++ b/physics/cs_conv_aw_adj.F90 @@ -0,0 +1,144 @@ +!> \file cs_conv_aw_adj.f90 +!! This file contains the Arakawa-Wu adjustment of large-scale microphysics tendencies. + +module cs_conv_aw_adj + + implicit none + + private + + public :: cs_conv_aw_adj_init, cs_conv_aw_adj_run, cs_conv_aw_adj_finalize + + contains + + subroutine cs_conv_aw_adj_init() + end subroutine cs_conv_aw_adj_init + + subroutine cs_conv_aw_adj_finalize() + end subroutine cs_conv_aw_adj_finalize + +!! \section arg_table_cs_conv_aw_adj_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |-----------------|---------------------------------------------------------------|----------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | im | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | number of veritcal levels | count | 0 | integer | | in | F | +!! | do_cscnv | flag_for_Chikira_Sugiyama_deep_convection | flag for Chikira-Sugiyama convection | flag | 0 | logical | | in | F | +!! | do_aw | flag_for_Arakawa_Wu_adjustment | flag for Arakawa Wu scale-aware adjustment | flag | 0 | logical | | in | F | +!! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | +!! | ntrac | number_of_tracers | number of tracers | count | 0 | integer | | in | F | +!! | ncld | number_of_hydrometeors | number of hydrometeors | count | 0 | integer | | in | F | +!! | ntcw | index_for_liquid_cloud_condensate | tracer index for cloud condensate (or liquid water) | index | 0 | integer | | in | F | +!! | ntclamt | index_for_cloud_amount | tracer index for cloud amount integer | index | 0 | integer | | in | F | +!! | nncl | number_of_tracers_for_cloud_condensate | number of tracers for cloud condensate | count | 0 | integer | | in | F | +!! | con_g | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | sigmafrac | convective_updraft_area_fraction | convective updraft area fraction | frac | 2 | real | kind_phys | in | F | +!! | gt0 | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | inout | F | +!! | gq0 | tracer_concentration_updated_by_physics | tracer concentration updated by physics | kg kg-1 | 3 | real | kind_phys | inout | F | +!! | save_t | air_temperature_save | air temperature before entering a physics scheme | K | 2 | real | kind_phys | in | F | +!! | save_q | tracer_concentration_save | tracer concentration before entering a physics scheme | kg kg-1 | 3 | real | kind_phys | in | F | +!! | prsi | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | cldfrac | cloud_fraction_for_MG | cloud fraction used by Morrison-Gettelman MP | frac | 2 | real | kind_phys | inout | F | +!! | subcldfrac | subgrid_scale_cloud_fraction_from_shoc | subgrid-scale cloud fraction from the SHOC scheme | frac | 2 | real | kind_phys | inout | F | +!! | prcp | lwe_thickness_of_explicit_precipitation_amount | explicit precipitation (rain, ice, snow, graupel, ...) on physics timestep | m | 1 | real | kind_phys | inout | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine cs_conv_aw_adj_run(im, levs, do_cscnv, do_aw, do_shoc, & + ntrac, ncld, ntcw, ntclamt, nncl, con_g, sigmafrac, & + gt0, gq0, save_t, save_q, prsi, cldfrac, subcldfrac, & + prcp, errmsg, errflg) + + use machine, only: kind_phys + + implicit none + +! --- interface variables + integer, intent(in) :: im, levs + logical, intent(in) :: do_cscnv, do_aw, do_shoc + integer, intent(in) :: ntrac, ncld, ntcw, ntclamt, nncl + real(kind_phys), intent(in) :: con_g + real(kind_phys), dimension(im,levs), intent(inout) :: sigmafrac + real(kind_phys), dimension(im,levs), intent(inout) :: gt0 + real(kind_phys), dimension(im,levs,ntrac), intent(inout) :: gq0 + real(kind_phys), dimension(im,levs), intent(in) :: save_t + real(kind_phys), dimension(im,levs,ntrac), intent(in) :: save_q + real(kind_phys), dimension(im,levs+1), intent(in) :: prsi + real(kind_phys), dimension(im,levs), intent(inout) :: cldfrac + real(kind_phys), dimension(im,levs), intent(inout) :: subcldfrac + real(kind_phys), dimension(im), intent(inout) :: prcp + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + +! --- local variables + real(kind=kind_phys), dimension(im) :: temrain1 + real(kind=kind_phys) :: tem1, tem2 + real(kind=kind_phys) :: onebg + integer :: i, k, n + +! --- initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + !if (do_cscnv .and. do_aw) then + + onebg = 1.0_kind_phys/con_g + +! 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 +! fsigma = 0. ! don't apply any AW correction, in addition comment next line +! fsigma = sigmafrac + +! adjust sfc rainrate for conservation +! vertically integrate reduction of water increments, reduce precip by that amount + + temrain1(:) = 0.0 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) + gt0(i,k) = gt0(i,k) - tem1 * (gt0(i,k)-save_t(i,k)) + tem2 = tem1 * (gq0(i,k,1)-save_q(i,k,1)) + gq0(i,k,1) = gq0(i,k,1) - tem2 + temrain1(i) = temrain1(i) - (prsi(i,k)-prsi(i,k+1)) * tem2 * onebg + enddo + enddo +! add convective clouds + if (do_shoc) then + do k = 1,levs + do i = 1,im + subcldfrac(i,k) = min(1.0, subcldfrac(i,k) + sigmafrac(i,k)) + enddo + enddo + if (ncld == 5) then + gq0(:,:,ntclamt) = subcldfrac(:,:) + endif + elseif (ncld == 2) then + do k = 1,levs + do i = 1,im + cldfrac(i,k) = min(1.0, cldfrac(i,k) + sigmafrac(i,k)) + enddo + enddo + endif + ! + do n=ntcw,ntcw+nncl-1 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) * (gq0(i,k,n)-save_q(i,k,n)) + gq0(i,k,n) = gq0(i,k,n) - tem1 + temrain1(i) = temrain1(i) - (prsi(i,k)-prsi(i,k+1)) * tem1 * onebg + enddo + enddo + enddo + ! + do i = 1,im + prcp(i) = max(prcp(i) - temrain1(i)*0.001, 0.0_kind_phys) + enddo + + !endif + + return + + end subroutine cs_conv_aw_adj_run + +end module cs_conv_aw_adj diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 new file mode 100644 index 000000000..d2a586fe0 --- /dev/null +++ b/physics/m_micro.F90 @@ -0,0 +1,1825 @@ +!> \file m_micro.F90 +!! This file contains the subroutine that call Morrison-Gettelman microphysics (MG2 and MG3) +!! \cite Morrison and Gettelman. + +!> This module contains the CCPP-compliant Morrison-Gettelman microphysics (MG2 and MG3) scheme. +module m_micro + + implicit none + public :: m_micro_init, m_micro_run, m_micro_finalize + private + logical :: is_initialized = .False. + +contains + +!> \section arg_table_m_micro_init Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |------------------------|-------------------------------------------------|---------------------------------------------------------------------------------------------|-------------|------|------------|-----------|--------|----------| +!! | imp_physics | flag_for_microphysics_scheme | choice of microphysics scheme | flag | 0 | integer | | in | F | +!! | imp_physics_mg | flag_for_morrison_gettelman_microphysics_scheme | choice of Morrison-Gettelman rmicrophysics scheme | flag | 0 | integer | | in | F | +!! | fprcp | number_of_frozen_precipitation_species | number of frozen precipitation species | count | 0 | integer | | in | F | +!! | gravit | gravitational_acceleration | gravitational acceleration | m s-2 | 0 | real | kind_phys | in | F | +!! | rair | gas_constant_dry_air | ideal gas constant for dry air | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | rh2o | gas_constant_water_vapor | ideal gas constant for water vapor | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | cpair | specific_heat_of_dry_air_at_constant_pressure | specific heat of dry air at constant pressure | J kg-1 K-1 | 0 | real | kind_phys | in | F | +!! | tmelt | triple_point_temperature_of_water | triple point temperature of water | K | 0 | real | kind_phys | in | F | +!! | latvap | latent_heat_of_vaporization_of_water_at_0C | latent heat of evaporation/sublimation | J kg-1 | 0 | real | kind_phys | in | F | +!! | latice | latent_heat_of_fusion_of_water_at_0C | latent heat of fusion | J kg-1 | 0 | real | kind_phys | in | F | +!! | mg_dcs | mg_autoconversion_size_threshold_ice_snow | autoconversion size threshold for cloud ice to snow for MG microphysics | um | 0 | real | kind_phys | in | F | +!! | mg_qcvar | mg_cloud_water_variance | cloud water relative variance for MG microphysics | | 0 | real | kind_phys | in | F | +!! | mg_ts_auto_ice | mg_time_scale_for_autoconversion_of_ice | autoconversion time scale for ice for MG microphysics | s | 0 | real | kind_phys | in | F | +!! | mg_rhmini | mg_minimum_rh_for_ice | relative humidity threshold parameter for nucleating ice for MG microphysics | none | 0 | real | kind_phys | in | F | +!! | microp_uniform | mg_flag_for_uniform_subcolumns | flag for uniform subcolumns for MG microphysics | flag | 0 | logical | | in | F | +!! | do_cldice | mg_flag_for_cloud_ice_processes | flag for cloud ice processes for MG microphysics | flag | 0 | logical | | in | F | +!! | hetfrz_classnuc | mg_flag_for_heterogeneous_freezing | flag for heterogeneous freezing for MG microphysics | flag | 0 | logical | | in | F | +!! | mg_precip_frac_method | mg_type_of_precip_fraction_method | type of precip fraction method for MG microphysics (in_cloud or max_overlap) | none | 0 | character | len=16 | in | F | +!! | mg_berg_eff_factor | mg_bergeron_efficiency_factor | bergeron efficiency factor for MG microphysics | frac | 0 | real | kind_phys | in | F | +!! | sed_supersat | mg_allow_supersat_after_sed | allow supersaturation after sedimentation for MG microphysics | flag | 0 | logical | | in | F | +!! | do_sb_physics | mg_flag_for_sb2001_autoconversion | flag for SB 2001 autoconversion or accretion for MG microphysics | flag | 0 | logical | | in | F | +!! | mg_do_hail | mg_flag_for_hail | flag for hail for MG microphysics (graupel possible if false) | flag | 0 | logical | | in | F | +!! | mg_do_graupel | mg_flag_for_graupel | flag for graupel for MG microphysics (hail possible if false) | flag | 0 | logical | | in | F | +!! | mg_nccons | mg_flag_drop_concentration_constant | flag for constant droplet concentration for MG microphysics | flag | 0 | logical | | in | F | +!! | mg_nicons | mg_flag_ice_concentration_constant | flag for constant ice concentration for MG microphysics | flag | 0 | logical | | in | F | +!! | mg_ngcons | mg_flag_graupel_concentration_constant | flag for constant graupel concentration for MG microphysics | flag | 0 | logical | | in | F | +!! | mg_ncnst | mg_drop_concentration_constant | droplet concentration constant for MG microphysics | m-3 | 0 | real | kind_phys | in | F | +!! | mg_ninst | mg_ice_concentration_constant | ice concentration constant for MG microphysics | m-3 | 0 | real | kind_phys | in | F | +!! | mg_ngnst | mg_graupel_concentration_constant | graupel concentration constant for MG microphysics | m-3 | 0 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, cpair,& + tmelt, latvap, latice, mg_dcs, mg_qcvar, mg_ts_auto_ice, & + mg_rhmini, microp_uniform, do_cldice, hetfrz_classnuc, & + mg_precip_frac_method, mg_berg_eff_factor, sed_supersat, & + do_sb_physics, mg_do_hail, mg_do_graupel, mg_nccons, & + mg_nicons, mg_ngcons, mg_ncnst, mg_ninst, mg_ngnst, errmsg, errflg) + + use machine, only: kind_phys + use cldwat2m_micro, only: ini_micro + use micro_mg2_0, only: micro_mg_init2_0 => micro_mg_init + use micro_mg3_0, only: micro_mg_init3_0 => micro_mg_init + use aer_cloud, only: aer_cloud_init + + integer, intent(in) :: imp_physics, imp_physics_mg, fprcp + logical, intent(in) :: microp_uniform, do_cldice, hetfrz_classnuc, & + sed_supersat, do_sb_physics, mg_do_hail, & + mg_do_graupel, mg_nccons, mg_nicons, mg_ngcons + real(kind=kind_phys), intent(in) :: gravit, rair, rh2o, cpair, tmelt, latvap, latice + real(kind=kind_phys), intent(in) :: mg_dcs, mg_qcvar, mg_ts_auto_ice, mg_rhmini, & + mg_berg_eff_factor, mg_ncnst, mg_ninst, mg_ngnst + character(len=16), intent(in) :: mg_precip_frac_method + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + errmsg = '' + errflg = 0 + + if (is_initialized) return + + if (imp_physics/=imp_physics_mg) then + write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from Morrison-Gettelman MP" + errflg = 1 + return + end if + + if (fprcp <= 0) then + call ini_micro (mg_dcs, mg_qcvar, mg_ts_auto_ice) + elseif (fprcp == 1) then + call micro_mg_init2_0(kind_phys, gravit, rair, rh2o, cpair, & + tmelt, latvap, latice, mg_rhmini, & + mg_dcs, mg_ts_auto_ice, & + mg_qcvar, & + microp_uniform, do_cldice, & + hetfrz_classnuc, & + mg_precip_frac_method, & + mg_berg_eff_factor, & + sed_supersat, do_sb_physics, & + mg_nccons, mg_nicons, & + mg_ncnst, mg_ninst) + elseif (fprcp == 2) then + call micro_mg_init3_0(kind_phys, gravit, rair, rh2o, cpair, & + tmelt, latvap, latice, mg_rhmini, & + mg_dcs, mg_ts_auto_ice, & + mg_qcvar, & + mg_do_hail, mg_do_graupel, & + microp_uniform, do_cldice, & + hetfrz_classnuc, & + mg_precip_frac_method, & + mg_berg_eff_factor, & + sed_supersat, do_sb_physics, & + mg_nccons, mg_nicons, & + mg_ncnst, mg_ninst, & + mg_ngcons, mg_ngnst) + else + write(0,*)' fprcp = ',fprcp,' is not a valid option - aborting' + stop + endif + call aer_cloud_init () + + is_initialized = .true. + +end subroutine m_micro_init + +! \brief Brief description of the subroutine +! +!> \section arg_table_m_micro_finalize Argument Table +!! + subroutine m_micro_finalize + end subroutine m_micro_finalize +#if 0 +!> \defgroup condense GFS m_micro Main +!! \brief This subroutine computes grid-scale condensation and evaporation of +!! cloud condensate. +!! \section arg_table_m_micro_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-----------------------------------------------------------------------------|---------------------------------------------------------------------------------------------|-------------|------|------------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | ix | horizontal_dimension | horizontal dimension | count | 0 | integer | | in | F | +!! | lm | vertical_dimension | vertical layer dimension | count | 0 | integer | | in | F | +!! | flipv | flag_flip | vertical flip logical | flag | 0 | logical | | in | F | +!! | dt_i | time_step_for_physics | physics time step | s | 0 | real | kind_phys | in | F | +!! | prsl_i | air_pressure | layer mean pressure | Pa | 2 | real | kind_phys | in | F | +!! | prsi_i | air_pressure_at_interface | air pressure at model layer interfaces | Pa | 2 | real | kind_phys | in | F | +!! | phil | geopotential | geopotential at model layer centers | m2 s-2 | 2 | real | kind_phys | in | F | +!! | phii | geopotential_at_interface | geopotential at model layer interfaces | m2 s-2 | 2 | real | kind_phys | in | F | +!! | omega_i | omega | layer mean vertical velocity | Pa s-1 | 2 | real | kind_phys | in | F | +!! | qlls_i | cloud_liquid_water_mixing_ratio | moist cloud water mixing ratio | kg kg-1 | 2 | real | kind_phys | in | F | +!! | qlcn_i | mass_fraction_of_convective_cloud_liquid_water | mass fraction of convective cloud liquid water | kg kg-1 | 2 | real | kind_phys | in | F | +!! | qils_i | cloud_ice_mixing_ratio | moist cloud ice mixing ratio | kg kg-1 | 2 | real | kind_phys | in | F | +!! | qicn_i | mass_fraction_of_convective_cloud_ice | mass fraction of convective cloud ice water | kg kg-1 | 2 | real | kind_phys | in | F | +!! | lwheat_i | tendency_of_air_temperature_due_to_longwave_heating_on_radiation_timestep | total sky lw heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | swheat_i | tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep | total sky sw heating rate | K s-1 | 2 | real | kind_phys | in | F | +!! | w_upi | vertical_velocity_for_updraft | vertical velocity for updraft | m s-1 | 2 | real | kind_phys | in | F | +!! | cf_upi | convective_cloud_fraction_for_microphysics | convective cloud fraction for microphysics | frac | 2 | real | kind_phys | in | F | +!! | frland | land_area_fraction | land area fraction | frac | 1 | real | kind_phys | in | F | +!! | zpbl | atmosphere_boundary_layer_thickness | pbl height | m | 1 | real | kind_phys | in | F | +!! | cnv_mfd_i | detrained_mass_flux | detrained mass flux | kg m-2 s-1 | 2 | real | kind_phys | in | F | +!! | cnv_prc3_i | convective_precipitation_flux | convective precipitation flux | kg m-2 s-1 | 2 | real | kind_phys | in | F | +!! | cnv_dqldt_i | tendency_of_cloud_water_due_to_convective_microphysics | tendency of cloud water due to convective microphysics | kg m-2 s-1 | 2 | real | kind_phys | in | F | +!! | clcn_i | convective_cloud_volume_fraction | convective cloud volume fraction | frac | 2 | real | kind_phys | in | F | +!! | u_i | x_wind_updated_by_physics | zonal wind updated by physics | m s-1 | 2 | real | kind_phys | in | F | +!! | v_i | y_wind_updated_by_physics | meridional wind updated by physics | m s-1 | 2 | real | kind_phys | in | F | +!! | taugwx | cumulative_surface_x_momentum_flux_for_diag_multiplied_by_timestep | cumulative sfc x momentum flux multiplied by timestep | Pa s | 1 | real | kind_phys | in | F | +!! | taugwy | cumulative_surface_y_momentum_flux_for_diag_multiplied_by_timestep | cumulative sfc y momentum flux multiplied by timestep | Pa s | 1 | real | kind_phys | in | F | +!! | tauorox | instantaneous_surface_x_momentum_flux | x momentum flux | Pa | 1 | real | kind_phys | in | F | +!! | tauoroy | instantaneous_surface_y_momentum_flux | y momentum flux | Pa | 1 | real | kind_phys | in | F | +!! | cnv_fice_i | ice_fraction_in_convective_tower | ice fraction in convective tower | frac | 2 | real | kind_phys | in | F | +!! | cnv_ndrop_i | number_concentration_of_cloud_liquid_water_particles_for_detrainment | droplet number concentration in convective detrainment | m-3 | 2 | real | kind_phys | in | F | +!! | cnv_nice_i | number_concentration_of_ice_crystals_for_detrainment | crystal number concentration in convective detrainment | m-3 | 2 | real | kind_phys | in | F | +!! | q_io | water_vapor_specific_humidity_updated_by_physics | water vapor specific humidity updated by physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | lwm_o | cloud_condensed_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of cloud condensed water updated by physics | kg kg-1 | 2 | real | kind_phys | out | F | +!! | qi_o | ice_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of ice water updated by physics | kg kg-1 | 2 | real | kind_phys | out | F | +!! | t_io | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | inout | F | +!! | rn_o | lwe_thickness_of_explicit_precipitation_amount | explicit precipitation (rain, ice, snow, graupel, ...) on physics timestep | m | 1 | real | kind_phys | out | F | +!! | sr_o | ratio_of_snowfall_to_rainfall | snow ratio: ratio of snow to total precipitation | frac | 1 | real | kind_phys | out | F | +!! | ncpl_io | cloud_droplet_number_concentration_updated_by_physics | number concentration of cloud droplets updated by physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | ncpi_io | ice_number_concentration_updated_by_physics | number concentration of ice updated by physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | fprcp | number_of_frozen_precipitation_species | number of frozen precipitation species | count | 0 | integer | | in | F | +!! | rnw_io | local_rain_water_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of rain water local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | snw_io | local_snow_water_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of snow water local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qgl_io | local_graupel_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of graupel local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | ncpr_io | local_rain_number_concentration | number concentration of rain local to physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | ncps_io | local_snow_number_concentration | number concentration of snow local to physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | ncgl_io | local_graupel_number_concentration | number concentration of graupel local to physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | clls_io | cloud_fraction_for_MG | cloud fraction used by Morrison-Gettelman MP | frac | 2 | real | kind_phys | inout | F | +!! | kcbl | vertical_index_at_cloud_base | vertical index at cloud base | index | 1 | integer | | inout | F | +!! | cldreffl | effective_radius_of_stratiform_cloud_liquid_water_particle_in_um | effective radius of cloud liquid water particle in micrometer | um | 2 | real | kind_phys | out | F | +!! | cldreffi | effective_radius_of_stratiform_cloud_ice_particle_in_um | effective radius of cloud ice water particle in micrometers | um | 2 | real | kind_phys | out | F | +!! | cldreffr | effective_radius_of_stratiform_cloud_rain_particle_in_um | effective radius of cloud rain particle in micrometers | um | 2 | real | kind_phys | out | F | +!! | cldreffs | effective_radius_of_stratiform_cloud_snow_particle_in_um | effective radius of cloud snow particle in micrometers | um | 2 | real | kind_phys | out | F | +!! | cldreffg | effective_radius_of_stratiform_cloud_graupel_particle_in_um | effective radius of cloud graupel particle in micrometers | um | 2 | real | kind_phys | out | F | +!! | aero_in | flag_for_aerosol_input_MG | flag for using aerosols in Morrison-Gettelman microphysics | flag | 0 | logical | | in | F | +!! | skip_macro | flag_skip_macro | flag to skip cloud macrophysics in Morrison scheme | flag | 0 | logical | | in | F | +!! | cn_prc2 | rain_rate_from_MG_cloud_macrophysics | rain rate from cloud macrophysics in Morrison-Gettelman microphysics | mm s-1? | 1 | real | kind_phys | out | F | +!! | cn_snr | snow_rate_from_MG_cloud_macrophysics | snow rate from cloud macrophysics in Morrison-Gettelman microphysics | mm s-1? | 1 | real | kind_phys | out | F | +!! | lprnt | flag_print | control flag for diagnostic print out | flag | 0 | logical | | in | F | +!! | ipr | horizontal_index_of_printed_column | horizontal index of printed column | index | 0 | integer | | in | F | +!! | kdt | index_of_time_step | current forecast iteration | index | 0 | integer | | in | F | +!! | xlat | latitude | latitude | radians | 1 | real | kind_phys | in | F | +!! | xlon | longitude | longitude | radians | 1 | real | kind_phys | in | F | +!! | rhc_i | critical_relative_humidity | critical relative humidity | frac | 2 | real | kind_phys | in | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +#endif +subroutine m_micro_run(im, ix, lm, flipv, dt_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 & + &, CNV_DQLDT_i, CLCN_i, u_i, v_i & + &, TAUGWX, TAUGWY & + &, 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& + &, qgl_io, ncpr_io, ncps_io, ncgl_io & + &, CLLS_io, KCBL & + &, CLDREFFL, CLDREFFI, CLDREFFR, CLDREFFS & + &, CLDREFFG & + &, aero_in, skip_macro, cn_prc2, cn_snr & + &, lprnt, ipr, kdt, xlat, xlon, rhc_i, & + & errmsg, errflg) + + use machine , only: kind_phys + use physcons, grav => con_g, pi => con_pi, & + & rgas => con_rd, cp => con_cp, & + & hvap => con_hvap, hfus => con_hfus, & + & ttp => con_ttp, tice => con_t0c, & + & eps => con_eps, epsm1 => con_epsm1, & + & VIREPS => con_fvirt, & + & latvap => con_hvap, latice => con_hfus + + use funcphys, only: fpvs ! saturation vapor pressure for water-ice mixed +! use funcphys, only: fpvsl, fpvsi, fpvs ! saturation vapor pressure for water,ice & mixed + use aer_cloud, only: AerProps, getINsubset,init_aer, & + & aerosol_activate,AerConversion1 + use cldmacro, only: macro_cloud,meltfrz_inst,update_cld, & + & meltfrz_inst + use cldwat2m_micro,only: mmicro_pcond + use micro_mg2_0, only: micro_mg_tend2_0 => micro_mg_tend, qcvar2 => qcvar + use micro_mg3_0, only: micro_mg_tend3_0 => micro_mg_tend, qcvar3 => qcvar + +! use wv_saturation, only: aqsat + + implicit none +! Anning Cheng July 2015 writing the interface for GSM. Based on GMAO version of M-2M, +! 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 +! +! Feb 2018 : S. Moorthi Updated for MG3 with graupel as prognostic variable +!------------------------------------ +! 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,& + qsmall=1.e-14 + + integer, parameter :: ncolmicro = 1 + integer,intent(in) :: im, ix,lm, ipr, kdt, fprcp + logical,intent(in) :: flipv, aero_in, skip_macro, lprnt + real (kind=kind_phys), intent(in):: dt_i + + real (kind=kind_phys), dimension(ix,lm),intent(in) :: & + & 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, & + & 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, rhc_i + real (kind=kind_phys),dimension(im),intent(in):: TAUGWX, & + & TAUGWY, TAUOROX, TAUOROY, FRLAND,ZPBL,xlat,xlon +! & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY,ps_i,FRLAND,ZPBL +! & CNVPRCP + +! output + real (kind=kind_phys),dimension(ix,lm), intent(out) :: lwm_o, qi_o, & + cldreffl, cldreffi, cldreffr, cldreffs, cldreffg + real (kind=kind_phys),dimension(im), intent(out) :: rn_o, sr_o + real (kind=kind_phys),dimension(im), intent(out) :: CN_PRC2,CN_SNR + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + +! input and output +! Anning Cheng 10/24/2016 twat for total water, diagnostic purpose + integer, dimension(IM), intent(inout) :: KCBL + real (kind=kind_phys),dimension(ix,lm),intent(inout):: q_io, t_io, & + & ncpl_io,ncpi_io,CLLS_io + real (kind=kind_phys),dimension(im,lm),intent(inout):: rnw_io,snw_io,& + & ncpr_io, ncps_io, & + & qgl_io, ncgl_io +!Moo real (kind=kind_phys),dimension(im,lm),intent(inout):: CLLS_io + + +! Local variables + integer kcldtopcvn,i,k,ll, kbmin, NAUX, nbincontactdust,l + integer, dimension(im) :: kct + real (kind=kind_phys) T_ICE_ALL, USE_AV_V,BKGTAU,LCCIRRUS, & + & NPRE_FRAC, Nct, Wct, fcn, ksa1, tauxr8, DT_Moist, dt_r8, & + & TMAXLL, USURF,LTS_UP, LTS_LOW, MIN_EXP, fracover, c2_gw, est3 + + real(kind=kind_phys), allocatable, dimension(:,:) :: & + & 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, PLO, ZLO, temp, & + & QLLS, QLCN, QILS,QICN, CNV_CVW,CNV_UPDF, & +! & QLLS, QLCN, QILS,QICN, CNV_CVW,CNV_UPDF,SMAXL,SMAXI, & +! & NHET_NUC, NLIM_NUC, CDNC_NUC,INC_NUC,CNN01,CNN04,CNN1,DNHET_IMM, & + & NHET_NUC, NLIM_NUC, CDNC_NUC,INC_NUC, DNHET_IMM, & + & NHET_IMM,NHET_DEP,NHET_DHF,DUST_IMM,DUST_DEP, DUST_DHF,WSUB, & + & SIGW_GW,SIGW_CNV,SIGW_TURB, & +! & SIGW_GW,SIGW_CNV,SIGW_TURB,SIGW_RC,REV_CN_X,REV_LS_X, & + & rnw,snw,ncpr,ncps,qgl,ncgl, & +! & RSU_LS_X, ALPHT_X, DLPDF_X, DIPDF_X,rnw,snw,ncpr,ncps,qgl,ncgl, & +! & ACLL_CN_X,ACIL_CN_X, PFRZ, FQA,QCNTOT,QTOT,QL_TOT,qi_tot,blk_l,rhc + & FQA,QL_TOT,qi_tot,blk_l,rhc + + real(kind=kind_phys) :: QCNTOT, QTOT + +! real(kind=kind_phys), dimension(IM,LM):: DQRL_X, & + real(kind=kind_phys), dimension(IM,LM):: CNV_DQLDT, CLCN,CLLS, & + & CCN01,CCN04,CCN1 + + real(kind=kind_phys), allocatable, dimension(:,:) :: RHX_X & + &, CFPDF_X, VFALLSN_CN_X, QSNOW_CN, VFALLRN_CN_X, QRAIN_CN & + &, REV_CN_X, RSU_CN_X, DLPDF_X, DIPDF_X, ALPHT_X, PFRZ & + &, ACLL_CN_X, ACIL_CN_X, DQRL_X & + &, PFI_CN_X, PFL_CN_X, QST3, DZET, QDDF3 + real(kind=kind_phys), allocatable, dimension(:) :: vmip + +! real(kind=kind_phys), dimension(IM,LM) :: QDDF3 +! 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, kh +! real(kind=kind_phys), dimension(IM,0:LM) :: PLE, PKE, kh +! &, PFI_CN_X, PFL_CN_X + + real(kind=kind_phys),dimension(LM) :: rhdfdar8, rhu00r8, & + & ttendr8,qtendr8, cwtendr8,npre8, npccninr8,ter8, & + & plevr8,ndropr8,qir8,qcr8,wparc_turb,qvr8, nir8,ncr8, & + & nimmr8,nsootr8,rnsootr8,omegr8,qrr8,qsr8,nrr8,nsr8, & + & qgr8, ngr8 + + real(kind=kind_phys), dimension(1:LM,10) :: rndstr8,naconr8 + + real(kind=kind_phys), dimension(IM) :: CN_ARFX,& + & LS_SNR,LS_PRC2, TPREC +! & VMIP, twat + + real(kind=kind_phys), dimension (LM) :: uwind_gw,vwind_gw, & + & 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, & + & dust_immr8,dust_depr8,dust_dhfr8,nlimicer8,cldfr8,liqcldfr8, & + & icecldfr8,cldor8, pdelr8, & + & rpdelr8,lc_turb,zmr8,ficer8,rate1ord_cw2pr, tlatr8, qvlatr8, & + & qctendr8, qitendr8, nctendr8, nitendr8, effcr8, effc_fnr8, & + & effir8, nevaprr8, evapsnowr8, prainr8, & + & prodsnowr8, cmeoutr8, deffir8, pgamradr8, lamcradr8,qsoutr8, & + & qroutr8,droutr8, qcsevapr8,qisevapr8, qvresr8, & + & cmeioutr8, dsoutr8, qcsinksum_rate1ord,qrtend,nrtend, & + & qstend, nstend, alphar8, rhr8, & + + & qgtend, ngtend, qgoutr8, ngoutr8, dgoutr8 + + real(kind=kind_phys), dimension(1) :: prectr8, precir8 + + real(kind=kind_phys), dimension (LM) :: 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, & + & nnuccdor8, nnucccor8,naair8, & + & nsacwior8, nsubior8, nprcior8, npraior8, npccnor8, npsacwsor8, & + & nsubcor8, npraor8, nprc1or8, tlatauxr8,pfrz_inc_r8,sadice, & + & sadsnow, am_evp_st, 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, & +! graupel related + & reff_grau, umg, qgsedtenr8, mnuccrior8, & + & pracgr8, psacwgr8, pgsacwr8, pgracsr8, prdgr8, qmultgr8,& + & qmultrgr8, psacrr8, npracgr8, nscngr8, ngracsr8, nmultgr8,& + & nmultrgr8, npsacwgr8, qgout2, ngout2, dgout2, freqg + + 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), dimension(2:LM+1) :: lflx, iflx, rflx, & + sflx, gflx + +! 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 & + &, ncnstr8 = 100.0e6 + + real(kind=kind_phys):: k_gw, maxkh, tausurf_gw, overscale, tx1, rh1_r8 + + real(kind=kind_phys),dimension(3) :: ccn_diag + real(kind=kind_phys),dimension(58) :: cloudparams + + integer, parameter :: CCN_PARAM=2, IN_PARAM=5 + + real(kind=kind_phys), parameter ::fdust_drop=1.0, fsoot_drop=0.1 & + &, sigma_nuc_r8=0.28,SCLMFDFR=0.03 +! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1 + + type (AerProps), dimension (IM,LM) :: AeroProps + type (AerProps) :: AeroAux, AeroAux_b + real, allocatable, dimension(:,:,:) :: AERMASSMIX + + logical :: use_average_v, ltrue, lprint + +!================================== +!====2-moment Microhysics= +!================== Start Stratiform cloud processes========================================== +!set up initial values + + data USE_AV_V/1./, BKGTAU/0.015/, LCCIRRUS/500./, NPRE_FRAC/1./, & + & TMAXLL/296./, fracover/1./, LTS_LOW/12./, LTS_UP/24./, & + & MIN_EXP/0.5/ + + 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./ + +! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + +! rhr8 = 1.0 + if(flipv) then + DO K=1, LM + ll = lm-k+1 + DO I = 1,IM + Q1(i,k) = q_io(i,ll) + U1(i,k) = u_i(i,ll) + V1(i,k) = v_i(i,ll) + omega(i,k) = omega_i(i,ll) + ncpl(i,k) = ncpl_io(i,ll) + ncpi(i,k) = ncpi_io(i,ll) + rnw(i,k) = rnw_io(i,ll) + snw(i,k) = snw_io(i,ll) + qgl(i,k) = qgl_io(i,ll) + ncpr(i,k) = ncpr_io(i,ll) + ncps(i,k) = ncps_io(i,ll) + ncgl(i,k) = ncgl_io(i,ll) +! QLLS is the total cloud water + QLLS(i,k) = QLLS_i(i,ll)-QLCN_i(i,ll) + QLCN(i,k) = QLCN_i(i,ll) + QILS(i,k) = QILS_i(i,ll)-QICN_i(i,ll) + QICN(i,k) = QICN_i(i,ll) + CNV_CVW(i,k) = w_upi(i,ll) + 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) = max(CLLS_io(I,ll)-CLCN_i(I,ll),0.0) + PLO(i,k) = prsl_i(i,ll)*0.01 + 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 + 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 + allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & + &, CNV_NDROP(im,lm), CNV_NICE(im,lm)) + DO K=1, LM + ll = lm-k+1 + DO I = 1,IM + CNV_MFD(i,k) = CNV_MFD_i(i,ll) + CNV_PRC3(i,k) = CNV_PRC3_i(i,ll) + CNV_FICE(i,k) = CNV_FICE_i(i,ll) + CNV_NDROP(i,k) = CNV_NDROP_i(i,ll) + CNV_NICE(i,k) = CNV_NICE_i(i,ll) + enddo + enddo + endif + + else + DO K=1, LM + DO I = 1,IM + Q1(i,k) = q_io(i,k) + U1(i,k) = u_i(i,k) + V1(i,k) = v_i(i,k) + omega(i,k) = omega_i(i,k) + ncpl(i,k) = ncpl_io(i,k) + ncpi(i,k) = ncpi_io(i,k) + ncpi(i,k) = ncpi_io(i,k) + rnw(i,k) = rnw_io(i,k) + snw(i,k) = snw_io(i,k) + qgl(i,k) = qgl_io(i,k) + ncpr(i,k) = ncpr_io(i,k) + ncps(i,k) = ncps_io(i,k) + ncgl(i,k) = ncgl_io(i,k) +! QLLS is the total cloud water + QLLS(i,k) = QLLS_i(i,k)-QLCN_i(i,k) + QLCN(i,k) = QLCN_i(i,k) + QILS(i,k) = QILS_i(i,k)-QICN_i(i,k) + QICN(i,k) = QICN_i(i,k) + CNV_CVW(i,k) = w_upi(i,k) + 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) = max(CLLS_io(I,k)-CLCN_i(I,k),0.0) + PLO(i,k) = prsl_i(i,k)*0.01 + 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 + 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 + allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & + &, CNV_NDROP(im,lm), CNV_NICE(im,lm)) + DO K=1, LM + DO I = 1,IM + CNV_MFD(i,k) = CNV_MFD_i(i,k) + CNV_PRC3(i,k) = CNV_PRC3_i(i,k) + CNV_FICE(i,k) = CNV_FICE_i(i,k) + CNV_NDROP(i,k) = CNV_NDROP_i(i,k) + CNV_NICE(i,k) = CNV_NICE_i(i,k) + enddo + enddo + endif + endif +! + DT_MOIST = dt_i + dt_r8 = dt_i + + do i=1,im + KCBL(i) = max(LM-KCBL(i),10) + KCT(i) = 10 + enddo + + DO I=1, IM + DO K = LM-2, 10, -1 + If ((CNV_DQLDT(I,K) <= 1.0e-9) .and. & + & (CNV_DQLDT(I,K+1) > 1.0e-9)) then + KCT(I) = K+1 + exit + end if + END DO + END DO + +! do L=LM,1,-1 +! do i=1,im +! DZET(i,L) = ZET(i,L) - ZET(i,L+1) +! 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) +! MASS(i,l) = (ple(i,l) - ple(i,l-1)) * (100.0/grav) +! enddo +! enddo +!------------------------------------------------------------------------------ +! call aqsat(temp,plo*100.,est3,qst3,im,im,lm,1,lm) +! do k=1,lm +! do i=1,im +! DZET(i,k) = TH1(i,k) * (pke(i,k)-pke(i,k-1)) & +! & * cpbg * (1.0 + vireps*q1(i,k)) +! MASS(i,k) = (ple(i,k) - ple(i,k-1)) * (100.0/grav) +! end do +! end do + +! do k=1,lm +! do i=1,im +! temp(i,k) = th1(i,k) * PK(i,k) +! est3 = fpvs(temp(i,k)) +! qst3(i,k) = min(eps*est3/max(plo(i,k)*100.0+epsm1*est3,1.0e-10),1.0) +! enddo +! enddo +! call aqsat(temp,plo*100.,est3,qst3,im,im,lm,1,lm) +! do k=1,lm +! do i=1,im +! DZET(i,k) = TH1(i,k) * (pke(i,k)-pke(i,k-1)) & +! & * cpbg * (1.0 + vireps*q1(i,k)) +! MASS(i,k) = (ple(i,k) - ple(i,k-1)) * (100.0/grav) +! enddo +! enddo + +! do i=1,im +! ZET(i,LM+1) = 0.0 +! vmip(i) = 0.0 +! enddo +!------------------------------------------------------------------------------ + + if (.not. skip_macro) then + allocate(qddf3(im,lm)) + allocate(vmip(im)) + do i=1,im + vmip(i) = 0.0 + enddo + DO K = LM, 1, -1 + do i=1,im + if (zet(i,k) < 3000.0) then +! qddf3(i,k) = - (zet(i,k) - 3000.0) * zet(i,k) * mass(i,k) + qddf3(i,k) = - (zet(i,k) - 3000.0) * zet(i,k) & + & * (ple(i,k) - ple(i,k-1)) * (100.0/grav) + else + qddf3(i,k) = 0.0 + endif + vmip(i) = vmip(i) + qddf3(i,k) + enddo + END DO + do i=1,im + if (vmip(i) /= 0.0) vmip(i) = 1.0 / vmip(i) + enddo + DO K = 1,LM + do i=1,im + QDDF3(i,K) = QDDF3(i,K) * VMIP(i) + enddo + END DO + deallocate (vmip) + endif + + + do l=lm-1,1,-1 + do i=1,im + tx1 = 0.5 * (temp(i,l+1) + temp(i,l)) + kh(i,l) = 3.55e-7*tx1**2.5*(rgas*0.01) / ple(i,l) !kh molecule diff only needing refinement + enddo + end do + do i=1,im + kh(i,0) = kh(i,1) + kh(i,lm) = kh(i,lm-1) + enddo + do L=LM,1,-1 + do i=1,im + blk_l(i,l) = 1.0 / ( 1.0/max(0.15*ZPBL(i),0.4*zlo(i,lm-1))& + & + 1.0/(zlo(i,l)*.4) ) + + SC_ICE(i,l) = 1.0 + NCPL(i,l) = MAX( NCPL(i,l), 0.) + NCPI(i,l) = MAX( NCPI(i,l), 0.) + RAD_CF(i,l) = max(0.0, min(CLLS(i,l)+CLCN(i,l), 1.0)) + CDNC_NUC(i,l) = 0.0 + INC_NUC(i,l) = 0.0 + + enddo + end do +! T_ICE_ALL = TICE - 40.0 + T_ICE_ALL = CLOUDPARAMS(33) + TICE + + + + do l=1,lm + rhdfdar8(l) = 1.e-8 + rhu00r8(l) = 0.95 + + ttendr8(l) = 0. + qtendr8(l) = 0. + cwtendr8(l) = 0. + + npccninr8(l) = 0. + enddo + do k=1,10 + do l=1,lm + rndstr8(l,k) = 2.0e-7 + enddo + enddo + +!need an estimate of convective area +!======================================================================================================================= +!======================================================================================================================= +!===================================Nucleation of cloud droplets and ice crystals ====================================== +! Aerosol cloud interactions. Calculate maxCCN tendency using Fountoukis and nenes (2005) or Abdul Razzak and Ghan (2002) +! liquid Activation Parameterization +! Ice activation follows the Barahona & Nenes ice activation scheme, ACP, (2008, 2009). +! Written by Donifan Barahona and described in Barahona et al. (2013) +!======================================================================================================================= +!======================================================================================================================= +!======================================================================================================================= + if(aero_in) then + allocate(AERMASSMIX (IM,LM, 15)) + AERMASSMIX = 1.e-15 + call AerConversion1 (AERMASSMIX, AeroProps) + deallocate(AERMASSMIX) + end if + use_average_v = .false. + if (USE_AV_V > 0.0) then + use_average_v = .true. + end if + + k_gw = (pi+pi) / LCCIRRUS + +!------------------------------------------------------------------------------- + do I=1,IM ! beginning of first big I loop + + kcldtopcvn = KCT(I) + + tausurf_gw = min(0.5*SQRT(TAUOROX(I)*TAUOROX(I) & + & + TAUOROY(I)*TAUOROY(I)), 10.0) + do k=1,lm + + uwind_gw(k) = min(0.5*SQRT( U1(I,k)*U1(I,k) & + & + V1(I,k)*V1(I,k)), 50.0) + +! tausurf_gw =tausurf_gw + max (tausurf_gw, min(0.5*SQRT(TAUX(I , J)**2+TAUY(I , J)**2), 10.0)*BKGTAU) !adds a minimum value from unresolved sources + + + pm_gw(k) = 100.0*PLO(I,k) + tm_gw(k) = TEMP(I,k) + + nm_gw(k) = 0.0 + rho_gw(k) = pm_gw(k) /(RGAS*tm_gw(k)) + + ter8(k) = TEMP(I,k) + plevr8(k) = 100.*PLO(I,k) + ndropr8(k) = NCPL(I,k) + qir8(k) = QILS(I,k) + QICN(I,k) + qcr8(k) = QLLS(I,k) + QLCN(I,k) + qcaux(k) = qcr8(k) + + npccninr8(k) = 0.0 + naair8(k) = 0.0 + + npre8(k) = 0.0 + + if (RAD_CF(I,k) > 0.01 .and. qir8(k) > 0.0) then + npre8(k) = NPRE_FRAC*NCPI(I,k) + else + npre8(k) = 0.0 + endif + + omegr8(k) = OMEGA(I,k) + lc_turb(k) = max(blk_l(I,k), 50.0) +! rad_cooling(k) = RADheat(I,k) + + if (npre8(k) > 0.0 .and. qir8(k) > 0.0) then + dpre8(k) = ( qir8(k)/(6.0*npre8(k)*900.0*PI))**(1.0/3.0) + else + dpre8(k) = 1.0e-9 + endif + wparc_ls(k) = -omegr8(k) / (rho_gw(k)*GRAV) & + & + cpbg * radheat(i,k) +! & + cpbg * rad_cooling(k) + enddo + do k=0,lm + pi_gw(k) = 100.0*PLE(I,k) + rhoi_gw(k) = 0.0 + ni_gw(k) = 0.0 + ti_gw(k) = 0.0 + enddo + + +! ==================================================================== +!*********** Calculate subgrid scale distribution in vertical velocity**** +! ==================================================================== + + + call gw_prof (1, LM, 1, tm_gw, pm_gw, pi_gw, rhoi_gw, ni_gw, & + & ti_gw, nm_gw) + + do k=1,lm + nm_gw(k) = max(nm_gw(k), 0.005) + h_gw(k) = k_gw*rho_gw(k)*uwind_gw(k)*nm_gw(k) + if (h_gw(K) > 0.0) then + h_gw(K) = sqrt(2.0*tausurf_gw/h_gw(K)) + end if + + wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133 + + wparc_cgw(k) = 0.0 + end do + +!!!======== Subgrid variability from Convective Sources According to Barahona et al. 2014 in prep + + if (kcldtopcvn > 20) then + + ksa1 = 1.0 + Nct = nm_gw(kcldtopcvn) + Wct = max(CNV_CVW(I,kcldtopcvn), 0.0) + + fcn = maxval(CNV_UPDF(I,kcldtopcvn:LM)) + + do k=1,kcldtopcvn + c2_gw = (nm_gw(k) + Nct) / Nct + wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56* & + & 1.806*c2_gw*c2_gw)*Wct*0.133 + enddo + + end if + + do k=1,lm + dummyW(k) = 0.133*k_gw*uwind_gw(k)/nm_gw(k) + enddo + + do K=1, LM-5, 1 + if (wparc_cgw(K)+wparc_gw(K) > dummyW(K)) then + exit + end if + end do + + do l=1,min(k,lm-5) + wparc_cgw(l) = 0.0 + wparc_gw(l) = 0.0 + enddo + + + + kbmin = KCBL(I) + kbmin = min(int(kbmin), LM-1)-4 + do K = 1, LM + wparc_turb(k) = KH(I,k) / lc_turb(k) + dummyW(k) = 10.0 + enddo + + if (FRLAND(I) < 0.1 .and. ZPBL(I) < 800.0 .and. & + & TEMP(I,LM) < 298.0 .and. TEMP(I,LM) > 274.0 ) then + do K = 1, LM + dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01,10.0),-10.0) + dummyW(k) = 1.0 / (1.0+exp(dummyW(k))) + enddo + maxkh = max(maxval(KH(I,kbmin:LM-1)*nm_gw(kbmin:LM-1)/ & + & 0.17), 0.3) + do K = 1, LM + wparc_turb(k) = (1.0-dummyW(k))*wparc_turb(k) & + & + dummyW(k)*maxkh + enddo + + end if + + wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2) + + + +!!!:=========Total variance + + do K = 1, LM + swparc(k) = sqrt(wparc_gw(k) * wparc_gw(k) & + & + wparc_turb(k) * wparc_turb(k) & + & + wparc_cgw(k) * wparc_cgw(k)) + enddo + + +! ========================================================================================== +! ========================Activate the aerosols ============================================ + + do K = 1, LM + + 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 + else + tauxr8 = ter8(K) + endif + + if(aero_in) then + AeroAux = AeroProps(I, K) + else + call init_Aer(AeroAux) + call init_Aer(AeroAux_b) + endif + + pfrz_inc_r8(k) = 0.0 + rh1_r8 = 0.0 !related to cnv_dql_dt, needed to changed soon + + + call aerosol_activate(tauxr8, plevr8(K), swparc(K), & + & wparc_ls(K), AeroAux, npre8(k), dpre8(k), ccn_diag, & + & ndropr8(k), npccninr8(K), smaxliq(K), & +! & ndropr8(k), qcr8(K), npccninr8(K), smaxliq(K), & + & naair8(K), smaxicer8(K), nheticer8(K), nhet_immr8(K), & + & dnhet_immr8(K), nhet_depr8(k), nhet_dhfr8(k), & + & sc_icer8(k), dust_immr8(K), dust_depr8(k), & + & dust_dhfr8(k), nlimicer8(k), use_average_v, & + & CCN_PARAM, IN_PARAM, fdust_drop, & + & fsoot_drop,pfrz_inc_r8(K),sigma_nuc_r8, rh1_r8, & + & size(ccn_diag)) + + if (npccninr8(k) < 1.0e-12) npccninr8(k) = 0.0 + + CCN01(I,K) = max(ccn_diag(1)*1e-6, 0.0) + CCN04(I,K) = max(ccn_diag(2)*1e-6, 0.0) + CCN1 (I,K) = max(ccn_diag(3)*1e-6, 0.0) + + + + else + ccn_diag(:) = 0.0 + smaxliq(K) = 0.0 + swparc(K) = 0.0 + smaxicer8(K) = 0.0 + nheticer8(K) = 0.0 + sc_icer8(K) = 2.0 +! sc_icer8(K) = 1.0 + naair8(K) = 0.0 + npccninr8(K) = 0.0 + nlimicer8(K) = 0.0 + nhet_immr8(K) = 0.0 + dnhet_immr8(K) = 0.0 + nhet_depr8(K) = 0.0 + nhet_dhfr8(K) = 0.0 + dust_immr8(K) = 0.0 + dust_depr8(K) = 0.0 + dust_dhfr8(K) = 0.0 + + end if + +! SMAXL(I,k) = smaxliq(k) * 100.0 +! SMAXI(I,k) = smaxicer8(k) * 100.0 + NHET_NUC(I,k) = nheticer8(k) * 1e-6 + 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) > 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) + DNHET_IMM(I,k) = max(dnhet_immr8(k), 0.0) + NHET_DEP(I,k) = nhet_depr8(k) * 1e-6 + NHET_DHF(I,k) = nhet_dhfr8(k) * 1e-6 + DUST_IMM(I,k) = max(dust_immr8(k), 0.0)*1e-6 + DUST_DEP(I,k) = max(dust_depr8(k), 0.0)*1e-6 + DUST_DHF(I,k) = max(dust_dhfr8(k), 0.0)*1e-6 + WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8 + SIGW_GW (I,k) = wparc_gw(k) * wparc_gw(k) + SIGW_CNV (I,k) = wparc_cgw(k) * wparc_cgw(k) + SIGW_TURB (I,k) = wparc_turb(k) * wparc_turb(k) + + enddo ! end of K loop + enddo ! end of first big I loop +!------------------------------------------------------------------------------- + +! SC_ICE=MIN(MAX(SC_ICE, 1.0), 2.0) +! WHERE (TEMP .gt. T_ICE_ALL) +! SC_ICE=1.0 +! END WHERE + +!===========================End cloud particle nucleation======================= +! ----------------------------- +! +!===========================Begin Cloud Macrophysics =========================== +! ------------------ + +! do k=1,lm +! do i=1,im +! REV_CN_X(i,k) = 0.0 +! REV_LS_X(i,k) = 0.0 +! RSU_CN_X(i,k) = 0.0 +! RSU_LS_X(i,k) = 0.0 +! CFX(i,k) = INC_NUC(i,k) + NHET_IMM(i,k) +! enddo +! enddo +! do k=0,lm +! do i=1,im +! PFI_CN_X(i,k) = 0.0 +! PFL_CN_X(i,k) = 0.0 +! enddo +! enddo + +! 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,:) + + allocate(RHX_X(im,lm), CFPDF_X(im,lm), VFALLSN_CN_X(im,lm), & + & QSNOW_CN(im,lm), VFALLRN_CN_X(im,lm), QRAIN_CN(im,lm),& + & REV_CN_X(im,lm), RSU_CN_X(im,lm), DLPDF_X(im,lm), & + & DIPDF_X(im,lm), ALPHT_X(im,lm), PFRZ(im,lm), & + & ACLL_CN_X(im,lm), ACIL_CN_X(im,lm), DQRL_X(im,lm), & + & DZET(im,lm), qst3(im,lm)) + allocate (PFI_CN_X(im,0:lm), PFL_CN_X(im,0:lm)) + + do L=LM,1,-1 + do i=1,im + DZET(i,L) = ZET(i,L) - ZET(i,L+1) + 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) +! MASS(i,l) = (ple(i,l) - ple(i,l-1)) * (100.0/grav) + enddo + enddo + do k=1,lm + do i=1,im + REV_CN_X(i,k) = 0.0 + RSU_CN_X(i,k) = 0.0 + enddo + enddo + do k=0,lm + do i=1,im + PFI_CN_X(i,k) = 0.0 + PFL_CN_X(i,k) = 0.0 + enddo + enddo + +! 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, 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, & + & ACLL_CN_X, ACIL_CN_X, PFL_CN_X, & + & PFI_CN_X, DLPDF_X, DIPDF_X, & + & 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, 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,:) + + do k=1,lm + do i=1,im + if (CNV_MFD(i,k) > 1.0e-6) then + tx1 = 1.0 / CNV_MFD(i,k) + CNV_NDROP(i,k) = CNV_NDROP(i,k) * tx1 + CNV_NICE(i,k) = CNV_NICE(i,k) * tx1 + else + CNV_NDROP(i,k) = 0.0 + CNV_NICE(i,k) = 0.0 + endif +! 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 + INC_NUC(i,k) = INC_NUC(i,k) * PFRZ(i,k) + NHET_NUC(i,k) = NHET_NUC(i,k) * PFRZ(i,k) + else + INC_NUC(i,k) = 0.0 + NHET_NUC(i,k) = 0.0 + endif + + enddo + enddo + + +!make sure QI , NI stay within T limits + 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 & +! &, INT(CLOUDPARAMS(57)), PLO , Q1, QLLS & +! &, QLCN, QILS, QICN, TEMP & +! &, CLLS, CLCN, SC_ICE, NCPI & +! &, NCPL, INC_NUC, RHCmicro ) +!============ Put cloud fraction back in contact with the PDF (Barahona et al., GMD, 2014)============ + + deallocate(RHX_X, CFPDF_X, VFALLSN_CN_X, & + & QSNOW_CN, VFALLRN_CN_X, QRAIN_CN, REV_CN_X, RSU_CN_X,& + & DLPDF_X, DIPDF_X, PFRZ, ACLL_CN_X, ACIL_CN_X, DQRL_X,& + & PFI_CN_X, PFL_CN_X, DZET, qst3, qddf3) + + else + do i=1,im + CN_PRC2(i) = 0.0 + CN_SNR(i) = 0.0 + enddo + + + endif ! .not. skip_macro + + +!===========================End of Cloud Macrophysics ======================== +! -------------------------- +! + + +!TVQX1 = SUM( ( Q1 + QLCN + QICN )*DM, 3) + + do k=1,lm + do i=1,im + QCNTOT = QLCN(i,k) + QICN(i,k) + QTOT = QCNTOT + QLLS(i,k) + QILS(i,k) + QL_TOT(i,k) = QLCN(i,k) + QLLS(i,k) + QI_TOT(i,k) = QICN(i,k) + QILS(i,k) + if (QTOT > 0.0) then + FQA(i,k) = min(max(QCNTOT / QTOT, 0.0), 1.0) + else + FQA(i,k) = 0.0 + endif +! Anning if negative, borrow water and ice from vapor 11/23/2016 + if (QL_TOT(i,k) < 0.0) then + Q1(i,k) = Q1(i,k) + QL_TOT(i,k) + TEMP(i,k) = TEMP(i,k) - lvbcp*QL_TOT(i,k) + QL_TOT(i,k) = 0.0 + endif + if (QI_TOT(i,k) < 0.0) then + Q1(i,k) = Q1(i,k) + QI_TOT(i,k) + TEMP(i,k) = TEMP(i,k) - lsbcp*QI_TOT(i,k) + QI_TOT(i,k) = 0.0 + endif + enddo + enddo + +!============================================================================================= +!===========================Two-moment stratiform microphysics =============================== +!===========This is the implementation of the Morrison and Gettelman (2008) microphysics ===== +!============================================================================================= + + do I=1,IM + LS_SNR(i) = 0.0 + LS_PRC2(i) = 0.0 + + nbincontactdust = 1 + + do l=1,10 + do k=1,lm + naconr8(k,l) = 0.0 + rndstr8(k,l) = 2.0e-7 + enddo + enddo + do k=1,lm + npccninr8(k) = 0.0 + naair8(k) = 0.0 + omegr8(k) = 0.0 + + tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) + if (tx1 > 0.0) then + cldfr8(k) = min(max(tx1, 0.00001), 1.0) + else + cldfr8(k) = 0.0 + endif + + 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) + ter8(k) = TEMP(I,k) + qvr8(k) = Q1(I,k) + + qcr8(k) = QL_TOT(I,k) + qir8(k) = QI_TOT(I,k) + ncr8(k) = MAX(NCPL(I,k), 0.0) + nir8(k) = MAX(NCPI(I,k), 0.0) + qrr8(k) = rnw(I,k) + qsr8(k) = snw(I,k) + qgr8(k) = qgl(I,k) + nrr8(k) = MAX(NCPR(I,k), 0.0) + nsr8(k) = MAX(NCPS(I,k), 0.0) + ngr8(k) = MAX(ncgl(I,k), 0.0) + + + naair8(k) = INC_NUC(I,k) + npccninr8(k) = CDNC_NUC(I,k) + + if (cldfr8(k) >= 0.001) then + nimmr8(k) = min(DNHET_IMM(I,k),ncr8(k)/(cldfr8(k)*DT_MOIST)) + else + nimmr8(k) = 0.0 + endif + + + if(aero_in) then + AeroAux = AeroProps(I, K) + else + call init_Aer(AeroAux) + end if + call getINsubset(1, AeroAux, AeroAux_b) + naux = AeroAux_b%nmods + if (nbincontactdust < naux) then + nbincontactdust = naux + end if + naconr8(K, 1:naux) = AeroAux_b%num(1:naux) + rndstr8(K, 1:naux) = AeroAux_b%dpg(1:naux) * 0.5 + +! Get black carbon properties for contact ice nucleation + call getINsubset(2, AeroAux, AeroAux_b) + nsootr8 (K) = sum(AeroAux_b%num) + naux = AeroAux_b%nmods + rnsootr8 (K) = sum(AeroAux_b%dpg(1:naux))/naux + + pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0 + rpdelr8(k) = 1./pdelr8(k) + plevr8(k) = 100.*PLO(I,k) + 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) = qcvar2 + 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 + + 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 +! 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) = 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 + + elseif (fprcp == 1) then ! callo mg2 +! 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 + ltrue = any(qcr8 >= qsmall) .or. any(qir8 >= qsmall) & + .or. any(qsr8 >= qsmall) .or. any(qrr8 >= qsmall) + if (ltrue) then + alphar8(:) = qcvar2 + +! if(lprint) then +! write(0,*)' calling micro_mg_tend2_0 qcvar2=',qcvar2 +! write(0,*)' qcr8=',qcr8(:) +! write(0,*)' ncr8=',ncr8(:) +! write(0,*)' npccninr8=',npccninr8(:) +! write(0,*)' plevr8=',plevr8(:) +! write(0,*)' ter8=',ter8(:) +! endif + + call micro_mg_tend2_0 ( & + & 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 + rnw(I,k) = rnw(I,k) + qrtend(k)*dt_r8 + snw(I,k) = snw(I,k) + qstend(k)*dt_r8 + + 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) + NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, 0.0) + NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, 0.0) + + 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 (lprint) then +! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) +! write(0,*)' aft micro_mg_tend q1= ', q1(i,:) +! write(0,*)' aft micro_mg_tend LS_PRC2= ', LS_PRC2(i),' ls_snr=',ls_snr(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 + else + ltrue = any(qcr8 >= qsmall) .or. any(qir8 >= qsmall) & + .or. any(qsr8 >= qsmall) .or. any(qrr8 >= qsmall) & + .or. any(qgr8 >= qsmall) + lprint = lprnt .and. i == ipr + if (ltrue) then + alphar8(:) = qcvar3 +! if(lprint) then +! write(0,*)' calling micro_mg_tend3_0 qcvar3=',qcvar3,' i=',i +! write(0,*)' qcr8=',qcr8(:) +! write(0,*)' ncr8=',ncr8(:) +! write(0,*)' npccninr8=',npccninr8(:) +! write(0,*)' plevr8=',plevr8(:) +! write(0,*)' ter8=',ter8(:) +! endif + call micro_mg_tend3_0 ( & + & ncolmicro, lm, dt_r8, & + & ter8, qvr8, & + & qcr8, qir8, & + & ncr8, nir8, & + & qrr8, qsr8, & + & nrr8, nsr8, & + & qgr8, ngr8, & + & 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, & +! + & qgtend, ngtend, & +! + & effcr8, effc_fnr8, effir8, & + & sadice, sadsnow, & + & prectr8, precir8, & + & nevaprr8, evapsnowr8, & + & am_evp_st, & + & prainr8, prodsnowr8, & + & cmeoutr8, deffir8, & + & pgamradr8, lamcradr8, & + & qsoutr8, dsoutr8, & +! + & qgoutr8, ngoutr8, dgoutr8, & +! + & lflx, iflx, gflx, & +! + & rflx, sflx, qroutr8, & +! + & reff_rain, reff_snow, reff_grau, & +! + & qcsevapr8, qisevapr8, qvresr8, & + & cmeioutr8, vtrmcr8, vtrmir8, & + & umr, ums, & +! + & umg, qgsedtenr8, & +! + & qcsedtenr8, qisedtenr8, & + & qrsedten, qssedten, & + & praor8, prcor8, & + & mnucccor8, mnucctor8, msacwior8, & + & psacwsor8, bergsor8, bergor8, & + & meltor8, homoor8, & + & qcresor8, prcior8, praior8, & +! + & qiresor8, mnuccror8, mnuccrior8, pracsor8, & +! + & meltsdtr8, frzrdtr8, mnuccdor8, & +! + & pracgr8, psacwgr8, pgsacwr8, & + & pgracsr8, prdgr8, & + & qmultgr8, qmultrgr8, psacrr8, & + & npracgr8, nscngr8, ngracsr8, & + & nmultgr8, nmultrgr8, npsacwgr8, & +! + & nroutr8, nsoutr8, & + & refl, arefl, areflz, & + & frefl, csrfl, acsrfl, & + & fcsrfl, rercld, & + & ncair8, ncalr8, & + & qrout2, qsout2, & + & nrout2, nsout2, & + & drout2, dsout2, & +! + & qgout2, ngout2, dgout2, freqg, & + & 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 + rnw(I,k) = rnw(I,k) + qrtend(k)*dt_r8 + snw(I,k) = snw(I,k) + qstend(k)*dt_r8 + qgl(I,k) = qgl(I,k) + qgtend(k)*dt_r8 + + 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) + NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, 0.0) + NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, 0.0) + NCGL(I,k) = max(NCGL(I,k) + ngtend(k)*dt_r8, 0.0) + + 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.) + CLDREFFG(I,k) = max(reff_grau(k),250.) + enddo ! K loop +! if (lprint) then +! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) +! write(0,*)' aft micro_mg_tend q1= ', q1(i,:) +! write(0,*)' aft micro_mg_tend LS_PRC2= ', LS_PRC2(i),' ls_snr=',ls_snr(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. + CLDREFFG(I,k) = 250. + enddo ! K loop + endif + endif + + enddo ! I loop +!============================================Finish 2-moment micro implementation=========================== + +!TVQX1 = SUM( ( Q1 + QL_TOT + QI_TOT(1:im,:,:))*DM, 3) & + + + if (.not. skip_macro) then + do k=1,lm + do i=1,im + QLCN(i,k) = QL_TOT(i,k) * FQA(i,k) + QLLS(i,k) = QL_TOT(i,k) - QLCN(i,k) + QICN(i,k) = QI_TOT(i,k) * FQA(i,k) + QILS(i,k) = QI_TOT(i,k) - QICN(i,k) + end do + 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) + + + do k=1,lm + do i=1,im + QL_TOT(I,K) = QLLS(I,K) + QLCN(I,K) + QI_TOT(I,K) = QILS(I,K) + QICN(I,K) + end do + end do + deallocate(CNV_MFD,CNV_PRC3,CNV_FICE,CNV_NDROP,CNV_NICE) + endif + +! do I=1,IM +! TPREC(i) = CN_PRC2(i) + LS_PRC2(i) + CN_SNR(i) + LS_SNR(i) +! enddo + + do K= 1, LM + do I=1,IM + if (QI_TOT(i,k) <= 0.0) NCPI(i,k) = 0.0 + if (QL_TOT(i,k) <= 0.0) NCPL(i,k) = 0.0 + end do + end do + + +!=============================================End Stratiform cloud processes========================================== +!====================================================================================================================== +!===========================Clean stuff and send it to radiation ====================================================== +!====================================================================================================================== +! outputs + if(flipv) then + DO K=1, LM + ll = lm-k+1 + DO I = 1,IM + t_io(i,k) = TEMP(i,ll) + q_io(i,k) = Q1(i,ll) + ncpi_io(i,k) = NCPI(i,ll) + ncpl_io(i,k) = NCPL(i,ll) + rnw_io(i,k) = rnw(i,ll) + snw_io(i,k) = snw(i,ll) + qgl_io(i,k) = qgl(i,ll) + ncpr_io(i,k) = NCPR(i,ll) + ncps_io(i,k) = NCPS(i,ll) + ncgl_io(i,k) = NCGL(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) = min(CLLS(i,ll)+CLCN(i,ll),1.0) + END DO + END DO + else + DO K=1, LM + DO I = 1,IM + t_io(i,k) = TEMP(i,k) + q_io(i,k) = Q1(i,k) + ncpi_io(i,k) = NCPI(i,k) + ncpl_io(i,k) = NCPL(i,k) + rnw_io(i,k) = rnw(i,k) + snw_io(i,k) = snw(i,k) + qgl_io(i,k) = qgl(i,k) + ncpr_io(i,k) = NCPR(i,k) + ncps_io(i,k) = NCPS(i,k) + ncgl_io(i,k) = NCGL(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) = min(CLLS(i,k)+CLCN(i,k),1.) + END DO + END DO + end if + DO I = 1,IM + TPREC(i) = CN_PRC2(i) + CN_SNR(i) + LS_PRC2(i) + LS_SNR(i) +! rn_o(i) = TPREC(i) * dt_i * 0.001 + rn_o(i) = (LS_PRC2(i) + LS_SNR(i)) * dt_i * 0.001 + + if (rn_o(i) < 1.e-13) then + sr_o(i) = 0. + else + sr_o(i) = (CN_SNR(i)+LS_SNR(i)) / rn_o(i) + endif + cn_prc2(i) = cn_prc2(i) * dt_i * 0.001 + cn_snr(i) = cn_snr(i) * dt_i * 0.001 + END DO + + if (allocated(ALPHT_X)) deallocate (ALPHT_X) + +! 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 + + + +!======================================================================= + + end subroutine m_micro_run +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!DONIF Calculate the Brunt_Vaisala frequency + +!=============================================================================== + subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) + use machine , only : kind_phys + use physcons, grav => con_g, cp => con_cp, rgas => con_rd + implicit none +!----------------------------------------------------------------------- +! Compute profiles of background state quantities for the multiple +! gravity wave drag parameterization. +! +! The parameterization is assumed to operate only where water vapor +! concentrations are negligible in determining the density. +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: ncol + integer, intent(in) :: pcols + integer, intent(in) :: pver + + + + real(kind=kind_phys), intent(in) :: t(pcols,pver) + real(kind=kind_phys), intent(in) :: pm(pcols,pver) + real(kind=kind_phys), intent(in) :: pi(pcols,0:pver) + + real(kind=kind_phys), intent(out) :: rhoi(pcols,0:pver) + real(kind=kind_phys), intent(out) :: ni(pcols,0:pver) + real(kind=kind_phys), intent(out) :: ti(pcols,0:pver) + real(kind=kind_phys), intent(out) :: nm(pcols,pver) + +!---------------------------Local storage------------------------------- + integer :: ix,kx + + real :: dtdp + real :: n2, cpair, r,g + real :: n2min = 1.e-8 + r = RGAS + cpair = CP + g = GRAV + +!----------------------------------------------------------------------------- +! Determine the interface densities and Brunt-Vaisala frequencies. +!----------------------------------------------------------------------------- + +! The top interface values are calculated assuming an isothermal atmosphere +! above the top level. + kx = 0 + do ix = 1, ncol + ti(ix,kx) = t(ix,kx+1) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + ni(ix,kx) = sqrt (g*g / (cpair*ti(ix,kx))) + end do + +! Interior points use centered differences + do kx = 1, pver-1 + do ix = 1, ncol + ti(ix,kx) = 0.5 * (t(ix,kx) + t(ix,kx+1)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + dtdp = (t(ix,kx+1)-t(ix,kx)) / (pm(ix,kx+1)-pm(ix,kx)) + n2 = g*g/ti(ix,kx) * (1./cpair - rhoi(ix,kx)*dtdp) + ni(ix,kx) = sqrt (max (n2min, n2)) + end do + end do + +! Bottom interface uses bottom level temperature, density; next interface +! B-V frequency. + kx = pver + do ix = 1, ncol + ti(ix,kx) = t(ix,kx) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + ni(ix,kx) = ni(ix,kx-1) + end do + +!----------------------------------------------------------------------------- +! Determine the midpoint Brunt-Vaisala frequencies. +!----------------------------------------------------------------------------- + do kx=1,pver + do ix=1,ncol + nm(ix,kx) = 0.5 * (ni(ix,kx-1) + ni(ix,kx)) + end do + end do + + return + end subroutine gw_prof + + +!Find cloud top based on cloud fraction + + subroutine find_cldtop(ncol, pver, cf, kcldtop) + implicit none + + integer, intent(in) :: pver , ncol + real, intent(in) :: cf(ncol,pver) + integer, intent(out) :: kcldtop + integer :: kuppest, ibot, k + real :: stab, cfcrit, cf00, cfp1 + + + ibot = pver-1 + kcldtop = ibot+1 + kuppest = 20 + cfcrit = 1e-2 + + + do k = kuppest , ibot + cfp1 = cf(ncol, k+1) + + if ( ( cfp1 >= cfcrit ) ) then + kcldtop = k +1 + exit + end if + end do + + if (kcldtop >= ibot) then + kcldtop = pver + return + endif + + + end subroutine find_cldtop + +end module m_micro diff --git a/physics/m_micro_interstitial.F90 b/physics/m_micro_interstitial.F90 new file mode 100644 index 000000000..f06f3b90a --- /dev/null +++ b/physics/m_micro_interstitial.F90 @@ -0,0 +1,360 @@ +!> \file m_micro_interstitial.F90 +!! This file contains subroutines that prepare data for and from the Morrison-Gettelman microphysics scheme +!! as part of the GFS physics suite. +module m_micro_pre +contains + +! \brief Brief description of the subroutine +! +!> \section arg_table_m_micro_pre_init Argument Table +!! +subroutine m_micro_pre_init() +end subroutine m_micro_pre_init + +! \brief Brief description of the subroutine +!! +!! \section arg_table_m_micro_pre_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|-------------------------------------------------------|---------------------------------------------------------------------------------------------|---------|------|------------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | number of vertical layers | count | 0 | integer | | in | F | +!! | do_shoc | flag_for_shoc | flag for SHOC | flag | 0 | logical | | in | F | +!! | fprcp | number_of_frozen_precipitation_species | number of frozen precipitation species | count | 0 | integer | | in | F | +!! | mg3_as_mg2 | flag_mg3_as_mg2 | flag for controlling prep for Morrison-Gettelman microphysics | flag | 0 | logical | | in | F | +!! | imfdeepcnv | flag_for_mass_flux_deep_convection_scheme | flag for mass-flux deep convection scheme | flag | 0 | integer | | in | F | +!! | imfshalcnv | flag_for_mass_flux_shallow_convection_scheme | flag for mass-flux shallow convection scheme | flag | 0 | integer | | in | F | +!! | gq0_ice | ice_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of ice water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_water | cloud_condensed_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of cloud condensed water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_rain | rain_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of rain water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_snow | snow_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of snow water updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_graupel | graupel_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of graupel updated by physics | kg kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_rain_nc | rain_number_concentration_updated_by_physics | number concentration of rain updated by physics | kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_snow_nc | snow_number_concentration_updated_by_physics | number concentration of snow updated by physics | kg-1 | 2 | real | kind_phys | in | F | +!! | gq0_graupel_nc | graupel_number_concentration_updated_by_physics | number concentration of graupel updated by physics | kg-1 | 2 | real | kind_phys | in | F | +!! | cld_shoc | subgrid_scale_cloud_fraction_from_shoc | subgrid-scale cloud fraction from the SHOC scheme | frac | 2 | real | kind_phys | in | F | +!! | cnvc | convective_cloud_cover | convective cloud cover | frac | 2 | real | kind_phys | in | F | +!! | cnvw | convective_cloud_water_mixing_ratio | moist convective cloud water mixing ratio | kg kg-1 | 2 | real | kind_phys | in | F | +!! | tcr | cloud_phase_transition_threshold_temperature | threshold temperature below which cloud starts to freeze | K | 0 | real | kind_phys | in | F | +!! | tcrf | cloud_phase_transition_denominator | denominator in cloud phase transition = 1/(tcr-tf) | K-1 | 0 | real | kind_phys | in | F | +!! | gt0 | air_temperature_updated_by_physics | temperature updated by physics | K | 2 | real | kind_phys | in | F | +!! | qrn | local_rain_water_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of rain water local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qsnw | local_snow_water_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of snow water local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qgl | local_graupel_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of graupel local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | ncpr | local_rain_number_concentration | number concentration of rain local to physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | ncps | local_snow_number_concentration | number concentration of snow local to physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | ncgl | local_graupel_number_concentration | number concentration of graupel local to physics | kg-1 | 2 | real | kind_phys | inout | F | +!! | cld_frc_MG | cloud_fraction_for_MG | cloud fraction used by Morrison-Gettelman MP | frac | 2 | real | kind_phys | inout | F | +!! | qlcn | mass_fraction_of_convective_cloud_liquid_water | mass fraction of convective cloud liquid water | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qicn | mass_fraction_of_convective_cloud_ice | mass fraction of convective cloud ice water | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | cf_upi | convective_cloud_fraction_for_microphysics | convective cloud fraction for microphysics | frac | 2 | real | kind_phys | inout | F | +!! | clw_water | cloud_liquid_water_mixing_ratio | moist cloud water mixing ratio | kg kg-1 | 2 | real | kind_phys | out | F | +!! | clw_ice | cloud_ice_mixing_ratio | moist cloud ice mixing ratio | kg kg-1 | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! +subroutine m_micro_pre_run (im, levs, do_shoc, fprcp, mg3_as_mg2, imfdeepcnv, imfshalcnv, gq0_ice, gq0_water, & + gq0_rain, gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, gq0_graupel_nc, cld_shoc, cnvc, cnvw, tcr, tcrf, gt0, & + qrn, qsnw, qgl, ncpr, ncps, ncgl, cld_frc_MG, qlcn, qicn, cf_upi, clw_water, clw_ice, errmsg, errflg ) + +use machine, only : kind_phys +implicit none + +integer, intent(in) :: im, levs, imfdeepcnv, imfshalcnv, fprcp +logical, intent(in) :: do_shoc, mg3_as_mg2 +real(kind=kind_phys), intent(in) :: tcr, tcrf + +real(kind=kind_phys), intent(in) :: & + gq0_ice(:,:), gq0_water(:,:), gq0_rain(:,:), gq0_snow(:,:), & + gq0_graupel(:,:), gq0_rain_nc(:,:), gq0_snow_nc(:,:), & + gq0_graupel_nc(:,:), cld_shoc(:,:), cnvc(:,:), cnvw(:,:), & + gt0(:,:) + +real(kind=kind_phys), intent(inout) :: & + qrn(:,:), qsnw(:,:), qgl(:,:), ncpr(:,:), ncps(:,:), ncgl(:,:), & + cld_frc_MG(:,:), cf_upi(:,:), qlcn(:,:), qicn(:,:) + +real(kind=kind_phys), intent(out) :: clw_ice(:,:), clw_water(:,:) + +character(len=*), intent(out) :: errmsg +integer, intent(out) :: errflg + +integer :: i, k +real(kind=kind_phys) :: tem + +! Initialize CCPP error handling variables +errmsg = '' +errflg = 0 + +! 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 (do_shoc) then + if (fprcp == 0) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + else if ((abs(fprcp) == 1) .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + else + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = gq0_graupel(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + ncgl(i,k) = gq0_graupel_nc(i,k) + cld_frc_MG(i,k) = cld_shoc(i,k) + enddo + enddo + end if +else if ((imfdeepcnv >= 0) .or. (imfshalcnv > 0)) then + if (fprcp == 0) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + cld_frc_MG(i,k) = max(0.0, min(1.0,cld_frc_MG(i,k)+cnvc(i,k))) + ! clouds from t-dt and cnvc + tem = cnvw(i,k)* max(0.0, MIN(1.0, (TCR-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 if (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + cld_frc_MG(i,k) = max(0.0, min(1.0,cld_frc_MG(i,k)+cnvc(i,k))) + ! clouds from t-dt and cnvc + tem = cnvw(i,k)* max(0.0, MIN(1.0, (TCR-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) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + enddo + enddo + else + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + cld_frc_MG(i,k) = max(0.0, min(1.0,cld_frc_MG(i,k)+cnvc(i,k))) + ! clouds from t-dt and cnvc + tem = cnvw(i,k)* max(0.0, MIN(1.0, (TCR-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) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = gq0_graupel(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + ncgl(i,k) = gq0_graupel_nc(i,k) + enddo + enddo + end if +else + if (fprcp == 0 ) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + enddo + enddo + elseif (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + enddo + enddo + else + do k=1,levs + do i=1,im + clw_ice(i,k) = gq0_ice(i,k) + clw_water(i,k) = gq0_water(i,k) + qrn(i,k) = gq0_rain(i,k) + qsnw(i,k) = gq0_snow(i,k) + qgl(i,k) = gq0_graupel(i,k) + ncpr(i,k) = gq0_rain_nc(i,k) + ncps(i,k) = gq0_snow_nc(i,k) + ncgl(i,k) = gq0_graupel_nc(i,k) + enddo + enddo + endif +end if + + +end subroutine m_micro_pre_run + +! \brief Brief description of the subroutine +! +!> \section arg_table_m_micro_pre_finalize Argument Table +!! +subroutine m_micro_pre_finalize () +end subroutine m_micro_pre_finalize + +end module m_micro_pre + +!> This module contains the CCPP-compliant MG microphysics +!! post intersititial codes. + module m_micro_post + + contains + +! \brief Brief description of the subroutine +! +!> \section arg_table_m_micro_post_init Argument Table +!! + subroutine m_micro_post_init() + end subroutine m_micro_post_init + +! \brief Brief description of the subroutine +!! +!! \section arg_table_m_micro_post_run Argument Table +!! | local_name | standard_name | long_name | units | rank | type | kind | intent | optional | +!! |----------------|--------------------------------------------------------------------------|----------------------------------------------------------------------------------|---------|------|-----------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent | count | 0 | integer | | in | F | +!! | levs | vertical_dimension | number of vertical layers | count | 0 | integer | | in | F | +!! | fprcp | number_of_frozen_precipitation_species | number of frozen precipitation species | count | 0 | integer | | in | F | +!! | mg3_as_mg2 | flag_mg3_as_mg2 | flag for controlling prep for Morrison-Gettelman microphysics | flag | 0 | logical | | in | F | +!! | ncpr | local_rain_number_concentration | number concentration of rain local to physics | kg-1 | 2 | real | kind_phys | in | F | +!! | ncps | local_snow_number_concentration | number concentration of snow local to physics | kg-1 | 2 | real | kind_phys | in | F | +!! | ncgl | local_graupel_number_concentration | number concentration of graupel local to physics | kg-1 | 2 | real | kind_phys | in | F | +!! | qrn | local_rain_water_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of rain water local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qsnw | local_snow_water_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of snow water local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | qgl | local_graupel_mixing_ratio | moist (dry+vapor, no condensates) mixing ratio of graupel local to physics | kg kg-1 | 2 | real | kind_phys | inout | F | +!! | gq0_rain | rain_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of rain water updated by physics | kg kg-1 | 2 | real | kind_phys | out | F | +!! | gq0_snow | snow_water_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of snow water updated by physics | kg kg-1 | 2 | real | kind_phys | out | F | +!! | gq0_graupel | graupel_mixing_ratio_updated_by_physics | moist (dry+vapor, no condensates) mixing ratio of graupel updated by physics | kg kg-1 | 2 | real | kind_phys | out | F | +!! | gq0_rain_nc | rain_number_concentration_updated_by_physics | number concentration of rain updated by physics | kg-1 | 2 | real | kind_phys | out | F | +!! | gq0_snow_nc | snow_number_concentration_updated_by_physics | number concentration of snow updated by physics | kg-1 | 2 | real | kind_phys | out | F | +!! | gq0_graupel_nc | graupel_number_concentration_updated_by_physics | number concentration of graupel updated by physics | kg-1 | 2 | real | kind_phys | out | F | +!! | errmsg | ccpp_error_message | error message for error handling in CCPP | none | 0 | character | len=* | out | F | +!! | errflg | ccpp_error_flag | error flag for error handling in CCPP | flag | 0 | integer | | out | F | +!! + subroutine m_micro_post_run( & + im, levs, fprcp, mg3_as_mg2, ncpr, ncps, ncgl, qrn, qsnw, qgl, & + gq0_rain, gq0_snow, gq0_graupel, gq0_rain_nc, gq0_snow_nc, & + gq0_graupel_nc, errmsg, errflg) + + use machine, only : kind_phys + implicit none + + integer, intent(in) :: im, levs, fprcp + logical, intent(in) :: mg3_as_mg2 + + real(kind=kind_phys), intent(in) :: ncpr(:,:), ncps(:,:), ncgl(:,:) + real(kind=kind_phys), intent(inout) :: qrn(:,:), qsnw(:,:), qgl(:,:) + real(kind=kind_phys), intent(inout) :: gq0_rain(:,:), gq0_snow(:,:), & + gq0_graupel(:,:), gq0_rain_nc(:,:), gq0_snow_nc(:,:), gq0_graupel_nc(:,:) + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + integer :: i, k + + real(kind=kind_phys), parameter :: qsmall = 1.0e-20 + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 +! 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=',diag%rainc(ipr)*86400.0 & +! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) +! 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 (ntgl > 0 .and. lprnt) & +! write(0,*)' cgw1aft=',stateout%gq0(ipr,:,ntgl),' 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 (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt + + if (abs(fprcp) == 1 .or. mg3_as_mg2) then + do k=1,levs + do i=1,im + if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 + if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 + gq0_rain(i,k) = qrn(i,k) + gq0_snow(i,k) = qsnw(i,k) + gq0_rain_nc(i,k) = ncpr(i,k) + gq0_snow_nc(i,k) = ncps(i,k) + enddo + enddo + elseif (fprcp > 1) then + do k=1,levs + do i=1,im + if (abs(qrn(i,k)) < qsmall) qrn(i,k) = 0.0 + if (abs(qsnw(i,k)) < qsmall) qsnw(i,k) = 0.0 + if (abs(qgl(i,k)) < qsmall) qgl(i,k) = 0.0 + gq0_rain(i,k) = qrn(i,k) + gq0_snow(i,k) = qsnw(i,k) + gq0_graupel(i,k) = qgl(i,k) + gq0_rain_nc(i,k) = ncpr(i,k) + gq0_snow_nc(i,k) = ncps(i,k) + gq0_graupel_nc(i,k) = ncgl(i,k) + enddo + enddo + + endif + +! 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 (lprnt) write(0,*)' qrna=',qrn(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qsnwa=',qsnw(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)' qglba',qgl(ipr,:),' kdt=',kdt +! + + + end subroutine m_micro_post_run + +! \brief Brief description of the subroutine +! +!> \section arg_table_m_micro_post_finalize Argument Table +!! + subroutine m_micro_post_finalize() + end subroutine m_micro_post_finalize + + end module m_micro_post diff --git a/physics/micro_mg2_0.F90 b/physics/micro_mg2_0.F90 new file mode 100755 index 000000000..96169f9a9 --- /dev/null +++ b/physics/micro_mg2_0.F90 @@ -0,0 +1,3319 @@ +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, oneo6=one/six + +!========================================================= +! 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, rair, 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(br+one) + gamma_br_plus4 = gamma(br+four) + gamma_bs_plus1 = gamma(bs+one) + gamma_bs_plus4 = gamma(bs+four) + gamma_bi_plus1 = gamma(bi+one) + gamma_bi_plus4 = gamma(bi+four) + gamma_bj_plus1 = gamma(bj+one) + gamma_bj_plus4 = gamma(bj+four) + + 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, npccnin, & + 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) :: npccnin(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) +! real(r8), intent(in) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) + real(r8) :: 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,2:nlev+1) ! grid-box average liquid condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: iflx(mgncol,2:nlev+1) ! grid-box average ice condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: rflx(mgncol,2:nlev+1) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), intent(out) :: sflx(mgncol,2: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 sedimentation (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) :: dum3 + real(r8) :: dumni0 + real(r8) :: dumns0 + real(r8) :: tx1, tx2, tx3, tx4, tx5, tx6, tx7, grho + ! 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) + real(r8) :: ts_au_loc(mgncol) + + ! 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, nstep_def + + ! Varaibles to scale fall velocity between small and regular ice regimes. + real(r8) :: irad, ifrac, tsfac + logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. +! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.true. + real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & + ts_au_min=180.0 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + ! Process inputs + + ! assign variable deltat to deltatin + deltat = deltatin + oneodt = one / deltat + nlb = nlev/3 + nstep_def = max(1, nint(deltat/20)) + tsfac = log(ts_au/ts_au_min) * qiinv + + ! 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+1) = zero + sflx(i,k+1) = zero + lflx(i,k+1) = zero + iflx(i,k+1) = 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 + npccn(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) + npccn = max((npccnin*lcldm-nc)*oneodt, zero) + nc = max(nc + npccn*deltat, zero) + ncal = nc*rho/lcldm ! sghan minimum in #/cm3 + 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) + + !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 = min(one, max(zero, (cpp/xlf)*(t(i,k)-snowmelt)/qs(i,k))) + else + dum = one + end if + + minstsm(i,k) = dum*qs(i,k) + ninstsm(i,k) = dum*ns(i,k) + + dum1 = - minstsm(i,k) * (xlf*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 = minstrf(i,k) * (xlf*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) 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 / icldm(i,k) + 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 + if (precip_frac(i,k) > mincld) then + dum = one / precip_frac(i,k) + else + dum = zero + endif + 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 + do i=1,mgncol + if (qiic(i,k) >= qimax) then + ts_au_loc(i) = ts_au_min + elseif (qiic(i,k) <= qimin) then + ts_au_loc(i) = ts_au + else +! ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv + ts_au_loc(i) = ts_au_min *exp(-tsfac*(qiic(i,k)-qimin)) + endif + enddo + if(do_ice_gmao) then + call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), lami(:,k), & + n0i(:,k), dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) + else + call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & + dcs, ts_au_loc(:), 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 + if (precip_frac(i,k) > mincld) then + dum = one / precip_frac(i,k) + else + dum = zero + endif + 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) + + umr(i,k) = min(dum1, dum*gamma_br_plus4*oneo6) + unr(i,k) = min(dum1, dum*gamma_br_plus1) + 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) >= qsmall) 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*oneo6) + 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) + 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) = zero + nnudep(:,k) = zero + + !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) = zero + msacwi(:,k) = zero + 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) = zero + nprai(:,k) = zero + 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) + + berg(i,k) = berg(i,k)*micro_mg_berg_eff_factor + + if (vap_dep(i,k) < zero .and. qi(i,k) > qsmall .and. icldm(i,k) > mincld) then + nsubi(i,k) = vap_dep(i,k) * ni(i,k) / (qi(i,k) * icldm(i,k)) + else + nsubi(i,k) = zero + endif + + ! 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(i,k) = zero + enddo + + 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) / dum * 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. one/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) + dum3 = dum1 * precip_frac(i,k) + dum2 = (pra(i,k)+prc(i,k))*lcldm(i,k) + dum = (dum3 - 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) / dum3 * 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 + + 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 + + tx4 = tx2 + ice_sublim(i,k) + vap_dep(i,k) + mnuccd(i,k) + qtmp = q(i,k) - (tx1 + tx4) * deltat + ttmp = t(i,k) + (tx1*xxlv + tx4*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 + if (precip_frac(i,k) > mincld) then + tx4 = oneodt / precip_frac(i,k) + else + tx4 = zero + endif + pre(i,k) = dum*dum1*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*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) + + +! if (lprnt .and. k >= 60 ) & +! write(0,*)' k=',k,' tlat=',tlat(i,k),' pre=',pre(i,k),' precip_frac=',precip_frac(i,k),& +! ' prds=',prds(i,k),' vap_dep=',vap_dep(i,k),' ice_sublim=',ice_sublim(i,k), & +! ' mnuccd=',mnuccd(i,k),' mnudep=',mnudep(i,k),' lcldm=',lcldm(i,k),' bergs=',bergs(i,k), & +! ' psacws=',psacws(i,k),' mnuccc=',mnuccc(i,k),' mnucct=',mnucct(i,k),' msacwi=',msacwi(i,k), & +! ' mnuccr=',mnuccr(i,k), & +! ' pracs=',pracs(i,k),' mnuccri=',mnuccri(i,k),' xlf=',xlf,' xxlv=',xxlv,' xxls=',xxls + + 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) + +! if (lprnt .and. k >= 60) write(0,*)' k=',k,' tlat=',tlat(i,k) + + 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. + qstend(i,k) = qstend(i,k) + (qs(i,k)-qsn(i,k)) * oneodt + qs(i,k) = qsn(i,k) + + nstend(i,k) = nstend(i,k) + (ns(i,k)-nsn(i,k)) * oneodt + ns(i,k) = nsn(i,k) + + qrtend(i,k) = qrtend(i,k) + (qr(i,k)-qrn(i,k)) * oneodt + qr(i,k) = qrn(i,k) + + nrtend(i,k) = nrtend(i,k) + (nr(i,k)-nrn(i,k)) * oneodt + nr(i,k) = nrn(i,k) + + !............................................................................. + + !================================================================================ + + ! 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) > mincld) 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) > mincld) 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) > mincld) 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_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) + + call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & + lami(:,k), mgncol) +! fallspeed for rain + + call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & + lamr(:,k), mgncol) +! fallspeed for snow + call size_dist_param_basic(mg_snow_props, dums(:,k), dumns(:,k), & + lams(:,k), mgncol) + + enddo + + do k=1,nlev + do i=1,mgncol + + ! calculate number and mass weighted fall velocity for droplets and cloud ice + !------------------------------------------------------------------- + + grho = g*rho(i,k) + + 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) = grho*vtrmc(i,k) + + fnc(i,k) = grho* acn(i,k)*gamma(pgam(i,k)+one+bc) & + / (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*oneo6, tx2) + + fi(i,k) = grho * vtrmi(i,k) + fni(i,k) = grho * 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*oneo6, tx2) + + fi(i,k) = grho*vtrmi(i,k) + fni(i,k) = ifrac * fni(i,k) + (one-ifrac) * grho * min(tx1*gamma_bj_plus1, tx2) + end if + else + fi(i,k) = zero + fni(i,k)= zero + end if + + + ! fallspeed for rain + +! 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) + umr(i,k) = min(tx1*gamma_br_plus4*oneo6, tx2) + unr(i,k) = min(tx1*gamma_br_plus1, tx2) + + fr(i,k) = grho * umr(i,k) + fnr(i,k) = grho * unr(i,k) + + else + fr(i,k) = zero + fnr(i,k) = zero + end if + + ! fallspeed for snow + + +! 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*oneo6, tx2) + uns(i,k) = min(tx1*gamma_bs_plus1, tx2) + + fs(i,k) = grho * ums(i,k) + fns(i,k) = grho * 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 + nint(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + nstep = min(nstep, nstep_def) + + + ! 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 + + if (icldm(i,k-1) > mincld) then + dum1 = max(zero, min(one, icldm(i,k)/icldm(i,k-1))) + else + dum1 = one + endif + + tx5 = dumi(i,k) + tx7 = pdel_inv(i,k) * tx1 + dum2 = tx7 * dum1 + dumi(i,k) = (tx5 + falouti(k-1)*dum2) / (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)*dum2) / (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) + + dum2 = (one-dum1) * falouti(k-1) * pdel_inv(i,k) * tx2 + qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to evap/sub of cloud ice + qisevap(i,k) = qisevap(i,k) + dum2 ! for output + + tlat(i,k) = tlat(i,k) - dum2 * xxls + + 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 + nint(max( maxval( fc(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fnc(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + nstep = min(nstep, nstep_def) + + ! 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 + + if (lcldm(i,k-1) > mincld) then + dum1 = max(zero, min(one, lcldm(i,k)/lcldm(i,k-1))) + else + dum1 = one + endif + + tx5 = dumc(i,k) + tx7 = pdel_inv(i,k) * tx1 + dum2 = tx7 * dum1 + dumc(i,k) = (tx5 + faloutc(k-1)*dum2) / (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)*dum2) / (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) + + dum2 = (one-dum1) * faloutc(k-1) * pdel_inv(i,k) * tx2 + qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to to evap/sub of cloud water + qcsevap(i,k) = qcsevap(i,k) + dum2 ! for output + + tlat(i,k) = tlat(i,k) - dum2 * xxlv + + 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 +! if (lprnt) write(0,*)' maxval=',maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))& +! ,maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)) + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + nstep = min(nstep, nstep_def) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + +! if(lprnt) then +! write(0,*)' nstep=',nstep,' tx1=',tx1,' tx2=',tx2,' tx3=',tx3,' qsmall=',qsmall +! write(0,*)' fr=',fr(i,:) +! write(0,*)' dumr=',dumr(i,:) +! endif + + 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 + +! if (lprnt) write(0,*)' prectaftrain=',prect(i),' preci=',preci(i) + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fs(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fns(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + ! 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 + +! if (lprnt) write(0,*)' prectaftsed=',prect(i),' preci=',preci(i) + + !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 + if (lcldm(i,k) > mincld) then + tx1 = one / lcldm(i,k) + else + tx1 = zero + endif + if (icldm(i,k) > mincld) then + tx2 = one / icldm(i,k) + else + tx2 = zero + endif + if (precip_frac(i,k) > mincld) then + tx3 = one / precip_frac(i,k) + else + tx3 = zero + endif + 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) 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) 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/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 new file mode 100755 index 000000000..9dbb1dd12 --- /dev/null +++ b/physics/micro_mg3_0.F90 @@ -0,0 +1,4405 @@ +module micro_mg3_0 +!--------------------------------------------------------------------------------- +! Purpose: +! MG microphysics version 3.0 - Update of MG microphysics with +! prognostic hail OR graupel. +! +! Author: Andrew Gettelman, Hugh Morrison +! +! +! Version 3 history: Sep 2016: development begun for hail, graupel +! This version:https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ +! +! Version 2 history: Sep 2011: Development begun. +! Feb 2013: Added of prognostic precipitation. +! Aug 2015: Published and released version +! Contributions from: Sean Santos, Peter Caldwell, Xiaohong Liu and Steve Ghan +! +! Anning Cheng adopted mg2 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 MG2 code +! S. Moorthi - Nov 2017 - made the sedimentation quasi-implicit +! S. Moorthi - Feb 2018 - updated to MG3 - modified graupel sedimentation +! other modifications to eliminate blowup. +! S. Moorthi - Mar 2018 - fixed a few bugs and added option to run as MG2 +! +! invoked in CAM by specifying -microphys=mg3 +! +! 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. +! +!--------------------------------------------------------------------------------- +!Version 3.O based on micro_mg2_0.F90 and WRF3.8.1 module_mp_morr_two_moment.F +!--------------------------------------------------------------------------------- +! 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, & +!++ag + ag, bg, ah, bh, rhog, rhoh, & +!--ag + 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 +!++ag kt +logical :: ngcons ! ngcons = .true. to specify constant graupel number +!--ag kt + +! 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) +!++ag kt +real(r8) :: ngnst ! graupel num concentration when ngcons=.true. (m-3) +!--ag kt + +!========================================================= +! 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 + +! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation. +real(r8), parameter :: sublim_factor = 0.0_r8 !number sublimation factor. + +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, oneo6=one/six + +!========================================================= +! 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, & +!++ag + do_hail, do_graupel +!--ag + +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 + +real(r8) :: rhogtmp ! hail or graupel density (kg m-3) +real(r8) :: agtmp ! tmp ag/ah parameter +real(r8) :: bgtmp ! tmp fall speed parameter + +! additional constants to help speed up code +real(r8) :: gamma_br_plus1, gamma_bs_plus1, gamma_bi_plus1, gamma_bj_plus1, gamma_bg_plus1 +real(r8) :: gamma_br_plus4, gamma_bs_plus4, gamma_bi_plus4, gamma_bj_plus4, gamma_bg_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, & +!++ag + micro_mg_do_hail_in, micro_mg_do_graupel_in, & +!--ag + 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, ngcons_in, ngnst_in) +! nccons_in, nicons_in, ncnst_in, ninst_in, ngcons_in, ngnst_in, errstring) + + 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 + +!++ag +!MG3 dense precipitating ice. Note, only 1 can be true, or both false. + logical, intent(in) :: micro_mg_do_graupel_in ! .true. = configure with graupel + ! .false. = no graupel (hail possible) + logical, intent(in) :: micro_mg_do_hail_in ! .true. = configure with hail + ! .false. = no hail (graupel possible) +!--ag + + 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, ngcons_in + real(r8), intent(in) :: ncnst_in, ninst_in, ngnst_in + logical ip + real(r8):: tmn, tmx, trice + + +! character(128), intent(out) :: errstring ! Output status (non-blank for error return) + + !----------------------------------------------------------------------- + + dcs = micro_mg_dcs * 1.0e-6 + ts_au = ts_auto + qcvar = mg_qcvar + + ! Initialize subordinate utilities module. + call micro_mg_utils_init(kind, rair, rh2o, cpair, tmelt_in, latvap, latice, & + dcs) +! dcs, errstring) + +! if (trim(errstring) /= "") return + + ! 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) +! write(0,*)' in micro_mg_utils_init=',' r=',r,' rair=',rair,' rh2o=',rh2o + 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 +!++ag + ngcons = ngcons_in + ngnst = ngnst_in +!--ag + + ! 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 +!++ag + do_hail = micro_mg_do_hail_in + do_graupel = micro_mg_do_graupel_in +! + if (do_hail) then + agtmp = ah + bgtmp = bh + rhogtmp = rhoh + elseif (do_graupel) then + agtmp = ag + bgtmp = bg + rhogtmp = rhog + else + agtmp = zero + bgtmp = zero + endif +!--ag + + ! 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(br+one) + gamma_br_plus4 = gamma(br+four) + gamma_bs_plus1 = gamma(bs+one) + gamma_bs_plus4 = gamma(bs+four) + gamma_bi_plus1 = gamma(bi+one) + gamma_bi_plus4 = gamma(bi+four) + gamma_bj_plus1 = gamma(bj+one) + gamma_bj_plus4 = gamma(bj+four) +! + gamma_bg_plus1 = gamma(bgtmp+one) + gamma_bg_plus4 = gamma(bgtmp+four) + + 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, & +!++ag + qgr, ngr, & +!--ag + relvar, accre_enhan_i, & + p, pdel, & + cldn, liqcldf, icecldf, qsatfac, & + qcsinksum_rate1ord, & + naai, npccnin, & + rndst, nacon, & + tlat, qvlat, & + qctend, qitend, & + nctend, nitend, & + qrtend, qstend, & + nrtend, nstend, & +!++ag + qgtend, ngtend, & +!--ag + effc, effc_fn, effi, & + sadice, sadsnow, & + prect, preci, & + nevapr, evapsnow, & + am_evp_st, & + prain, prodsnow, & + cmeout, deffi, & + pgamrad, lamcrad, & + qsout, dsout, & +!++ag + qgout, ngout, dgout, & +!--ag + lflx, iflx, & +!++ag + gflx, & +!--ag + rflx, sflx, qrout, & +!++ag + reff_rain, reff_snow, reff_grau, & +!--ag + + qcsevap, qisevap, qvres, & + cmeitot, vtrmc, vtrmi, & + umr, ums, & +!++ag + umg, qgsedten, & +!--ag + qcsedten, qisedten, & + qrsedten, qssedten, & + pratot, prctot, & + mnuccctot, mnuccttot, msacwitot, & + psacwstot, bergstot, bergtot, & + melttot, homotot, & + qcrestot, prcitot, praitot, & +!++ag + qirestot, mnuccrtot, mnuccritot, pracstot, & +!--ag + meltsdttot, frzrdttot, mnuccdtot, & +!++ag + pracgtot, psacwgtot, pgsacwtot, & + pgracstot, prdgtot, & + qmultgtot, qmultrgtot, psacrtot, & + npracgtot, nscngtot, ngracstot, & + nmultgtot, nmultrgtot, npsacwgtot, & +!--ag + nrout, nsout, & + refl, arefl, areflz, & + frefl, csrfl, acsrfl, & + fcsrfl, rercld, & + ncai, ncal, & + qrout2, qsout2, & + nrout2, nsout2, & + drout2, dsout2, & +!++ag + qgout2, ngout2, dgout2, freqg, & +!--ag + 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, & +!++ag + mg_graupel_props,& +!--ag + 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, & +!++ag + graupel_collecting_snow, & + graupel_collecting_rain, & + graupel_collecting_cld_water, & + graupel_riming_liquid_snow, & + graupel_rain_riming_snow, & + graupel_rime_splintering, & + evaporate_sublimate_precip_graupel,& +! graupel_sublimate_evap +!--ag + 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) +!++ag + real(r8), intent(in) :: qgr(mgncol,nlev) ! graupel/hail mixing ratio (kg/kg) + real(r8), intent(in) :: ngr(mgncol,nlev) ! graupel/hail number conc (1/kg) +!--ag + + 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) :: npccnin(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) +! real(r8), intent(in) :: npccn(mgncol,nlev) ! ccn activated number tendency (from microp_aero_ts) (1/kg*s) + real(r8) :: 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)) +!++ag + real(r8), intent(out) :: qgtend(mgncol,nlev) ! microphysical tendency qg (1/s) + real(r8), intent(out) :: ngtend(mgncol,nlev) ! microphysical tendency ng (1/(kg*s)) +!--ag + 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,2:nlev+1) ! grid-box average liquid condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: iflx(mgncol,2:nlev+1) ! grid-box average ice condensate flux (kg m^-2 s^-1) + real(r8), intent(out) :: rflx(mgncol,2:nlev+1) ! grid-box average rain flux (kg m^-2 s^-1) + real(r8), intent(out) :: sflx(mgncol,2:nlev+1) ! grid-box average snow flux (kg m^-2 s^-1) +!++ag + real(r8), intent(out) :: gflx(mgncol,2:nlev+1) ! grid-box average graupel/hail flux (kg m^-2 s^-1) +!--ag + 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) +!++ag + real(r8), intent(out) :: reff_grau(mgncol,nlev) ! graupel effective radius (micron) +!--ag + 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 sedimentation (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) +!++ag + real(r8), intent(out) :: umg(mgncol,nlev) ! mass weighted graupel/hail fallspeed (m/s) + real(r8), intent(out) :: qgsedten(mgncol,nlev) ! qg sedimentation tendency (1/s) +!--ag + + 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) :: mnuccritot(mgncol,nlev)! mixing ratio tendency due to heterogeneous freezing of rain to ice (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 +!++ag Hail/Graupel Tendencies + real(r8), intent(out) :: pracgtot(mgncol,nlev) ! change in q collection rain by graupel (precipf) + real(r8), intent(out) :: psacwgtot(mgncol,nlev) ! change in q collection droplets by graupel (lcldm) + real(r8), intent(out) :: pgsacwtot(mgncol,nlev) ! conversion q to graupel due to collection droplets by snow (lcldm) + real(r8), intent(out) :: pgracstot(mgncol,nlev) ! conversion q to graupel due to collection rain by snow (precipf) + real(r8), intent(out) :: prdgtot(mgncol,nlev) ! dep of graupel (precipf) +! real(r8), intent(out) :: eprdgtot(mgncol,nlev) ! sub of graupel (precipf) + real(r8), intent(out) :: qmultgtot(mgncol,nlev) ! change q due to ice mult droplets/graupel (lcldm) + real(r8), intent(out) :: qmultrgtot(mgncol,nlev)! change q due to ice mult rain/graupel (precipf) + real(r8), intent(out) :: psacrtot(mgncol,nlev) ! conversion due to coll of snow by rain (precipf) + real(r8), intent(out) :: npracgtot(mgncol,nlev) ! change n collection rain by graupel (precipf) + real(r8), intent(out) :: nscngtot(mgncol,nlev) ! change n conversion to graupel due to collection droplets by snow (lcldm) + real(r8), intent(out) :: ngracstot(mgncol,nlev) ! change n conversion to graupel due to collection rain by snow (precipf) + real(r8), intent(out) :: nmultgtot(mgncol,nlev) ! ice mult due to acc droplets by graupel (lcldm) + real(r8), intent(out) :: nmultrgtot(mgncol,nlev)! ice mult due to acc rain by graupel (precipf) + real(r8), intent(out) :: npsacwgtot(mgncol,nlev)! change n collection droplets by graupel (lcldm?) +!--ag + 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) +!++ag + real(r8), intent(out) :: qgout(mgncol,nlev) ! graupel/hail mixing ratio (kg/kg) + real(r8), intent(out) :: dgout(mgncol,nlev) ! graupel/hail diameter (m) + real(r8), intent(out) :: ngout(mgncol,nlev) ! graupel/hail number concentration (1/m3) +!Not sure if these are needed since graupel/hail is prognostic? + real(r8), intent(out) :: qgout2(mgncol,nlev) ! copy of qgout as used to compute dgout2 + real(r8), intent(out) :: ngout2(mgncol,nlev) ! copy of ngout as used to compute dgout2 + real(r8), intent(out) :: dgout2(mgncol,nlev) ! mean graupel/hail particle diameter (m) + real(r8), intent(out) :: freqg(mgncol,nlev) ! fractional occurrence of graupel + +!--ag + + 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) +!++ag + real(r8) :: qg(mgncol,nlev) ! graupel mixing ratio (kg/kg) + real(r8) :: ng(mgncol,nlev) ! graupel number concentration (1/kg) +! real(r8) :: rhogtmp ! hail or graupel density (kg m-3) + +!--ag + + ! 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 +!++ag + real(r8) :: qgic(mgncol,nlev) ! in-precip graupel/hail +!++ag + + + ! 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 +!++ag + real(r8) :: ngic(mgncol,nlev) ! in-precip graupel/hail +!++ag + + ! 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 +!++ag + ! graupel/hail + real(r8) :: lamg(mgncol,nlev) ! slope + real(r8) :: n0g(mgncol,nlev) ! intercept +! real(r8) :: bgtmp ! tmp fall speed parameter +!--ag + + ! Rates/tendencies due to: + + ! Instantaneous snow melting + real(r8) :: minstsm(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstsm(mgncol,nlev) ! number concentration +!++ag + ! Instantaneous graupel melting + real(r8) :: minstgm(mgncol,nlev) ! mass mixing ratio + real(r8) :: ninstgm(mgncol,nlev) ! number concentration +!--ag + + ! 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) + +!++ag + !graupel/hail processes + real(r8) :: npracg(mgncol,nlev) ! change n collection rain by graupel (precipf) + real(r8) :: nscng(mgncol,nlev) ! change n conversion to graupel due to collection droplets by snow (lcldm) + real(r8) :: ngracs(mgncol,nlev) ! change n conversion to graupel due to collection rain by snow (precipf) + real(r8) :: nmultg(mgncol,nlev) ! ice mult due to acc droplets by graupel (lcldm) + real(r8) :: nmultrg(mgncol,nlev) ! ice mult due to acc rain by graupel (precipf) + real(r8) :: npsacwg(mgncol,nlev) ! change n collection droplets by graupel (lcldm) + + real(r8) :: psacr(mgncol,nlev) ! conversion due to coll of snow by rain (precipf) + real(r8) :: pracg(mgncol,nlev) ! change in q collection rain by graupel (precipf) + real(r8) :: psacwg(mgncol,nlev) ! change in q collection droplets by graupel (lcldm) + real(r8) :: pgsacw(mgncol,nlev) ! conversion q to graupel due to collection droplets by snow (lcldm) + real(r8) :: pgracs(mgncol,nlev) ! conversion q to graupel due to collection rain by snow (precipf) + real(r8) :: prdg(mgncol,nlev) ! dep of graupel (precipf) +! real(r8) :: eprdg(mgncol,nlev) ! evap/sub of graupel (precipf) + real(r8) :: qmultg(mgncol,nlev) ! change q due to ice mult droplets/graupel (lcldm) + real(r8) :: qmultrg(mgncol,nlev) ! change q due to ice mult rain/graupel (precipf) +!--ag + + + ! fallspeeds + ! number-weighted + real(r8) :: uns(mgncol,nlev) ! snow + real(r8) :: unr(mgncol,nlev) ! rain +!++ag + real(r8) :: ung(mgncol,nlev) ! graupel/hail +!--ag + ! air density corrected fallspeed parameters + real(r8) :: arn(mgncol,nlev) ! rain + real(r8) :: asn(mgncol,nlev) ! snow +!++a + real(r8) :: agn(mgncol,nlev) ! graupel +!--ag + 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) + +!++ag + real(r8) :: fg(mgncol,nlev) + real(r8) :: fng(mgncol,nlev) +!--ag + + 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 + +!++ag + real(r8) :: faloutg(nlev) + real(r8) :: faloutng(nlev) + real(r8) :: faltndg + real(r8) :: faltndng +!--ag + + real(r8) :: rainrt(mgncol,nlev) ! rain rate for reflectivity calculation + + ! dummy variables + real(r8) :: dum + real(r8) :: dum1 + real(r8) :: dum2 +!++ag + real(r8) :: dum3 +!--ag + real(r8) :: dumni0 + real(r8) :: dumns0 + real(r8) :: tx1, tx2, tx3, tx4, tx5, tx6, tx7, grho + ! 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 +!++ag + real(r8) :: dumg(mgncol,nlev) ! graupel mixing ratio + real(r8) :: dumng(mgncol,nlev) ! graupel number concentration +!--ag + ! Array dummy variable + !real(r8) :: dum_2D(mgncol,nlev) + real(r8) :: pdel_inv(mgncol,nlev) + real(r8) :: ts_au_loc(mgncol) + + ! 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, nstep_def + + ! Varaibles to scale fall velocity between small and regular ice regimes. + real(r8) :: irad, ifrac, tsfac + logical, parameter :: do_ice_gmao=.false., do_liq_liu=.false. +! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.true. + real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & + ts_au_min=180.0 + + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + + ! Process inputs + + ! assign variable deltat to deltatin + deltat = deltatin + oneodt = one / deltat + nlb = nlev/3 +! nstep_def = max(1, nint(deltat/20)) + nstep_def = max(1, nint(deltat/5)) + tsfac = log(ts_au/ts_au_min) * qiinv + + ! 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) +!++ag + qg(i,k) = qgr(i,k) + ng(i,k) = ngr(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 + +! write(0,*)' in mg2 T=',t(1,:) +! write(0,*)' in mg2 P=',p(1,:),' r=',r + 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) +!++ag if do hail then agn = ah *rhof else ag*rhof + agn(i,k) = agtmp * 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 +!++ag + qgsedten(i,k) = zero +!--ag + + + 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 +!++ag + mnuccritot(i,k) = zero +!--ag + + pracstot(i,k) = zero + meltsdttot(i,k) = zero + frzrdttot(i,k) = zero + mnuccdtot(i,k) = zero + +!++ag + psacrtot(i,k) = zero + pracgtot(i,k) = zero + psacwgtot(i,k) = zero + pgsacwtot(i,k) = zero + pgracstot(i,k) = zero + prdgtot(i,k) = zero +! eprdgtot(i,k) = zero + qmultgtot(i,k) = zero + qmultrgtot(i,k) = zero + npracgtot(i,k) = zero + nscngtot(i,k) = zero + ngracstot(i,k) = zero + nmultgtot(i,k) = zero + nmultrgtot(i,k) = zero + npsacwgtot(i,k) = zero +!need to zero these out to be totally switchable (for conservation) + psacr(i,k) = zero + pracg(i,k) = zero + psacwg(i,k) = zero + pgsacw(i,k) = zero + pgracs(i,k) = zero + + prdg(i,k) = zero +! eprdg(i,k) = zero + qmultg(i,k) = zero + qmultrg(i,k) = zero + npracg(i,k) = zero + nscng(i,k) = zero + ngracs(i,k) = zero + nmultg(i,k) = zero + nmultrg(i,k) = zero + npsacwg(i,k) = zero +!--ag + rflx(i,k+1) = zero + sflx(i,k+1) = zero + lflx(i,k+1) = zero + iflx(i,k+1) = zero +!++ag + gflx(i,k+1) = zero +!--ag + + ! initialize precip output + + qrout(i,k) = zero + qsout(i,k) = zero + nrout(i,k) = zero + nsout(i,k) = zero +!++ag + qgout(i,k) = zero + ngout(i,k) = zero + dgout(i,k) = zero +!--ag + + ! 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 +!++ag + qgtend(i,k) = zero + ngtend(i,k) = zero +!--ag + + ! 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 +!++ag + qgic(i,k) = zero +!--ag + + + ncic(i,k) = zero + niic(i,k) = zero + nsic(i,k) = zero + nric(i,k) = zero +!++ag + ngic(i,k) = zero +!--ag + ! initialize precip fallspeeds to zero + ums(i,k) = zero + uns(i,k) = zero + umr(i,k) = zero + unr(i,k) = zero +!++ag + umg(i,k) = zero + ung(i,k) = zero +!--ag + + ! 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 +!++ag + qgout2(i,k) = zero + ngout2(i,k) = zero + freqg(i,k) = zero + dgout2(i,k) = zero +!--ag + + freqr(i,k) = zero + freqs(i,k) = zero + + reff_rain(i,k) = zero + reff_snow(i,k) = zero +!++ag + reff_grau(i,k) = zero + lamg(i,k) = zero + n0g(i,k) = zero +!--ag + + 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 + npccn(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 > mincld) + where (qc >= qsmall) + npccn = max((npccnin*lcldm-nc)*oneodt, zero) + nc = max(nc + npccn*deltat, zero) + ncal = nc*rho/lcldm ! sghan minimum in #/cm3 + 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) +! where (naai > zero .and. t < icenuct .and. relhum*esl/esi > 1.05_r8 & +! .and. icldm > mincld ) + + !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 = min(one, max(zero, (cpp/xlf)*(t(i,k)-snowmelt)/qs(i,k))) + else + dum = one + end if + + minstsm(i,k) = dum*qs(i,k) + ninstsm(i,k) = dum*ns(i,k) + + dum1 = - minstsm(i,k) * (xlf*oneodt) + tlat(i,k) = tlat(i,k) + dum1 + meltsdttot(i,k) = meltsdttot(i,k) + dum1 + +! if (lprnt .and. k >=100) write(0,*)' tlats=',tlat(i,k),' dum1=',dum1,& +! ' minstsm=',minstsm(i,k),' qs=',qs(i,k),' xlf=',xlf,' oneodt=',oneodt, & +! ' snowmelt=',snowmelt,' t=',t(i,k),' dum=',dum,' k=',k + + 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 +! if (lprnt) write(0,*)' qg1=',qg(1,:) + +!++ag + + if (do_graupel .or. do_hail) then +! melting of graupel at +2 C + + do k=1,nlev + do i=1,mgncol + + if (t(i,k) > snowmelt) then + if (qg(i,k) > zero) then + +! make sure melting graupel doesn't reduce temperature below threshold + dum = -(xlf/cpp) * qg(i,k) + if (t(i,k)+dum < snowmelt) then + dum = max(zero, min(one, (cpp/xlf)*(t(i,k)-snowmelt)/qg(i,k))) + else + dum = one + end if + + minstgm(i,k) = dum*qg(i,k) + ninstgm(i,k) = dum*ng(i,k) + + dum1 = - minstgm(i,k) * (xlf*oneodt) + tlat(i,k) = dum1 + tlat(i,k) + meltsdttot(i,k) = dum1 + meltsdttot(i,k) + +! if (lprnt .and. k >=100) write(0,*)' tlatg=',tlat(i,k),' dum1=',dum1,& +! ' minstgm=',minstgm(i,k),' qg=',qg(i,k),' xlf=',xlf,' oneodt=',oneodt, & +! ' snowmelt=',snowmelt,' t=',t(i,k),' k=',k,' cpp=',cpp + + qg(i,k) = max(qg(i,k) - minstgm(i,k), zero) + ng(i,k) = max(ng(i,k) - ninstgm(i,k), zero) + qr(i,k) = max(qr(i,k) + minstgm(i,k), zero) + nr(i,k) = max(nr(i,k) + ninstgm(i,k), zero) + end if + end if + + end do + end do + endif + +! if (lprnt) write(0,*)' tlat1g=',tlat(1,:)*deltat +!--ag + + 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 = minstrf(i,k) * (xlf*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) + +!++ag +! freeze rain to graupel not snow. + if(do_hail .or. do_graupel) then + qg(i,k) = max(qg(i,k) + minstrf(i,k), zero) + ng(i,k) = max(ng(i,k) + ninstrf(i,k), zero) + else + qs(i,k) = max(qs(i,k) + minstrf(i,k), zero) + ns(i,k) = max(ns(i,k) + ninstrf(i,k), zero) + end if +!--ag + + end if + end if + end do + end do + +! if (lprnt) then +! write(0,*)' tlat2=',tlat(1,:)*deltat +! write(0,*)' lcldm=',lcldm(1,100:127) +! write(0,*)' qc=',qc(1,100:127) +! write(0,*)' nc=',nc(1,100:127) +! write(0,*)' qg2=',qg(1,:) +! endif + + 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) > mincld) then + if (qc(i,k) >= qsmall) 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 .and. icldm(i,k) > mincld) then + if (qi(i,k) >= qsmall) then + ! limit in-cloud values to 0.005 kg/kg + dum = one / icldm(i,k) + 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 + +!++ag add graupel to precip frac? + ! 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 +!++ag +! where (qr(:,k-1) >= qsmall .or. qs(:,k-1) >= qsmall .or. qg(:,k-1) >= qsmall) +!--ag + 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 + !------------------------------------------- + +! if (lprnt .and. k>=60 .and. k<=65) then +! if (lprnt .and. k>=100) then +! if (lprnt) then +! write(0,*)' pgam=',pgam(1,k), ' qcic=',qcic(1,k),' ncic=',ncic(1,k),' rho=',rho(1,k),' k=',k +! endif + call size_dist_param_liq(mg_liq_props, qcic(:,k), ncic(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) +! if (lprnt .and. k>=60 .and. k<=65) then +! if (lprnt .and. k>=100) then +! if (lprnt) then +! write(0,*)' pgam=',pgam(1,k), ' lamc=',lamc(1,k),' k=',k +! endif + + + !======================================================================== + ! 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 + if (precip_frac(i,k) > mincld) then + dum = one / precip_frac(i,k) + else + dum = zero + endif + 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 + do i=1,mgncol + if (qiic(i,k) >= qimax) then + ts_au_loc(i) = ts_au_min + elseif (qiic(i,k) <= qimin) then + ts_au_loc(i) = ts_au + else +! ts_au_loc(i) = (ts_au*(qimax-qiic(i,k)) + ts_au_min*(qiic(i,k)-qimin)) * qiinv + ts_au_loc(i) = ts_au_min *exp(-tsfac*(qiic(i,k)-qimin)) + endif + enddo + if(do_ice_gmao) then + call gmao_ice_autoconversion(t(:,k), qiic(:,k), niic(:,k), lami(:,k), & + n0i(:,k), dcs, ts_au_loc(:), prci(:,k), nprci(:,k), mgncol) + else + call ice_autoconversion(t(:,k), qiic(:,k), lami(:,k), n0i(:,k), & + dcs, ts_au_loc(:), 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 + if (precip_frac(i,k) > mincld) then + dum = one / precip_frac(i,k) + else + dum = zero + endif + 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) + +!++ also do this for graupel, which is assumed to be 'precip_frac' + qgic(i,k) = min(qg(i,k)*dum, 0.01_r8) ! limit in-precip mixing ratios to 10 g/kg) + ngic(i,k) = ng(i,k) * dum + + ! if precip mix ratio is zero so should number concentration + if (qgic(i,k) < qsmall) then + qgic(i,k) = zero + ngic(i,k) = zero + endif + + ! make sure number concentration is a positive number to avoid + ! taking root of negative later + + ngic(i,k) = max(ngic(i,k), zero) +!--ag + 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) + + umr(i,k) = min(dum1, dum*gamma_br_plus4*oneo6) + unr(i,k) = min(dum1, dum*gamma_br_plus1) + 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) >= qsmall) 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*oneo6) + uns(i,k) = min(dum1, dum*gamma_bs_plus1) + + else + ums(i,k) = zero + uns(i,k) = zero + endif + enddo + + if (do_graupel .or. do_hail) then +!++ag +!use correct bg or bh (bgtmp=bg or bh) + !...................................................................... + ! graupel/hail + +!++AG SET rhog here and for mg_graupel_props? +! For now: rhog is constant. Set to same in micro_mg_utils.F90 +! Ideally: find a method to set once. (Hail = 400, Graupel = 500 from M2005) + +!mg,snow_props or mg_graupel props? + + call size_dist_param_basic(mg_graupel_props, qgic(:,k), ngic(:,k), & + lamg(:,k), mgncol, n0=n0g(:,k)) + + do i=1,mgncol + if (lamg(i,k) >= qsmall) then + + ! provisional graupel/hail number and mass weighted mean fallspeed (m/s) + + dum = agn(i,k) / lamg(i,k)**bgtmp + dum1 = 20._r8*rhof(i,k) + umg(i,k) = min(dum1, dum*gamma_bg_plus4*oneo6) + ung(i,k) = min(dum1, dum*gamma_bg_plus1) +! umg(i,k) = min(dum1, dum*gamma(four+bgtmp)*oneo6) +! ung(i,k) = min(dum1, dum*gamma(one+bgtmp)) + + else + umg(i,k) = zero + ung(i,k) = zero + endif + enddo +!--ag + endif + + if (do_cldice) then + if (.not. use_hetfrz_classnuc) then + + ! heterogeneous freezing of cloud water + !---------------------------------------------- + +! if (lprnt .and. k>=60 .and. k<=65) then +! if (lprnt .and. k>=100) then +! if (lprnt) then +! write(0,*)' pgam=',pgam(1,k), ' lamc=',lamc(1,k),' qcic=',qcic(1,k),' ncic=',ncic(1,k),' t=',t(1,k),' k=',k,& +! ' relvar=',relvar(1,k) +! endif + + call immersion_freezing(microp_uniform, t(:,k), pgam(:,k), lamc(:,k), & + qcic(:,k), ncic(:,k), relvar(:,k), mnuccc(:,k), nnuccc(:,k), mgncol) + +! if (lprnt .and. k>=60 .and. k<=65) then +! if (lprnt .and. k>=100) then +! if (lprnt) then +! write(0,*)' mnuccca=',mnuccc(1,k),' lcldm=',lcldm(1,k),' nnuccc=',nnuccc(1,k),' k=',k +! endif + + ! 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) > mincld) + where (qcic(:,k) >= qsmall .and. t(:,k) < 269.15_r8) + 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 + +! if (lprnt .and. k >= 60 .and. k <=65) write(0,*)' mnuccc=',mnuccc(1,60:65) +! if (lprnt .and. k >= 100) write(0,*)' mnuccc=',mnuccc(1,k) +! if (lprnt) write(0,*)' mnuccc=',mnuccc(1,k) + + 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) + +! if (lprnt .and. k >= 60 .and. k <=65) write(0,*)' mnucct=',mnucct(1,:) +! if (lprnt .and. k >= 100 ) write(0,*)' mnucct=',mnucct(1,k) +! if (lprnt) write(0,*)' mnucct=',mnucct(1,k) + + mnudep(:,k) = zero + nnudep(:,k) = zero + + !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*rhoinv(:,k) + !mnuccc(:,k) = nnuccc(:,k)*mi0l + + !nnucct(:,k) = frzcnt(:,k)*1.0e6_r8*rhoinv(:,k) + !mnucct(:,k) = nnucct(:,k)*mi0l + + !nnudep(:,k) = frzdep(:,k)*1.0e6_r8*rhoinv(:,k) + !mnudep(:,k) = nnudep(:,k)*mi0 + !elsewhere + !nnuccc(:,k) = zero + !mnuccc(:,k) = zero + + !nnucct(:,k) = zero + !mnucct(:,k) = zero + + !nnudep(:,k) = zero + !mnudep(:,k) = zero + !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) = zero + msacwi(:,k) = zero + 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) = zero + nprai(:,k) = zero + end if + +!++ag Moved below graupel conditional, now two different versions +! if (.not. (do_hail .or. do_graupel)) then +! 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) +! endif +!--ag + + 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) + berg(i,k) = berg(i,k) * micro_mg_berg_eff_factor + if (ice_sublim(i,k) < zero .and. qi(i,k) > qsmall .and. icldm(i,k) > mincld) then + nsubi(i,k) = sublim_factor * ice_sublim(i,k) * ni(i,k) / (qi(i,k) * icldm(i,k)) + else + nsubi(i,k) = zero + endif + + ! 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(i,k) = zero + end do + + end if !do_cldice + !---PMC 12/3/12 + +!++ag Process rate calls for graupel here. +! (Should this be in do_cldice loop?) +!=================================================================== + + if(do_hail .or. do_graupel) then + call graupel_collecting_snow(qsic(:,k),qric(:,k),umr(:,k),ums(:,k), & + rho(:,k),lamr(:,k),n0r(:,k),lams(:,k),n0s(:,k), psacr(:,k), mgncol) + + call graupel_collecting_cld_water(qgic(:,k),qcic(:,k),ncic(:,k),rho(:,k), & + n0g(:,k),lamg(:,k),bgtmp,agn(:,k), psacwg(:,k), npsacwg(:,k), mgncol) + + call graupel_riming_liquid_snow(psacws(:,k),qsic(:,k),qcic(:,k),nsic(:,k), & + rho(:,k),rhosn,rhogtmp,asn(:,k),lams(:,k),n0s(:,k),deltat, & + pgsacw(:,k),nscng(:,k),mgncol) + +! if(lprnt .and. k >=100) then +! if(lprnt) then +! write(0,*)' k=',k,' qric=',qric(1,k),' qgic=',qgic(1,k),' umg=',umg(1,k),' umr=',umr(1,k),& +! ' ung=',ung(1,k),' unr=',unr(1,k),' rho=',rho(1,k),' n0r=',n0r(1,k),' lamr=',lamr(1,k),& +! ' n0g=',n0g(1,k),' lamg=',lamg(1,k),' pracg=',pracg(1,k) +! endif + call graupel_collecting_rain(qric(:,k),qgic(:,k),umg(:,k), & + umr(:,k),ung(:,k),unr(:,k),rho(:,k),n0r(:,k),lamr(:,k),n0g(:,k), & + lamg(:,k), pracg(:,k),npracg(:,k),mgncol) +! if(lprnt .and. k >=100) write(0,*)' k=',k,' pracg=',pracg(1,k),' npracg=',npracg(1,k) + +!AG note: Graupel rain riming snow changes +! pracs, npracs, (accretion of rain by snow) psacr (collection of snow by rain) + +! if (lprnt .and. abs(k-81) <5) & +! write(0,*)' k=',k,' pracs=',pracs(1,k),' npracs=',npracs(1,k),' psacr=',psacr(1,k),& +! ' qsic=',qsic(1,k),' qric=',qric(1,k),' nric=',nric(1,k),' nsic=',nsic(1,k), & +! ' n0s=',n0s(1,k),' lams=',lams(1,k),' n0r=',n0r(1,k),' lamr=',lamr(1,k), & +! ' pgracs=',pgracs(1,k),' ngracs=',ngracs(1,k) + + call graupel_rain_riming_snow(pracs(:,k),npracs(:,k),psacr(:,k),qsic(:,k), & + qric(:,k),nric(:,k),nsic(:,k),n0s(:,k),lams(:,k),n0r(:,k),lamr(:,k), & + deltat,pgracs(:,k),ngracs(:,k),mgncol) +! if (lprnt .and. abs(k-81) <5) & +! write(0,*)' k=',k,' pracs=',pracs(1,k),' npracs=',npracs(1,k),' psacr=',psacr(1,k),& +! ' pgracs=',pgracs(1,k),' ngracs=',ngracs(1,k) + + call graupel_rime_splintering(t(:,k),qcic(:,k),qric(:,k),qgic(:,k), & + psacwg(:,k),pracg(:,k),qmultg(:,k),nmultg(:,k),qmultrg(:,k), & + nmultrg(:,k),mgncol) + +! if(lprnt .and. k >=100) write(0,*)' k=',k,' pracg2=',pracg(1,k) +! if (lprnt .and. abs(k-81) <5) & +! write(0,*)' k=',k,' pracg2=',pracg(1,k) + + call evaporate_sublimate_precip_graupel(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), agn(:,k), bgtmp, & + qcic(:,k), qiic(:,k), qric(:,k), qsic(:,k), qgic(:,k), & + lamr(:,k), n0r(:,k), lams(:,k), n0s(:,k), lamg(:,k), n0g(:,k), & + pre(:,k), prds(:,k), prdg(:,k), am_evp_st(:,k), mgncol) + +!!Not used: part of above +!! call graupel_sublimate_evap(t(:,k),q(:,k),qgic(:,k),rho(:,k),n0g(:,k), & +!! lamg(:,k),qvi(:,k),dv(:,k),mu(:,k),sc(:,k),bgtmp,agn(:,k), & +!! prdg(:,k),eprdg(:,k),mgncol) + +!Checks for Debugging + +! if (minval(qmultg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, qmultg < 0 : min=",minval(qmultg(:,k)) +! +! if (minval(qmultrg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, qmultrg < 0 : min=",minval(qmultrg(:,k)) +! +! if (minval(pgracs(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, pgracs < 0 : min=",minval(pgracs(:,k)) +! +! if (minval(psacwg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, psacwg < 0 : min=",minval(psacwg(:,k)) +! +! if (minval(npsacwg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, npsacwg < 0 : min=",minval(npsacwg(:,k)) +! +! if (minval(pracg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, pracg < 0 : min=",minval(pracg(:,k)) +! +! if (maxval(prdg(:,k)).gt.0._r8) & +! write(iulog,*) "OOPS, prdg > 0 : max=",maxval(prdg(:,k)) +! +! if (minval(nmultg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, nmultg < 0 : min=",minval(nmultg(:,k)) +! +! if (minval(nmultrg(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, nmultrg < 0 : min=",minval(nmultrg(:,k)) +! +! if (minval(ngracs(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, ngracs < 0 : min=",minval(ngracs(:,k)) +! +! if (minval(psacr(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, psacr < 0 : min=",minval(psacr(:,k)) +! +! if (minval(nscng(:,k)).lt.0._r8) & +! write(iulog,*) "OOPS, nscng < 0 : min=",minval(nscng(:,k)) + + else +! Routine without Graupel (original) + 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) + + + end if ! end do_graupel/hail loop +!--ag + + 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 + !------------------------------------------------------------------- + +!++ag Add graupel tendencies for qc to equation ON +! 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 + dum = ( (prc(i,k) + pra(i,k) + mnuccc(i,k) + mnucct(i,k) + msacwi(i,k) & + + psacws(i,k) + bergs(i,k) + qmultg(i,k) + psacwg(i,k) + pgsacw(i,k))*lcldm(i,k) & + + berg(i,k) ) * deltat +!--ag + + if (dum > qc(i,k) .and. abs(dum) > qsmall) then +!++ag +! ratio = qc(i,k)/deltat/((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 + + ratio = qc(i,k) / dum * omsm + + qmultg(i,k) = ratio * qmultg(i,k) + psacwg(i,k) = ratio * psacwg(i,k) + pgsacw(i,k) = ratio * pgsacw(i,k) +!--ag + 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) * (one-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 + !------------------------------------------------------------------- +!++ag NEW ONE ON +! dum = (nprc1(i,k)+npra(i,k)+nnuccc(i,k)+nnucct(i,k)+ & +! npsacws(i,k)-nsubc(i,k))*lcldm(i,k)*deltat + dum = (nprc1(i,k) + npra(i,k) + nnuccc(i,k) + nnucct(i,k) & + + npsacws(i,k) - nsubc(i,k) + npsacwg(i,k))*lcldm(i,k)*deltat +!--ag + + if (dum > nc(i,k) .and. abs(dum) > qsmall) then + ratio = nc(i,k) / dum * omsm +!++ag + npsacwg(i,k) = ratio * npsacwg(i,k) +!--ag + + 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. one/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 + !------------------------------------------------------------------- +!++ag Implemented change for graupel + dum1 = - pre(i,k) + pracs(i,k) + mnuccr(i,k) + mnuccri(i,k) & + + qmultrg(i,k) + pracg(i,k) + pgracs(i,k) + dum3 = dum1 * precip_frac(i,k) + dum2 = (pra(i,k)+prc(i,k))*lcldm(i,k) + dum = (dum3 - dum2) * deltat +!--ag + + ! note that qrtend is included below because of instantaneous freezing/melt + if (dum > qr(i,k) .and. dum1 >= qsmall .and. abs(dum3) > qsmall) then + ratio = (qr(i,k)*oneodt + dum2) / dum3 * omsm +!++ag + qmultrg(i,k) = ratio * qmultrg(i,k) + pracg(i,k) = ratio * pracg(i,k) + pgracs(i,k) = ratio * pgracs(i,k) +!--ag + 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 + +!++ag IMplemented change for graupel +! dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k))*precip_frac(i,k) +! nprc(i,k)*lcldm(i,k))*deltat + + dum1 = (-nsubr(i,k)+npracs(i,k)+nnuccr(i,k)+nnuccri(i,k)-nragg(i,k) & + +npracg(i,k)+ngracs(i,k))*precip_frac(i,k) + dum2 = nprc(i,k)*lcldm(i,k) + dum = (dum1 - dum2) * deltat +!--ag + + if (dum > nr(i,k) .and. abs(dum1) > qsmall) then + ratio = (nr(i,k)*oneodt + dum2) / dum1 * omsm + +!++ag + npracg(i,k) = ratio * npracg(i,k) + ngracs(i,k) = ratio * ngracs(i,k) +!--ag + 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 + !------------------------------------------------------------------- + +!++ag + + 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) + dum2 = vap_dep(i,k)+berg(i,k)+mnuccd(i,k) & + + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(i,k))*lcldm(i,k) & + + (qmultrg(i,k)+mnuccri(i,k))*precip_frac(i,k) + dum = (dum1 - dum2) * deltat +!-ag + + if (dum > qi(i,k) .and. abs(dum1) > qsmall) then + ratio = (qi(i,k)*oneodt + dum2) / dum1 * omsm + +!++ag +! Only sink terms are limited. +! qmultg(i,k) = ratio * qmultg(i,k) +! qmultrg(i,k) = ratio * qmultrg(i,k) +!--ag + 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 +!++ag + 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) + dum2 = nnuccd(i,k)+(nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & + + (nmultrg(i,k)+nnuccri(i,k))*precip_frac(i,k) +!--ag + dum = (dum1 - dum2) * deltat + + if (dum > ni(i,k) .and. abs(dum1) > qsmall) 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 + !------------------------------------------------------------------- +!++ag + if (do_hail .or. do_graupel) then +!NOTE: mnuccr is moved to graupel when active +!psacr is a positive value, but a loss for snow +!HM: psacr is positive in dum (two negatives) + + dum1 = (psacr(i,k) - prds(i,k)) * precip_frac(i,k) + dum2 = pracs(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. psacr(i,k)-prds(i,k) >= qsmall) then + ratio = (qs(i,k)*oneodt + dum2) / dum1 * omsm + psacr(i,k) = ratio * psacr(i,k) + prds(i,k) = ratio * prds(i,k) + endif + else + 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) + endif + endif + +!--ag +! 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 + + ratio = one +!++ag Watch sign of nscng and ngracs. What is sign of nnuccr? Negative? Should be a source here. + + if (do_hail .or. do_graupel) then +! dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)) +! dum2 = nprci(i,k)*icldm(i,k) + nscng(i,k)*lcldm(i,k) +! dum = (dum1 - dum2) * deltat +! check here - this is slightly different from ag version - moorthi + + dum1 = precip_frac(i,k)* (-nsubs(i,k)-nsagg(i,k)+ngracs(i,k)) & + - nscng(i,k)*lcldm(i,k) + dum2 = nprci(i,k)*icldm(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > ns(i,k) .and. abs(dum1) > qsmall) then + ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm + nscng(i,k) = ratio * nscng(i,k) + ngracs(i,k) = ratio * ngracs(i,k) + end if + + else + 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 + + if (dum > ns(i,k) .and. abs(dum1) > qsmall) then + ratio = (ns(i,k)*oneodt + dum2) / dum1 * omsm + end if + endif + nsubs(i,k) = ratio * nsubs(i,k) + nsagg(i,k) = ratio * nsagg(i,k) + + end do + +!++ag Graupel Conservation Checks +!------------------------------------------------------------------- + if (do_hail .or. do_graupel) then +! conservation of graupel mass +!------------------------------------------------------------------- + do i=1,mgncol + + dum1 = -prdg(i,k) * precip_frac(i,k) + dum2 = (pracg(i,k)+pgracs(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) & + + (psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) + dum = (dum1 - dum2) * deltat + + if (dum > qg(i,k) .and. abs(dum1) > qsmall) then + +! hm added +! note: prdg is always negative (like prds), so it needs to be subtracted in ratio + ratio = (qg(i,k)*oneodt + dum2) / dum1 * omsm + + prdg(i,k) = ratio * prdg(i,k) + + end if + + end do + +! conservation of graupel number: not needed, no sinks +!------------------------------------------------------------------- + end if +!--ag + + + 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 + +!++ag need to add graupel sublimation/evap here too (prdg)? May not need eprdg? +!++ag + tx1 = pre(i,k) * precip_frac(i,k) + tx2 = prds(i,k) * precip_frac(i,k) + tx6 = prdg(i,k) * precip_frac(i,k) + tx5 = tx2 + tx6 + tx3 = tx1 + tx5 + ice_sublim(i,k) + + if (tx3 < -1.e-20_r8) then + + tx4 = tx5 + ice_sublim(i,k) + vap_dep(i,k) + mnuccd(i,k) + qtmp = q(i,k) - (tx1 + tx4) * deltat + ttmp = t(i,k) + (tx1*xxlv + tx4*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) +! qvn = epsqs*esn/(p(i,k)-omeps*esn) + + ! modify ice/precip evaporation rate if q > qsat + if (qtmp > qvn) then + + tx4 = one / tx3 + dum1 = tx1 * tx4 + dum2 = tx2 * tx4 +!++ag + dum3 = tx6 * tx4 +!--ag + ! 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) +! qvn = epsqs*esn / (p(i,k)-omeps*esn) + + dum = min(zero, (qtmp-qvn)/(one + xxlv_squared*qvn/(cpp*rv*ttmp*ttmp))) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + if (precip_frac(i,k) > mincld) then + tx4 = oneodt / precip_frac(i,k) + else + tx4 = zero + endif + pre(i,k) = dum*dum1*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) +! qvn = epsqs*esn / (p(i,k)-omeps*esn) + + + dum = min(zero, (qtmp-qvn)/(one + xxls_squared*qvn/(cpp*rv*ttmp*ttmp))) + + ! modify rates if needed, divide by precip_frac to get local (in-precip) value + prds(i,k) = dum*dum2*tx4 +!++ag + prdg(i,k) = dum*dum3*tx4 +!--ag +!++ag + ! don't divide ice_sublim by cloud fraction since it is grid-averaged +! dum1 = one - dum1 - dum2 + dum1 = one - dum1 - dum2 - dum3 +!--ag + 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. + +!++ag +! 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) + + 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) & + -prdg(i,k)*precip_frac(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) + +! if (lprnt .and. k >= 60 .and. k <=65) & +! if (lprnt .and. k >= 100 ) & +! if (lprnt .and. abs(k-81) <5) & +! if (lprnt .and. k >= 60 ) & +! write(0,*)' k=',k,' tlat=',tlat(i,k),' pre=',pre(i,k),' precip_frac=',precip_frac(i,k),& +! ' prds=',prds(i,k),' prdg=',prdg(i,k),' vap_dep=',vap_dep(i,k),' ice_sublim=',ice_sublim(i,k), & +! ' mnuccd=',mnuccd(i,k),' mnudep=',mnudep(i,k),' lcldm=',lcldm(i,k),' bergs=',bergs(i,k), & +! ' psacws=',psacws(i,k),' mnuccc=',mnuccc(i,k),' mnucct=',mnucct(i,k),' msacwi=',msacwi(i,k), & +! ' psacwg=',psacwg(i,k),' qmultg=',qmultg(i,k),' pgsacw=',pgsacw(i,k),' mnuccr=',mnuccr(i,k), & +! ' pracs=',pracs(i,k),' mnuccri=',mnuccri(i,k),' pracg=',pracg(i,k),' pgracs=',pgracs(i,k), & +! ' qmultrg=',qmultrg(i,k),' xlf=',xlf,' xxlv=',xxlv,' xxls=',xxls + + + tlat(i,k) = tlat(i,k)+((pre(i,k)*precip_frac(i,k))*xxlv+ & + ((prds(i,k)+prdg(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)+psacwg(i,k)+ & + qmultg(i,k)+pgsacw(i,k))*lcldm(i,k)+ & + (mnuccr(i,k)+pracs(i,k)+mnuccri(i,k)+pracg(i,k)+pgracs(i,k)+qmultrg(i,k))*precip_frac(i,k)+ & + berg(i,k))*xlf) + +! if (lprnt .and. k >= 100 ) write(0,*)' k=',k,' tlat=',tlat(i,k) +! if (lprnt) write(0,*)' k=',k,' tlat=',tlat(i,k) +! if (lprnt .and. k >= 60) write(0,*)' k=',k,' tlat=',tlat(i,k) + +! 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))*l!ldm(i,k)-berg(i,k) + + 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)-qmultg(i,k)-psacwg(i,k)-pgsacw(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) + + qitend(i,k) = qitend(i,k)+ & + (mnuccc(i,k)+mnucct(i,k)+mnudep(i,k)+msacwi(i,k)+qmultg(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)+qmultrg(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) + + 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)-qmultrg(i,k)-pracg(i,k)-pgracs(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) + + if (do_hail.or.do_graupel) then + qgtend(i,k) = qgtend(i,k) + (pracg(i,k)+pgracs(i,k)+prdg(i,k)+psacr(i,k)+mnuccr(i,k))*precip_frac(i,k) & + + (psacwg(i,k)+pgsacw(i,k))*lcldm(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)-psacr(i,k))*precip_frac(i,k) + + else + !necessary since mnuccr moved to graupel + 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) + + end if +!--ag + + + 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 + +!++add evaporation/sublimation of graupel too? YES: After conservation checks. + +!++ag +!ADD GRAUPEL to evapsnow: prdg. (sign? same as prds: negative, so this is a positive number) +! evapsnow(i,k) = -prds(i,k) * precip_frac(i,k) + evapsnow(i,k) = (-prds(i,k)-prdg(i,k)) * precip_frac(i,k) +!--ag + 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 + +!++AG NEED TO MAKE CONSISTENT WITH BUDGETS + 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) + if (do_hail .or. do_graupel) then +! Subtract PSACR here or not? Ask Hugh + prodsnow(i,k) = (prai(i,k)+prci(i,k))*icldm(i,k)+(psacws(i,k)+bergs(i,k))*lcldm(i,k)+ & + pracs(i,k)*precip_frac(i,k) + else + 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) + end if + + ! 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) + +!++AG NEED TO MAKE CONSITANT: PGSACW, PSACWG (check budgets)? More sink terms? Check. No. Just loss to precip. +!Ask Hugh +! qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k))*lcldm(i,k) + qcsinksum_rate1ord(i,k) = (pra(i,k)+prc(i,k)+psacws(i,k)+psacwg(i,k)+pgsacw(i,k))*lcldm(i,k) +!--ag + ! 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) +!++ag + mnuccritot(i,k) = mnuccri(i,k) * precip_frac(i,k) +!--ag + +!++ag Hail/Graupel tendencies for output + psacrtot(i,k) = psacr(i,k) * precip_frac(i,k) + pracgtot(i,k) = pracg(i,k) * precip_frac(i,k) + psacwgtot(i,k) = psacwg(i,k) * lcldm(i,k) + pgsacwtot(i,k) = pgsacw(i,k) * lcldm(i,k) + pgracstot(i,k) = pgracs(i,k) * precip_frac(i,k) + prdgtot(i,k) = prdg(i,k) * precip_frac(i,k) + qmultgtot(i,k) = qmultg(i,k) * lcldm(i,k) + qmultrgtot(i,k) = qmultrg(i,k) * precip_frac(i,k) + npracgtot(i,k) = npracg(i,k) * precip_frac(i,k) + nscngtot(i,k) = nscng(i,k) * lcldm(i,k) + ngracstot(i,k) = ngracs(i,k) * precip_frac(i,k) + nmultgtot(i,k) = nmultg(i,k) * lcldm(i,k) + nmultrgtot(i,k) = nmultrg(i,k) * precip_frac(i,k) + npsacwgtot(i,k) = npsacwg(i,k) * lcldm(i,k) +!--ag + +!++ag +! 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) + + nctend(i,k) = nctend(i,k) + (-nnuccc(i,k)-nnucct(i,k)-npsacws(i,k)+nsubc(i,k) & + -npra(i,k)-nprc1(i,k)-npsacwg(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) + + nitend(i,k) = nitend(i,k) + nnuccd(i,k) + & + + (nnucct(i,k)+tmpfrz+nnudep(i,k)+nsacwi(i,k)+nmultg(i,k))*lcldm(i,k) & + + (nsubi(i,k)-nprci(i,k)-nprai(i,k))*icldm(i,k) & + + (nnuccri(i,k)+nmultrg(i,k))*precip_frac(i,k) + end if + + if(do_graupel.or.do_hail) then +! 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) + + nstend(i,k) = nstend(i,k) + (nsubs(i,k)+nsagg(i,k)-ngracs(i,k))*precip_frac(i,k) & + + nprci(i,k)*icldm(i,k)-nscng(i,k)*lcldm(i,k) + + ngtend(i,k) = ngtend(i,k) + nscng(i,k)*lcldm(i,k) & + + (ngracs(i,k)+nnuccr(i,k))*precip_frac(i,k) + + else + !necessary since mnuccr moved to graupel + 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) + + end if + +! 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) + + 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)-npracg(i,k)-ngracs(i,k))*precip_frac(i,k) +!--ag + + ! 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) +!++ag + qgout(i,k) = qg(i,k) + ngout(i,k) = ng(i,k) * rho(i,k) +!--ag + 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. + qstend(i,k) = qstend(i,k) + (qs(i,k)-qsn(i,k)) * oneodt + qs(i,k) = qsn(i,k) + + nstend(i,k) = nstend(i,k) + (ns(i,k)-nsn(i,k)) * oneodt + ns(i,k) = nsn(i,k) + + qrtend(i,k) = qrtend(i,k) + (qr(i,k)-qrn(i,k)) * oneodt + qr(i,k) = qrn(i,k) + + nrtend(i,k) = nrtend(i,k) + (nr(i,k)-nrn(i,k)) * oneodt + nr(i,k) = nrn(i,k) + +!++ag Re-apply graupel freezing/melting + qgtend(i,k) = qgtend(i,k) + (qg(i,k)-qgr(i,k)) * oneodt + qg(i,k) = qgr(i,k) + +! if (maxval(dum_2D-qg).gt.0._r8) & +! write(iulog,*) "OOPS, qg diff > 0 : max=",maxval(dum_2D-qg) +! if (minval(dum_2D-qg).lt.0._r8) & +! write(iulog,*) "OOPS, qg diff < 0 : min=",minval(dum_2D-qg) +! +! write(iulog,*) "Max qgtend: 1st = ",maxval(qgtend) +! write(iulog,*) "Min qgtend: 1st = ",minval(qgtend) +! write(iulog,*) "Max qvtend: 1st = ",maxval(qvlat) +! write(iulog,*) "Min qvtend: 1st = ",minval(qvlat) + + ngtend(i,k) = ngtend(i,k) + (ng(i,k)-ngr(i,k)) * oneodt + ng(i,k) = ngr(i,k) +!--ag + + !............................................................................. + + !================================================================================ + + ! 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 +!++ag ! and Graupel (mg3) + !================================================================================ + + ! 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) > mincld) 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) + ! switch for specification of droplet and crystal number + if (nccons) then + dumnc(i,k) = ncnst*rhoinv(i,k) + end if + else + dumc(i,k) = zero + dumnc(i,k) = zero + endif + if (icldm(i,k) > mincld) 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) + ! switch for specification of cloud ice number + if (nicons) then + dumni(i,k) = ninst*rhoinv(i,k) + end if + else + dumi(i,k) = zero + dumni(i,k) = zero + endif + if (precip_frac(i,k) > mincld) 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) + +!++ag Add graupel + dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat) * tx1 +! Moorthi testing + if (dumg(i,k) > 0.01) then + tx2 = dumg(i,k) - 0.01 + dumg(i,k) = 0.01 + dums(i,k) = dums(i,k) + tx2 + qstend(i,k) = (dums(i,k)*precip_frac(i,k) - qs(i,k)) * oneodt + qgtend(i,k) = (dumg(i,k)*precip_frac(i,k) - qg(i,k)) * oneodt + endif +! Moorthi testing + + dumng(i,k) = max((ng(i,k)+ngtend(i,k)*deltat)*tx1, zero) + ! switch for specification of droplet and crystal number + if (ngcons) then + dumng(i,k) = ngnst*rhoinv(i,k) + endif +!--ag + else + dumr(i,k) = zero + dumr(i,k) = zero + dums(i,k) = zero + dumns(i,k) = zero +!++ag Add graupel + dumg(i,k) = zero + dumng(i,k) = zero + endif +!--ag + enddo + enddo + + do k=1,nlev + +! obtain new slope parameter to avoid possible singularity + + + call size_dist_param_liq(mg_liq_props, dumc(:,k), dumnc(:,k), rho(:,k), & + pgam(:,k), lamc(:,k), mgncol) + + call size_dist_param_basic(mg_ice_props, dumi(:,k), dumni(:,k), & + lami(:,k), mgncol) +! fallspeed for rain + + call size_dist_param_basic(mg_rain_props, dumr(:,k), dumnr(:,k), & + lamr(:,k), mgncol) +! fallspeed for snow + call size_dist_param_basic(mg_snow_props, dums(:,k), dumns(:,k), & + lams(:,k), mgncol) +! fallspeed for graupel/hail + if (do_graupel .or. do_hail) then + call size_dist_param_basic(mg_graupel_props, dumg(:,k), dumng(:,k), & + lamg(:,k), mgncol) + endif + enddo + + do k=1,nlev + do i=1,mgncol + + ! calculate number and mass weighted fall velocity for droplets and cloud ice + !------------------------------------------------------------------- + + grho = g*rho(i,k) + + if (dumc(i,k) >= qsmall) then + + tx1 = lamc(i,k)**bc + vtrmc(i,k) = acn(i,k)*gamma(pgam(i,k)+four+bc) & + / (tx1*gamma(pgam(i,k)+four)) + + fc(i,k) = grho * vtrmc(i,k) + fnc(i,k) = grho * acn(i,k)*gamma(pgam(i,k)+one+bc) & + / (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*oneo6, tx2) + + fi(i,k) = grho * vtrmi(i,k) + fni(i,k) = grho * 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*oneo6, tx2) + + fi(i,k) = grho * vtrmi(i,k) + fni(i,k) = ifrac * fni(i,k) + (one-ifrac) * grho * min(tx1*gamma_bj_plus1, tx2) + end if + else + fi(i,k) = zero + fni(i,k)= zero + end if + + ! fallspeed for rain + +! 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) + umr(i,k) = min(tx1*gamma_br_plus4*oneo6, tx2) + unr(i,k) = min(tx1*gamma_br_plus1, tx2) + + fr(i,k) = grho * umr(i,k) + fnr(i,k) = grho * unr(i,k) + + else + fr(i,k) = zero + fnr(i,k) = zero + end if + + ! fallspeed for snow + +! 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*oneo6, tx2) + uns(i,k) = min(tx1*gamma_bs_plus1, tx2) + + fs(i,k) = grho * ums(i,k) + fns(i,k) = grho * uns(i,k) + + else + fs(i,k) = zero + fns(i,k) = zero + end if + + if (do_graupel .or. do_hail) then +!++ag + ! fallspeed for graupel + + +! if (lamg(i,k) >= qsmall) then + if (dumg(i,k) >= qsmall) then + + ! 'final' values of number and mass weighted mean fallspeed for graupel (m/s) + tx1 = agn(i,k) / lamg(i,k)**bgtmp + tx2 = 20._r8 * rhof(i,k) + umg(i,k) = min(tx1*gamma_bg_plus4*oneo6, tx2) + ung(i,k) = min(tx1*gamma_bg_plus1, tx2) + + fg(i,k) = grho * umg(i,k) + fng(i,k) = grho * ung(i,k) + + else + fg(i,k) = zero + fng(i,k) = zero + end if + endif + + ! 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 +!++ag + dumg(i,k) = qg(i,k) + qgtend(i,k)*deltat + dumng(i,k) = ng(i,k) + ngtend(i,k)*deltat +!--ag + + 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 + if (dumg(i,k) < qsmall) dumng(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 + nint(max( maxval( fi(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fni(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + + ! 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 + + if (icldm(i,k-1) > mincld) then + dum1 = max(zero, min(one, icldm(i,k)/icldm(i,k-1))) + else + dum1 = one + endif + + tx5 = dumi(i,k) + tx7 = pdel_inv(i,k) * tx1 + dum2 = tx7 * dum1 + dumi(i,k) = (tx5 + falouti(k-1)*dum2) / (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)*dum2) / (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) + + dum2 = (one-dum1) * falouti(k-1) * pdel_inv(i,k) * tx2 + qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to evap/sub of cloud ice + qisevap(i,k) = qisevap(i,k) + dum2 ! for output + + tlat(i,k) = tlat(i,k) - dum2 * xxls + + 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 + nint(max( maxval( fc(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fnc(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + ! 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 + + if (lcldm(i,k-1) > mincld) then + dum1 = max(zero, min(one, lcldm(i,k)/lcldm(i,k-1))) + else + dum1 = one + endif + + tx5 = dumc(i,k) + tx7 = pdel_inv(i,k) * tx1 + dum2 = tx7 * dum1 + dumc(i,k) = (tx5 + faloutc(k-1)*dum2) / (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)*dum2) / (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) + + dum2 = (one-dum1) * faloutc(k-1) * pdel_inv(i,k) * tx2 + qvlat(i,k) = qvlat(i,k) + dum2 ! add terms to to evap/sub of cloud water + qcsevap(i,k) = qcsevap(i,k) + dum2 ! for output + + tlat(i,k) = tlat(i,k) - dum2 * xxlv + + 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 +! if (lprnt) write(0,*)' maxval=',maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))& +! ,maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)) + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fr(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fnr(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + + nstep = min(nstep, nstep_def) + + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + +! if(lprnt) then +! write(0,*)' nstep=',nstep,' tx1=',tx1,' tx2=',tx2,' tx3=',tx3,' qsmall=',qsmall +! write(0,*)' fr=',fr(i,:) +! write(0,*)' dumr=',dumr(i,:) +! endif + + 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 + + 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 + +! if (lprnt) write(0,*)' prectaftrain=',prect(i),' preci=',preci(i) + + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fs(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fns(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + + ! 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 + +! if (lprnt) write(0,*)' prectaftssno=',prect(i),' preci=',preci(i) +! if (lprnt) write(0,*)' qgtnd1=',qgtend(1,:) + + if (do_graupel .or. do_hail) then +!++ag Graupel Sedimentation + ! calculate number of split time steps to ensure courant stability criteria + ! for sedimentation calculations + !------------------------------------------------------------------- + nstep = 1 + nint(max( maxval( fg(i,nlb:nlev)*pdel_inv(i,nlb:nlev)), & + maxval(fng(i,nlb:nlev)*pdel_inv(i,nlb:nlev))) * deltat) + nstep = min(nstep, nstep_def) + + tx2 = one / nstep + tx1 = tx2 * deltat + tx3 = tx2 / g + ! loop over sedimentation sub-time step to ensure stability + !============================================================== + do n = 1,nstep + + ! top of model + k = 1 + + ! add fallout terms to microphysical tendencies + + tx5 = dumg(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumg(i,k) = tx5 / (one + fg(i,k)*tx7) + tx6 = (dumg(i,k)-tx5) * oneodt + qgtend(i,k) = qgtend(i,k) + tx6 + tx5 = dumng(i,k) + dumng(i,k) = tx5 / (one + fng(i,k)*tx7) + ngtend(i,k) = ngtend(i,k) + (dumng(i,k)-tx5) * oneodt + + ! sedimentation tendency for output + qgsedten(i,k) = qgsedten(i,k) + tx6 + + faloutg(k) = fg(i,k) * dumg(i,k) + faloutng(k) = fng(i,k) * dumng(i,k) + + gflx(i,k+1) = gflx(i,k+1) + faloutg(k) * tx3 ! Ice flux + + do k = 2,nlev + + tx5 = dumg(i,k) + tx7 = pdel_inv(i,k) * tx1 + dumg(i,k) = (tx5 + faloutg(k-1)*tx7) / (one + fg(i,k)*tx7) + tx6 = (dumg(i,k)-tx5) * oneodt + ! add fallout terms to eulerian tendencies + qgtend(i,k) = qgtend(i,k) + tx6 + tx5 = dumng(i,k) + dumng(i,k) = (tx5 + faloutng(k-1)*tx7) / (one + fng(i,k)*tx7) + ngtend(i,k) = ngtend(i,k) + (dumng(i,k)-tx5) * oneodt + + + qgsedten(i,k) = qgsedten(i,k) + tx6 ! sedimentation tendency for output + + + faloutg(k) = fg(i,k) * dumg(i,k) + faloutng(k) = fng(i,k) * dumng(i,k) + + gflx(i,k+1) = gflx(i,k+1) + faloutg(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) + faloutg(nlev) * (tx3*0.001_r8) + preci(i) = preci(i) + faloutg(nlev) * (tx3*0.001_r8) + + end do !! nstep loop + endif +! if (lprnt) write(0,*)' qgtnds=',qgtend(1,:) +!--ag + enddo ! end of i loop + ! end sedimentation + +! if (lprnt) write(0,*)' prectaftsed=',prect(i),' preci=',preci(i) + + !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) + +!++ag + dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) +! Moorthi testing + if (dumg(i,k) > 0.01) then + tx2 = dumg(i,k) - 0.01 + dumg(i,k) = 0.01 + dums(i,k) = dums(i,k) + tx2 + qstend(i,k) = (dums(i,k) - qs(i,k)) * oneodt + qgtend(i,k) = (dumg(i,k) - qg(i,k)) * oneodt + endif +! Moorthi testing + dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat, zero) +!--ag + + ! 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 + +!++ag + ! switch for specification of graupel number + if (ngcons) then + dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) + end if +!--ag + + 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 +!++ag + if (dumg(i,k) < qsmall) dumng(i,k) = zero +!--ag + + 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 + + tx2 = dum * oneodt + qstend(i,k) = qstend(i,k) - tx2*dums(i,k) + nstend(i,k) = nstend(i,k) - tx2*dumns(i,k) + qrtend(i,k) = qrtend(i,k) + tx2*dums(i,k) + nrtend(i,k) = nrtend(i,k) + tx2*dumns(i,k) + + dum1 = - xlf * tx2 * dums(i,k) + tlat(i,k) = dum1 + tlat(i,k) + meltsdttot(i,k) = dum1 + meltsdttot(i,k) + end if + end if + enddo + enddo + + if (do_graupel .or. do_hail) then +!++ag + + ! melting of graupel 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 (dumg(i,k) > zero) then + + ! make sure melting graupel doesn't reduce temperature below threshold + dum = -(xlf/cpp) * dumg(i,k) + if (tx1+dum < zero) then + dum = max(zero, min(one, -tx1/dum)) + else + dum = one + end if + + tx2 = dum * oneodt + + qgtend(i,k) = qgtend(i,k) - tx2*dumg(i,k) + ngtend(i,k) = ngtend(i,k) - tx2*dumng(i,k) + qrtend(i,k) = qrtend(i,k) + tx2*dumg(i,k) + nrtend(i,k) = nrtend(i,k) + tx2*dumng(i,k) + + dum1 = - xlf*tx2*dumg(i,k) + tlat(i,k) = dum1 + tlat(i,k) + meltsdttot(i,k) = dum1 + meltsdttot(i,k) + end if + end if + enddo + enddo + +!--ag + endif + + 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 +!++ag freeze rain to graupel + if (do_hail .or. do_graupel) then + qgtend(i,k) = qgtend(i,k) + tx2 * dumr(i,k) + ngtend(i,k) = ngtend(i,k) + tx2 * dumnr(i,k) + else + qstend(i,k) = qstend(i,k) + tx2 * dumr(i,k) + nstend(i,k) = nstend(i,k) + tx2 * dumnr(i,k) + end if +!--ag + 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) +! qvn = epsqs*esn/(p(i,k)-omeps*esn) + + + 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 + if (lcldm(i,k) > mincld) then + tx1 = one / lcldm(i,k) + else + tx1 = zero + endif + if (icldm(i,k) > mincld) then + tx2 = one / icldm(i,k) + else + tx2 = zero + endif + if (precip_frac(i,k) > mincld) then + tx3 = one / precip_frac(i,k) + else + tx3 = zero + endif + 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 + +!++ag + dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) * tx3 + dumng(i,k) = max(ng(i,k)+ngtend(i,k)*deltat, zero) * tx3 +!--ag + + ! 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 + +!++ag + ! switch for specification of graupel number + if (ngcons) then + dumng(i,k) = ngnst*rhoinv(i,k)*precip_frac(i,k) + end if +!--ag + + ! 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) +!++ag + dumg(i,k) = min(dumg(i,k), 10.e-3_r8) +!--ag + 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 +!++ag + if (qg(i,k)+qgtend(i,k)*deltat < qsmall) ngtend(i,k) = -ng(i,k) * oneodt +!--ag + + 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) > mincld) then + if (qc(i,k) >= qsmall .and. (nc(i,k)+nctend(i,k)*deltat) > ten) 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) > mincld) then + if (qi(i,k) >= qsmall) 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_mg3_0 diff --git a/physics/micro_mg_utils.F90 b/physics/micro_mg_utils.F90 new file mode 100755 index 000000000..78556a5f8 --- /dev/null +++ b/physics/micro_mg_utils.F90 @@ -0,0 +1,2538 @@ +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 +! S. Moorthi - Feb 2018 : code optimization +! +! This version: https://svn-ccsm-models.cgd.ucar.edu/cam1/branch_tags/mg3_tags/mg3_33_cam5_4_153/ +! +! 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, & +!++ag + graupel_collecting_snow, & + graupel_collecting_rain, & + graupel_collecting_cld_water, & + graupel_riming_liquid_snow, & + graupel_rain_riming_snow, & + graupel_rime_splintering, & + evaporate_sublimate_precip_graupel +! graupel_sublimate_evap +!--ag + + +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 +!++ag +type(MGHydrometeorProps), public :: mg_graupel_props +!--ag + +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.000001_r8 +!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 + +!++ag +!Hail and Graupel (set in MG3) +real(r8), parameter, public :: rhog = 500._r8 +real(r8), parameter, public :: rhoh = 400._r8 +!--ag + +! 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 +!++ag +! graupel +real(r8), parameter, public :: ag = 19.3_r8 +real(r8), parameter, public :: bg = 0.37_r8 +! hail +real(r8), parameter, public :: ah = 114.5_r8 +real(r8), parameter, public :: bh = 0.5_r8 +!--ag + +! 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 + +!++ag +! mass of new graupel particle (assume same as mi0 for now, may want to make bigger?) +!real(r8), parameter, public :: mg0 = 4._r8/3._r8*pi*rhoi*(1.e-6_r8)**3 +!or set based on M2005: +real(r8), parameter, public :: mg0 = 1.6e-10_r8 +! radius of contact nuclei +real(r8), parameter, public :: mmult = 4._r8/3._r8*pi*rhoi*(5.e-6_r8)**3 +!--ag + +!================================================= +! 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 +!++ag +! collection efficiency, ice-droplet collisions +real(r8), parameter, public :: ecid = 0.7_r8 +! collection efficiency between droplets/rain and snow/rain +real(r8), parameter, public :: ecr = 1.0_r8 +!--ag + +! 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) + +real(r8) :: ra ! dry air gas constant + +! 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 +!++ag +real(r8) :: gamma_2bs_plus2 +!--ag +! +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, & + twopi = pi + pi + +!========================================================= +! 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, rair, rh2o, cpair, tmelt_in, latvap, & + latice, dcs) +! latice, dcs, errstring) + + integer, intent(in) :: kind +!++ag + real(r8), intent(in) :: rair +!--ag + 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 + !++ag + ra = rair ! dry air gas constant + !--ag + + ! 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) +!++ag + gamma_2bs_plus2 = gamma(bs+bs+two) +!--ag + + + ! 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) +!++ag + mg_graupel_props = MGHydrometeorProps(rhog, dsph, lam_bnd_snow) +!--ag + +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 = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic*rho) +! 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) = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic(i)*rho(i)) +! 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 = twopi*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) * & + 0.01_r8 * 1350._r8 * qcic(i)**2.47_r8 * (ncic(i)*1.e-6_r8*rho(i))**(-1.1_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 = max(1, min(int(pgam(i)), 15)) + 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), dimension(mgncol), 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(i))*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), dimension(mgncol), 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, tx2 + 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 + tx2 = one / ac_time(i) + nprci(i) = niic(i)*tx2 * (one - gamma_incomp(m_ip, tx1)) + prci(i) = qiic(i)*tx2 * (one - gamma_incomp(m_ip+three, 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+dum1) * 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, tx2 + integer :: i + + do i=1,mgncol + if (qric(i) >= icsmall .and. qsic(i) >= icsmall .and. t(i) <= tmelt) then + + tx2 = lamr(i)*lamr(i)*lamr(i) + + common_factor = pi*ecr*rho(i)*n0r(i)*n0s(i) / (tx2 * 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)) * & + ((half*d_rat + two)*d_rat + five) / tx2 + + 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 = zero + ! 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 + +! evaporation/sublimation of rain, snow and graupel +!=================================================================== +! 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_graupel(t, rho, dv, mu, sc, q, qvl, qvi, & + lcldm, precip_frac, arn, asn, agn, bg, qcic, qiic, qric, qsic, qgic, lamr, n0r, lams, n0s, lamg, n0g, & + pre, prds, prdg, 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 +!++ag + real(r8), dimension(mgncol), intent(in) :: agn ! graupel + real(r8), intent(in) :: bg +!--ag + + ! 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 + real(r8), dimension(mgncol), intent(in) :: qgic ! graupel + + ! 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 +!++ag + ! graupel + real(r8), dimension(mgncol), intent(in) :: lamg + real(r8), dimension(mgncol), intent(in) :: n0g +!--ag + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: pre + real(r8), dimension(mgncol), intent(out) :: prds +!++ag + real(r8), dimension(mgncol), intent(out) :: prdg +!--ag + 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), dimension(mgncol) :: dum + + integer :: i + + ! 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 .or. qgic(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 = twopi*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 = twopi*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 + +!++AG ADD GRAUPEL, do Same with prdg. + + if (qgic(i) >= qsmall) then + ab = calc_ab(t(i), qvi(i), xxls) + + eps = twopi*n0g(i)*rho(i)*Dv(i)* & + ( f1s/(lamg(i)*lamg(i)) & + + f2s*sqrt(agn(i)*rho(i)/mu(i)) & + * sc(i)**oneo3*gamma((five+bg)*half) & + / (lamg(i)**((five+bs)*half))) +! / (lamg(i)**((five+bg)*half))) ! changing bs to bg - Moorthi + prdg(i) = eps*(qclr-qvi(i))/ab + + ! only sublimate in out-of-cloud region and distribute over precip_frac + prdg(i) = min(prdg(i)*am_evp_st(i), zero) + prdg(i) = prdg(i)/precip_frac(i) + else + prdg(i) = zero + end if + + else + prds(i) = zero + pre(i) = zero +!++ag + prdg(i) = zero +!--ag + end if + enddo + +end subroutine evaporate_sublimate_precip_graupel + + +! 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 mixing ratio + real(r8), dimension(mgncol), intent(in) :: qsic ! snow mixing ratio + + ! 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 + +!======================================================================== +! Collection of snow by rain to form graupel +!======================================================================== + +subroutine graupel_collecting_snow(qsic,qric,umr,ums,rho,lamr,n0r,lams,n0s, & + psacr, mgncol) + + integer, intent(in) :: mgncol + + ! In-cloud MMRs + real(r8), dimension(mgncol), intent(in) :: qsic ! snow + real(r8), dimension(mgncol), intent(in) :: qric ! rain + + ! mass-weighted fall speeds + real(r8), dimension(mgncol), intent(in) :: umr ! rain + real(r8), dimension(mgncol), intent(in) :: ums ! snow + + real(r8), dimension(mgncol), intent(in) :: rho ! air density + + + ! Size parameters for rain + real(r8), dimension(mgncol), intent(in) :: lamr + real(r8), dimension(mgncol), intent(in) :: n0r + + ! Size parameters for snow + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + real(r8), dimension(mgncol), intent(out) :: psacr ! conversion due to coll of snow by rain + + real(r8) :: cons31, tx1, tx2, tx3, tx4, tx5 + integer :: i + + cons31 = pi*pi*ecr*rhosn + + do i=1,mgncol + + if (qsic(i) >= 0.1e-3_r8 .and. qric(i) >= 0.1e-3_r8) then + tx1 = 1.2_r8*umr(i) - 0.95_r8*ums(i) + tx1 = sqrt(tx1*tx1+0.08_r8*ums(i)*umr(i)) + tx2 = one / lams(i) + tx3 = one / lamr(i) + tx4 = tx2 * tx2 + tx5 = tx4 * tx4 * tx3 + + psacr(i) = cons31 * tx1 * rho(i) * n0r(i) * n0s(i) * tx5 & + * (5.0*tx4+tx3*(tx2+tx2+0.5*tx3)) + +! psacr(i) = cons31*(((1.2_r8*umr(i)-0.95_r8*ums(i))**2+ & +! 0.08_r8*ums(i)*umr(i))**0.5_r8*rho(i)* & +! n0r(i)*n0s(i)/lams(i)**3* & +! (5._r8/(lams(i)**3*lamr(i))+ & +! 2._r8/(lams(i)**2*lamr(i)**2)+ & +! 0.5_r8/(lams(i)*lamr(i)**3))) + else + psacr(i) = zero + end if + + end do + +end subroutine graupel_collecting_snow + +!======================================================================== +! Collection of cloud water by graupel +!======================================================================== + +subroutine graupel_collecting_cld_water(qgic,qcic,ncic,rho,n0g,lamg,bg,agn, & + psacwg, npsacwg, mgncol) + + integer, intent(in) :: mgncol + + ! In-cloud MMRs + real(r8), dimension(mgncol), intent(in) :: qgic ! graupel + real(r8), dimension(mgncol), intent(in) :: qcic ! cloud water + + real(r8), dimension(mgncol), intent(in) :: ncic ! cloud water number conc + + real(r8), dimension(mgncol), intent(in) :: rho ! air density + + ! Size parameters for graupel + real(r8), dimension(mgncol), intent(in) :: lamg + real(r8), dimension(mgncol), intent(in) :: n0g + + ! fallspeed parameters for graupel + ! Set AGN and BG as input (in micro_mg3_0.F90) (select hail or graupel as appropriate) + real(r8), intent(in) :: bg + real(r8), dimension(mgncol), intent(in) :: agn + + ! Output tendencies + real(r8), dimension(mgncol), intent(out) :: psacwg + real(r8), dimension(mgncol), intent(out) :: npsacwg + + real(r8) :: cons, tx1 + integer :: i + + cons = gamma(bg + 3._r8)*pi/4._r8 * ecid + + do i=1,mgncol + + if (qgic(i) >= 1.e-8 .and. qcic(i) >= qsmall) then + + tx1 = cons*agn(i)*rho(i)*n0g(i) / lamg(i)**(bg+3.) + + psacwg(i) = tx1 * qcic(i) + npsacwg(i) = tx1 * ncic(i) + else + psacwg(i) = 0._r8 + npsacwg(i) = 0._r8 + end if + enddo +end subroutine graupel_collecting_cld_water + +!======================================================================== +! Conversion of rimed cloud water onto snow to graupel/hail +!======================================================================== + +subroutine graupel_riming_liquid_snow(psacws,qsic,qcic,nsic,rho,rhosn,rhog,asn,lams,n0s,dtime, & + pgsacw,nscng,mgncol) + + integer, intent(in) :: mgncol + + ! Accretion of cloud water to snow tendency (modified) + real(r8), dimension(mgncol), intent(inout) :: psacws + + real(r8), dimension(mgncol), intent(in) :: qsic ! snow mixing ratio + real(r8), dimension(mgncol), intent(in) :: qcic ! cloud liquid mixing ratio + real(r8), dimension(mgncol), intent(in) :: nsic ! snow number concentration + + real(r8), dimension(mgncol), intent(in) :: rho ! air density + real(r8), intent(in) :: rhosn ! snow density + real(r8), intent(in) :: rhog ! graupel density + + real(r8), dimension(mgncol), intent(in) :: asn ! fall speed parameter for snow + + ! Size parameters for snow + real(r8), dimension(mgncol), intent(in) :: lams + real(r8), dimension(mgncol), intent(in) :: n0s + + real(r8), intent(in) :: dtime + + !Output process rates + real(r8), dimension(mgncol), intent(out) :: pgsacw ! dQ graupel due to collection droplets by snow + real(r8), dimension(mgncol), intent(out) :: nscng ! dN graupel due to collection droplets by snow + + real(r8) :: cons + real(r8) :: rhosu + real(r8) :: dum + integer :: i + +!........................................................................ +!Input: PSACWS,qs,qc,n0s,rho,lams,rhos,rhog +!Output:PSACWS,PGSACW,NSCNG + + rhosu = 85000._r8/(ra * tmelt) ! typical air density at 850 mb + + do i=1,mgncol + + cons=4._r8 *2._r8 *3._r8 *rhosu*pi*ecid*ecid*gamma_2bs_plus2/(8._r8*(rhog-rhosn)) + + if (psacws(i).gt.0._r8 .and. qsic(i).GE.0.1e-3_r8 .AND. qcic(i).GE.0.5E-3_r8) then +! Only allow conversion if qni > 0.1 and qc > 0.5 g/kg following Rutledge and Hobbs (1984) + !if (qsic(i).GE.0.1e-3_r8 .AND. qcic(i).GE.0.5E-3_r8) then + +! portion of riming converted to graupel (Reisner et al. 1998, originally IS1991) +! dtime here is correct. + pgsacw(i) = min(psacws(i), cons*dtime*n0s(i)*qcic(i)*qcic(i)* & + asn(i)*asn(i)/ (rho(i)*lams(i)**(bs+bs+two))) + +! if (pgsacw(i).lt.0_r8) then +! write(iulog,*) "pgsacw,i,lams,cons",i,pgsacw(i),lams(i),cons +! end if + +! Mix rat converted into graupel as embryo (Reisner et al. 1998, orig M1990) + dum= max(rhosn/(rhog-rhosn)*pgsacw(i), zero) + +! Number concentraiton of embryo graupel from riming of snow + nscng(i) = dum/mg0*rho(i) +! Limit max number converted to snow number (dtime here correct? We think yes) + nscng(i) = min(nscng(i),nsic(i)/dtime) + +! Portion of riming left for snow + psacws(i) = psacws(i) - pgsacw(i) + else + pgsacw(i) = zero + nscng(i) = zero + end if + + enddo + +end subroutine graupel_riming_liquid_snow + +!======================================================================== +!CHANGE IN Q,N COLLECTION RAIN BY GRAUPEL +!======================================================================== + +subroutine graupel_collecting_rain(qric,qgic,umg,umr,ung,unr,rho,n0r,lamr,n0g,lamg,& + pracg,npracg,mgncol) + + integer, intent(in) :: mgncol + + !MMR + real(r8), dimension(mgncol), intent(in) :: qric !rain mixing ratio + real(r8), dimension(mgncol), intent(in) :: qgic !graupel mixing ratio + + !Mass weighted Fall speeds + real(r8), dimension(mgncol), intent(in) :: umg ! graupel fall speed + real(r8), dimension(mgncol), intent(in) :: umr ! rain fall speed + + !Number weighted fall speeds + real(r8), dimension(mgncol), intent(in) :: ung ! graupel fall speed + real(r8), dimension(mgncol), intent(in) :: unr ! rain fall speed + + real(r8), dimension(mgncol), intent(in) :: rho ! air density + + ! Size parameters for rain + real(r8), dimension(mgncol), intent(in) :: n0r + real(r8), dimension(mgncol), intent(in) :: lamr + + ! Size parameters for graupel + real(r8), dimension(mgncol), intent(in) :: n0g + real(r8), dimension(mgncol), intent(in) :: lamg + + + !Output process rates + real(r8), dimension(mgncol), intent(out) :: pracg ! Q collection rain by graupel + real(r8), dimension(mgncol), intent(out) :: npracg ! N collection rain by graupel + +! Add collection of graupel by rain above freezing +! assume all rain collection by graupel above freezing is shed +! assume shed drops are 1 mm in size + + integer :: i + real(r8) :: cons41 + real(r8) :: cons32 + real(r8) :: dum, tx1, tx2, tx3, tx4, tx5, tx6 + + cons41 = pi*pi*ecr*rhow + cons32 = 0.5*pi*ecr + + do i=1,mgncol + + if (qric(i) >= 1.e-8_r8 .and. qgic(i) >= 1.e-8_r8) then + +! pracg is mixing ratio of rain per sec collected by graupel/hail + tx1 = 1.2_r8*umr(i) - 0.95_r8*umg(i) + tx1 = sqrt(tx1*tx1+0.08_r8*umg(i)*umr(i)) + tx2 = 1.0 / lamr(i) + tx3 = 1.0 / lamg(i) + tx4 = tx2 * tx2 + tx5 = tx4 * tx4 * tx3 + tx6 = rho(i) * n0r(i) * n0g(i) + + + pracg(i) = cons41 * tx1 * tx6 * tx5 * (5.0*tx4+tx3*(tx2+tx2+0.5*tx3)) + + +! pracg(i) = cons41*(((1.2_r8*umr(i)-0.95_r8*umg(i))**2._r8+ & +! 0.08_r8*umg(i)*umr(i))**0.5_r8*rho(i)* & +! n0r(i)*n0g(i)/lamr(i)**3._r8* & +! (5._r8/(lamr(i)**3._r8*lamg(i))+ & +! 2._r8/(lamr(i)**2._r8*lamg(i)**2._r8)+ & +! 0.5_r8/(lamr(i)*lamg(i)**3._r8))) + +! assume 1 mm drops are shed, get number shed per sec + + dum = pracg(i) / 5.2e-7_r8 + + tx1 = unr(i) - ung(i) + tx1 = sqrt(1.7_r8 * tx1 * tx1 + 0.3_r8*unr(i)*ung(i)) + tx4 = tx2 * tx3 + + npracg(i) = cons32 * tx1 * tx6 * tx4 * (tx2*(tx2+tx3)+tx3*tx3) + +! npracg(i) = cons32*rho(i)*(1.7_r8*(unr(i)-ung(i))**2._r8+ & +! 0.3_r8*unr(i)*ung(i))**0.5_r8*n0r(i)*n0g(i)* & +! (1._r8/(lamr(i)**3._r8*lamg(i))+ & +! 1._r8/(lamr(i)**2._r8*lamg(i)**2._r8)+ & +! 1._r8/(lamr(i)*lamg(i)**3._r8)) + +! hm 7/15/13, remove limit so that the number of collected drops can smaller than +! number of shed drops +! NPRACG(K)=MAX(NPRACG(K)-DUM,0.) + npracg(i) = npracg(i) - dum + else + npracg(i) = zero + pracg(i) = zero + end if + + enddo + +end subroutine graupel_collecting_rain + +!======================================================================== +! Rain riming snow to graupel +!======================================================================== +! Conversion of rimed rainwater onto snow converted to graupel + +subroutine graupel_rain_riming_snow(pracs,npracs,psacr,qsic,qric,nric,nsic,n0s, & + lams,n0r,lamr,dtime,pgracs,ngracs,mgncol) + + integer, intent(in) :: mgncol + + ! Accretion of rain by snow + real(r8), dimension(mgncol), intent(inout) :: pracs + real(r8), dimension(mgncol), intent(inout) :: npracs + real(r8), dimension(mgncol), intent(inout) :: psacr ! conversion due to coll of snow by rain + + + real(r8), dimension(mgncol), intent(in) :: qsic !snow mixing ratio + real(r8), dimension(mgncol), intent(in) :: qric !rain mixing ratio + + real(r8), dimension(mgncol), intent(in) :: nric ! rain number concentration + real(r8), dimension(mgncol), intent(in) :: nsic ! snow number concentration + + ! Size parameters for snow + real(r8), dimension(mgncol), intent(in) :: n0s + real(r8), dimension(mgncol), intent(in) :: lams + + ! Size parameters for rain + real(r8), dimension(mgncol), intent(in) :: n0r + real(r8), dimension(mgncol), intent(in) :: lamr + + real(r8), intent(in) :: dtime + + !Output process rates + real(r8), dimension(mgncol), intent(out) :: pgracs ! Q graupel due to collection rain by snow + real(r8), dimension(mgncol), intent(out) :: ngracs ! N graupel due to collection rain by snow + +!Input: PRACS,NPRACS,PSACR,qni,qr,lams,lamr,nr,ns Note: No PSACR in MG2 +!Output:PGRACS,NGRACS,PRACS,PSACR + + integer :: i + real(r8) :: cons18 + real(r8) :: cons19 + real(r8) :: dum,fmult,tx1,tx2 + + cons18 = rhosn*rhosn + cons19 = rhow*rhow + + do i=1,mgncol + + fmult = zero + + if (pracs(i) > zero .and. qsic(i) >= 0.1e-3_r8 .and. qric(i) >= 0.1e-3_r8) then + ! only allow conversion if qs > 0.1 and qr > 0.1 g/kg following rutledge and hobbs (1984) + !if (qsic(i).ge.0.1e-3_r8.and.qric(i).ge.0.1e-3_r8) then + ! portion of collected rainwater converted to graupel (reisner et al. 1998) + tx1 = four / lams(i) + tx2 = four / lamr(i) + tx1 = tx1 * tx1 * tx1 + tx2 = tx2 * tx2 * tx2 + dum = cons18 * tx1 * tx1 + dum = one - max(zero, min(one, dum / (dum + cons19 * tx2 * tx2))) + +! dum = cons18*(4._r8/lams(i))**3*(4._r8/lams(i))**3 & +! /(cons18*(4._r8/lams(i))**3*(4._r8/lams(i))**3+ & +! cons19*(4._r8/lamr(i))**3*(4._r8/lamr(i))**3) +! dum = min(dum,one) +! dum = max(dum, zero) +! +! pgracs(i) = (one-dum) * pracs(i) +! ngracs(i) = (one-dum) * npracs(i) + + pgracs(i) = dum * pracs(i) + ngracs(i) = dum * npracs(i) + ! limit max number converted to min of either rain or snow number concentration + ngracs(i) = min(ngracs(i),nric(i)/dtime) + ngracs(i) = min(ngracs(i),nsic(i)/dtime) + + ! amount left for snow production + pracs(i) = pracs(i) - pgracs(i) + npracs(i) = npracs(i) - ngracs(i) + + ! conversion to graupel due to collection of snow by rain +! psacr(i) = psacr(i) * (one-dum) + psacr(i) = psacr(i) * dum + else + pgracs(i) = zero + ngracs(i) = zero + end if + enddo + +end subroutine graupel_rain_riming_snow + +!======================================================================== +! Rime Splintering +!======================================================================== +subroutine graupel_rime_splintering(t,qcic,qric,qgic,psacwg,pracg,& + qmultg,nmultg,qmultrg,nmultrg,mgncol) + + integer, intent(in) :: mgncol + + real(r8), dimension(mgncol), intent(in) :: t !temperature + + !MMR + real(r8), dimension(mgncol), intent(in) :: qcic !liquid mixing ratio + real(r8), dimension(mgncol), intent(in) :: qric !rain mixing ratio + real(r8), dimension(mgncol), intent(in) :: qgic !graupel mixing ratio + + ! Already calculated terms for collection + real(r8), dimension(mgncol), intent(inout) :: psacwg ! collection droplets by graupel + real(r8), dimension(mgncol), intent(inout) :: pracg ! collection rain by graupel + + !Output process rates for splintering + real(r8), dimension(mgncol), intent(out) :: qmultg ! Q ice mult of droplets/graupel + real(r8), dimension(mgncol), intent(out) :: nmultg ! N ice mult of droplets/graupel + real(r8), dimension(mgncol), intent(out) :: qmultrg ! Q ice mult of rain/graupel + real(r8), dimension(mgncol), intent(out) :: nmultrg ! N ice mult of rain/graupel + + +!Input: qg,qc,qr, PSACWG,PRACG,T +!Output: NMULTG,QMULTG,NMULTRG,QMULTRG,PSACWG,PRACG + + integer :: i + real(r8) :: fmult + real(r8) :: tm_3,tm_5,tm_8 + + tm_3 = tmelt - 3._r8 + tm_5 = tmelt - 5._r8 + tm_8 = tmelt - 8._r8 + + +!nmultg,qmultg . +!======================================================================== + do i=1,mgncol + + nmultrg(i) = zero + qmultrg(i) = zero + nmultg(i) = zero + qmultg(i) = zero + + if (qgic(i) >= 0.1e-3_r8) then + if (qcic(i) >= 0.5e-3_r8 .or. qric(i) >= 0.1e-3_r8) then + if (psacwg(i) > zero .or. pracg(i) > zero) then + if (t(i) < tm_3 .and. t(i) > tm_8) then + if (t(i) > tm_3) then + fmult = zero + else if (t(i) <= tm_3 .and. t(i) > tm_5) then + fmult = (tm_3-t(i)) * 0.5 + else if (t(i) >= tm_8 .and. t(i) <= tm_5) then + fmult = (t(i)-tm_8) * (one/three) + else if (t(i) < tm_8) then + fmult = zero + end if + +! 1000 is to convert from kg to g (Check if needed for MG) + +! splintering from droplets accreted onto graupel + + if (psacwg(i) > zero) then + nmultg(i) = 35.e4_r8*psacwg(i)*fmult*1000._r8 + qmultg(i) = nmultg(i)*mmult + +! constrain so that transfer of mass from graupel to ice cannot be more mass +! than was rimed onto graupel + + qmultg(i) = min(qmultg(i),psacwg(i)) + psacwg(i) = psacwg(i) - qmultg(i) + + end if + + +!nmultrg,qmultrg . +!======================================================================== + +! riming and splintering from accreted raindrops + +! Factor of 1000. again (Check) + + if (pracg(i) > zero) then + nmultrg(i) = 35.e4*pracg(i)*fmult*1000._r8 + qmultrg(i) = nmultrg(i)*mmult + +! constrain so that transfer of mass from graupel to ice cannot be more mass +! than was rimed onto graupel + + qmultrg(i) = min(qmultrg(i),pracg(i)) + pracg(i) = pracg(i) - qmultrg(i) + + end if + + end if + end if + end if + end if + enddo + +end subroutine graupel_rime_splintering + +!======================================================================== +! Evaporation and sublimation of graupel +!======================================================================== + +!MERGE WITH RAIN AND SNOW EVAP +! +!subroutine graupel_sublimate_evap(t,q,qgic,rho,n0g,lamg,qvi,dv,mu,sc,bg,agn,& +! prdg,eprdg,mgncol) +! +! integer, intent(in) :: mgncol +! +! real(r8), dimension(mgncol), intent(in) :: t !temperature +! real(r8), dimension(mgncol), intent(in) :: q !specific humidity (mixing ratio) +! +! !MMR +! real(r8), dimension(mgncol), intent(in) :: qgic !graupel mixing ratio +! +! real(r8), dimension(mgncol), intent(in) :: rho ! air density +! +! ! Size parameters for graupel +! real(r8), dimension(mgncol), intent(in) :: n0g +! real(r8), dimension(mgncol), intent(in) :: lamg +! +! real(r8), dimension(mgncol), intent(in) :: qvi !saturation humidity (ice) +! +! 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 +! +! ! fallspeed parameters for graupel +! ! Set AGN and BG as input (in micro_mg3_0.F90) (select hail or graupel as appropriate) +! real(r8), intent(in) :: bg +! real(r8), dimension(mgncol), intent(in) :: agn +! +! ! Output tendencies (sublimation or evaporation of graupel) +! real(r8), dimension(mgncol), intent(out) :: prdg +! real(r8), dimension(mgncol), intent(out) :: eprdg +! +! real(r8) :: cons11,cons36 +! real(r8) :: abi +! real(r8) :: epsg +! integer :: i +! +! cons11=gamma(2.5_r8+bg/2._r8) !bg will be different for graupel (bg) or hail (bh) +! cons36=(2.5_r8+bg/2._r8) +! +! +! do i=1,mgncol +! +! abi = calc_ab(t(i), qvi(i), xxls) +! +! if (qgic(i).ge.qsmall) then +! epsg = 2._r8*pi*n0g(i)*rho(i)*dv(i)* & +! (f1s/(lamg(i)*lamg(i))+ & +! f2s*(agn(i)*rho(i)/mu(i))**0.5_r8* & +! sc(i)**(1._r8/3._r8)*cons11/ & +! (lamg(i)**cons36)) +! else +! epsg = 0. +! end if +! +!! vapor dpeosition on graupel +! prdg(i) = epsg*(q(i)-qvi(i))/abi +! +!! make sure not pushed into ice supersat/subsat +!! put this in main mg3 code…..check for it… +!! formula from reisner 2 scheme + +!! +!! dum = (qv3d(k)-qvi(k))/dt +!! +!! fudgef = 0.9999 +!! sum_dep = prd(k)+prds(k)+mnuccd(k)+prdg(k) +!! +!! if( (dum.gt.0. .and. sum_dep.gt.dum*fudgef) .or. & +!! (dum.lt.0. .and. sum_dep.lt.dum*fudgef) ) then +!! prdg(k) = fudgef*prdg(k)*dum/sum_dep +!! endif +! +!! if cloud ice/snow/graupel vap deposition is neg, then assign to sublimation processes +! +! eprdg(i)=0._r8 +! +! if (prdg(i).lt.0._r8) then +! eprdg(i)=prdg(i) +! prdg(i)=0. +! end if +! +! enddo +! +!end subroutine graupel_sublimate_evap + +!======================================================================== +!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/physics/module_mp_thompson_hrrr.F90 b/physics/module_mp_thompson_hrrr.F90 index 416e77d54..80b65c639 100644 --- a/physics/module_mp_thompson_hrrr.F90 +++ b/physics/module_mp_thompson_hrrr.F90 @@ -1598,12 +1598,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg LOGICAL:: debug_flag INTEGER:: nu_c - ! DH* +#ifdef DEBUG_AEROSOLS INTEGER :: mpirank, ierr LOGICAL :: abort = .false. call MPI_COMM_RANK(MPI_COMM_WORLD,mpirank,ierr) - ! *DH +#endif !+---+ @@ -3506,7 +3506,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (rr(kts).gt.R1*1000.) & pptrain = pptrain + sed_r(kts)*DT*onstep(1) - ! DH* +#ifdef DEBUG_AEROSOLS if (pptrain.ge.1E5) then write(0,*) mpirank, " ::: DH DEBUG THOMPSON: pptrain, nstep, n, kts, DT, sed_r(kts), onstep(1), rr(kts)", & & pptrain, nstep, n, kts, DT, sed_r(kts), onstep(1), rr(kts) @@ -3514,7 +3514,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (sed_r(kts)*DT*onstep(1).ge.1E3) then abort = .true. end if - ! *DH +#endif enddo endif @@ -3566,7 +3566,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (ri(kts).gt.R1*1000.) & pptice = pptice + sed_i(kts)*DT*onstep(2) - ! DH* +#ifdef DEBUG_AEROSOLS if (pptice.ge.1E5) then write(0,*) mpirank, " ::: DH DEBUG THOMPSON: pptice, nstep, n, kts, DT, sed_i(kts), onstep(2), ri(kts)", & & pptice, nstep, n, kts, DT, sed_i(kts), onstep(2), ri(kts) @@ -3574,7 +3574,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (sed_i(kts)*DT*onstep(2).ge.1E3) then abort = .true. end if - ! *DH +#endif enddo endif @@ -3602,7 +3602,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (rs(kts).gt.R1*1000.) & pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) - ! DH* +#ifdef DEBUG_AEROSOLS if (pptsnow.ge.1E5) then write(0,*) mpirank, " ::: DH DEBUG THOMPSON: pptsnow, nstep, n, kts, DT, sed_s(kts), onstep(3), rs(kts)", & & pptsnow, nstep, n, kts, DT, sed_s(kts), onstep(3), rs(kts) @@ -3610,7 +3610,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (sed_s(kts)*DT*onstep(3).ge.1E3) then abort = .true. end if - ! *DH +#endif enddo endif @@ -3638,7 +3638,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (rg(kts).gt.R1*1000.) & pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) - ! DH* +#ifdef DEBUG_AEROSOLS if (pptgraul.ge.1E5) then write(0,*) mpirank, " ::: DH DEBUG THOMPSON: pptgraul, nstep, n, kts, DT, sed_g(kts), onstep(4), rg(kts)", & & pptgraul, nstep, n, kts, DT, sed_g(kts), onstep(4), rg(kts) @@ -3646,7 +3646,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (sed_g(kts)*DT*onstep(4).ge.1E5) then abort = .true. end if - ! *DH +#endif enddo endif @@ -3752,14 +3752,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (qg1d(k) .le. R1) qg1d(k) = 0.0 enddo - ! DH* +#ifdef DEBUG_AEROSOLS if (abort) then write(0,*) "DH DEBUG: abort for debugging (inside mp_thompson)" call sleep(1) call MPI_BARRIER(MPI_COMM_WORLD, ierr) stop end if - ! *DH +#endif end subroutine mp_thompson !+---+-----------------------------------------------------------------+