diff --git a/.github/PULL_REQUEST_TEMPLATE/pull_request_template.md b/.github/pull_request_template.md similarity index 76% rename from .github/PULL_REQUEST_TEMPLATE/pull_request_template.md rename to .github/pull_request_template.md index 5968702e5..9f33913cd 100644 --- a/.github/PULL_REQUEST_TEMPLATE/pull_request_template.md +++ b/.github/pull_request_template.md @@ -1,22 +1,21 @@ -## Description of Changes: +## Description of Changes: One or more paragraphs describing the problem, solution, and required changes. -## Tests Conducted: -Explicitly state what tests were run on these changes, or if any are still pending (for README or other text-only changes, just put "None required". Make note of the compilers used, the platform/machine, and other relevant details as necessary. For more complicated changes, or those resulting in scientific changes, please be explicit! -**OR** Add any links to tests conducted. For example, "See ufs-community/ufs-weather-model/pull/" +## Tests Conducted: +Explicitly state what tests were run on these changes, or if any are still pending (for README or other text-only changes, just put "None required". Make note of the compilers used, the platform/machine, and other relevant details as necessary. For more complicated changes, or those resulting in scientific changes, please be explicit! +**OR** Add any links to tests conducted. For example, "See ufs-community/ufs-weather-model#" ## Dependencies: Add any links to parent PRs (e.g. SCM and/or UFS PRs) or submodules (e.g. rte-rrtmgp). For example: -- NCAR/ccpp-framework/pull/ -- NOAA-EMC/fv3atm/pull/ -- ufs-community/ufs-weather-model/pull/ +- NCAR/ccpp-framework# +- NOAA-EMC/fv3atm# +- ufs-community/ufs-weather-model/# ## Documentation: Does this PR add new capabilities that need to be documented or require modifications to the existing documentation? If so, brief supporting material can be provided here. Contact the CODEOWNERS if your PR requires extensive updates to the documentation. See https://github.com/NCAR/ccpp-doc for Technical Documentation or https://dtcenter.org/community-code/common-community-physics-package-ccpp/documentation for the latest Scientific Documentation. -## Issue (optional): -If this PR is resolving or referencing one or more issues, in this repository or elewhere, list them here. For example, "Fixes issue mentioned in #123" or "Related to bug in https://github.com/NCAR/other_repository/pull/63" +## Issue (optional): +If this PR is resolving or referencing one or more issues, in this repository or elewhere, list them here. For example, "Fixes issue mentioned in #123" or "Related to bug in NCAR/other_repository#123" -## Contributors (optional): +## Contributors (optional): If others have contributed to this work aside from the PR author, list them here - diff --git a/.github/workflows/basic_checks.yml b/.github/workflows/basic_checks.yml index 4e40790b5..7730b423d 100644 --- a/.github/workflows/basic_checks.yml +++ b/.github/workflows/basic_checks.yml @@ -4,6 +4,7 @@ on: [push, pull_request] jobs: build: + if: github.repository == 'NCAR/ccpp-physics' || github.repository == 'ufs-community/ccpp-physics' runs-on: macos-latest diff --git a/.github/workflows/ci_fv3_ccpp_prebuild.yml b/.github/workflows/ci_fv3_ccpp_prebuild.yml index a5c2f8092..5d87f7d50 100644 --- a/.github/workflows/ci_fv3_ccpp_prebuild.yml +++ b/.github/workflows/ci_fv3_ccpp_prebuild.yml @@ -4,9 +4,10 @@ on: [push, pull_request] jobs: ccpp-prebuild-FV3: + if: github.repository == 'NCAR/ccpp-physics' || github.repository == 'ufs-community/ccpp-physics' # The type of runner that the job will run on - runs-on: ubuntu-20.04 + runs-on: ubuntu-latest steps: - name: Checkout current ccpp-physics code @@ -38,11 +39,11 @@ jobs: git remote add remote_local $GIT_REMOTE_URL git fetch remote_local $GIT_REMOTE_BRANCH git checkout remote_local/$GIT_REMOTE_BRANCH - - - name: Set up Python 3.8.5 + + - name: Set up Python 3.10.13 uses: actions/setup-python@v3 with: - python-version: 3.8.5 + python-version: 3.10.13 - name: Add conda to system path run: | @@ -53,4 +54,4 @@ jobs: run: | cd /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/ccpp/ mkdir -p /home/runner/work/ccpp-physics/ccpp-physics/fv3atm/bin/ccpp/physics/physics/ - ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py \ No newline at end of file + ./framework/scripts/ccpp_prebuild.py --config config/ccpp_prebuild_config.py diff --git a/.github/workflows/ci_scm_ccpp_prebuild.yml b/.github/workflows/ci_scm_ccpp_prebuild.yml index 7c9d2300a..d50dafcef 100644 --- a/.github/workflows/ci_scm_ccpp_prebuild.yml +++ b/.github/workflows/ci_scm_ccpp_prebuild.yml @@ -4,9 +4,10 @@ on: [push, pull_request] jobs: ccpp-prebuild-SCM: + if: github.repository == 'NCAR/ccpp-physics' || github.repository == 'ufs-community/ccpp-physics' # The type of runner that the job will run on - runs-on: ubuntu-20.04 + runs-on: ubuntu-latest steps: @@ -42,11 +43,11 @@ jobs: git remote add remote_local $GIT_REMOTE_URL git fetch remote_local $GIT_REMOTE_BRANCH git checkout remote_local/$GIT_REMOTE_BRANCH - - - name: Set up Python 3.8.5 + + - name: Set up Python 3.10.13 uses: actions/setup-python@v3 with: - python-version: 3.8.5 + python-version: 3.10.13 - name: Add conda to system path run: | @@ -58,4 +59,4 @@ jobs: cd /home/runner/work/ccpp-physics/ccpp-physics/ccpp-scm/ git status mkdir -p /home/runner/work/ccpp-physics/ccpp-physics/ccpp-scm/scm/bin/ccpp/physics/physics/ - ./ccpp/framework/scripts/ccpp_prebuild.py --config ccpp/config/ccpp_prebuild_config.py \ No newline at end of file + ./ccpp/framework/scripts/ccpp_prebuild.py --config ccpp/config/ccpp_prebuild_config.py diff --git a/.gitmodules b/.gitmodules index b2d51bdfe..cc173dc23 100644 --- a/.gitmodules +++ b/.gitmodules @@ -2,3 +2,7 @@ path = physics/Radiation/RRTMGP/rte-rrtmgp url = https://github.com/earth-system-radiation/rte-rrtmgp branch = main +[submodule "physics/MP/TEMPO/TEMPO"] + path = physics/MP/TEMPO/TEMPO + url = https://github.com/NCAR/TEMPO + branch = main diff --git a/CMakeLists.txt b/CMakeLists.txt index db7fae815..3d2a2971e 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -196,7 +196,12 @@ target_include_directories(ccpp_physics PUBLIC target_link_libraries(ccpp_physics PRIVATE MPI::MPI_Fortran) target_link_libraries(ccpp_physics PUBLIC w3emc::w3emc_d sp::sp_d - NetCDF::NetCDF_Fortran) + NetCDF::NetCDF_Fortran + ) +#add FMS for FV3 only +if(FV3) + target_link_libraries(ccpp_physics PUBLIC fms) +endif() # Define where to install the library install(TARGETS ccpp_physics diff --git a/CODEOWNERS b/CODEOWNERS index d2417dae7..2e6e555ef 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -36,9 +36,10 @@ physics/GWD/ugwpv1_gsldrag_post.* @md physics/GWD/unified_ugwp* @mdtoyNOAA @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/MP/Ferrier_Aligo/module_MP_FER_HIRES.* @ericaligo-NOAA @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/MP/Ferrier_Aligo/mp_fer_hires.* @ericaligo-NOAA @grantfirl @rhaesung @Qingfu-Liu @dustinswales -physics/MP/GFDL/GFDL_parse_tracers.F90 @grantfirl @rhaesung @Qingfu-Liu @dustinswales -physics/MP/GFDL/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @rhaesung @Qingfu-Liu @dustinswales -physics/MP/GFDL/module_gfdl_cloud_microphys.* @RuiyuSun @grantfirl @rhaesung @Qingfu-Liu @dustinswales +physics/MP/GFDL/v1_2019/gfdl_cloud_microphys.* @RuiyuSun @grantfirl @rhaesung @Qingfu-Liu @dustinswales +physics/MP/GFDL/v1_2019/gfdl_cloud_microphys_mod.* @RuiyuSun @grantfirl @rhaesung @Qingfu-Liu @dustinswales +physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.* @RuiyuSun @grantfirl @rhaesung @Qingfu-Liu @dustinswales +physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3_mod.* @RuiyuSun @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/MP/GFDL/fv_sat_adj.* @RuiyuSun @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/MP/GFDL/multi_gases.F90 @RuiyuSun @grantfirl @rhaesung @Qingfu-Liu @dustinswales physics/MP/Morrison_Gettelman/aer_cloud.F @AnningCheng-NOAA @andrewgettelman @grantfirl @rhaesung @Qingfu-Liu @dustinswales diff --git a/physics/CONV/C3/cu_c3_driver.F90 b/physics/CONV/C3/cu_c3_driver.F90 index 0ea8be075..c7e1c1f8c 100644 --- a/physics/CONV/C3/cu_c3_driver.F90 +++ b/physics/CONV/C3/cu_c3_driver.F90 @@ -657,7 +657,9 @@ subroutine cu_c3_driver_run(ntracer,garea,im,km,dt,flag_init,flag_restart,& enddo do i = its,itf if(mconv(i).lt.0.)mconv(i)=0. - if((dx(i)<6500.).and.do_mynnedmf.and.(maxMF(i).gt.0.))ierr(i)=555 + if(do_mynnedmf) then + if((dx(i)<6500.).and.(maxMF(i).gt.0.))ierr(i)=555 + endif enddo !$acc end kernels if (dx(its)<6500.) then diff --git a/physics/CONV/Grell_Freitas/cu_gf_deep.F90 b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 index 74da8d2de..2fd963d57 100644 --- a/physics/CONV/Grell_Freitas/cu_gf_deep.F90 +++ b/physics/CONV/Grell_Freitas/cu_gf_deep.F90 @@ -5496,7 +5496,7 @@ subroutine get_partition_liq_ice(ierr,tn,po_cup, p_liq_ice,melting_layer ,itf,ktf,its,ite, kts,kte, cumulus ) implicit none character *(*), intent (in) :: cumulus - integer ,intent (in ) :: itf,ktf, its,ite, kts,kte + integer ,intent (in ) :: itf,ktf, its,ite, kts,kte real(kind=kind_phys), intent (in ), dimension(its:ite,kts:kte) :: tn,po_cup real(kind=kind_phys), intent (inout), dimension(its:ite,kts:kte) :: p_liq_ice,melting_layer !$acc declare copyin(tn,po_cup) copy(p_liq_ice,melting_layer) diff --git a/physics/CONV/SAMF/samfdeepcnv.f b/physics/CONV/SAMF/samfdeepcnv.f index b9f0ea8bc..b4fe70027 100644 --- a/physics/CONV/SAMF/samfdeepcnv.f +++ b/physics/CONV/SAMF/samfdeepcnv.f @@ -2537,10 +2537,10 @@ subroutine samfdeepcnv_run (im,km,first_time_step,restart, & c c------- final changed variable per unit mass flux c -!> - If grid size is less than a threshold value (dxcrtas: currently 8km if progsigma is not used and 30km if progsigma is used), the quasi-equilibrium assumption of Arakawa-Schubert is not used any longer. +!> - If grid size is less than a threshold value (dxcrtas: currently 8km if progsigma is not used), or progsigma = true, the quasi-equilibrium assumption of Arakawa-Schubert is not used any longer. ! if(progsigma)then - dxcrtas=30.e3 + dxcrtas=500.e3 dxcrtuf=10.e3 else dxcrtas=8.e3 diff --git a/physics/CONV/SAMF/samfdeepcnv.meta b/physics/CONV/SAMF/samfdeepcnv.meta index 7c208d2d3..e6f44bc7b 100644 --- a/physics/CONV/SAMF/samfdeepcnv.meta +++ b/physics/CONV/SAMF/samfdeepcnv.meta @@ -472,7 +472,7 @@ [omegain] standard_name = prognostic_updraft_velocity_in_convection long_name = convective updraft velocity - units = frac + units = Pa s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys @@ -481,7 +481,7 @@ [omegaout] standard_name = updraft_velocity_updated_by_physics long_name = convective updraft velocity updated by physics - units = frac + units = Pa s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys diff --git a/physics/CONV/SAMF/samfshalcnv.f b/physics/CONV/SAMF/samfshalcnv.f index 0746d085e..ee7f6a76e 100644 --- a/physics/CONV/SAMF/samfshalcnv.f +++ b/physics/CONV/SAMF/samfshalcnv.f @@ -204,7 +204,7 @@ subroutine samfshalcnv_run(im,km,itc,ntc,cliq,cp,cvap, & parameter(betaw=.03,dxcrtc0=9.e3) parameter(h1=0.33333333) ! progsigma - parameter(dxcrtas=30.e3,sigmind=0.01,sigmins=0.03,sigminm=0.01) + parameter(dxcrtas=500.e3,sigmind=0.01,sigmins=0.03,sigminm=0.01) c local variables and arrays real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), & uo(im,km), vo(im,km), qeso(im,km), diff --git a/physics/CONV/SAMF/samfshalcnv.meta b/physics/CONV/SAMF/samfshalcnv.meta index d6fb7960d..c1714801d 100644 --- a/physics/CONV/SAMF/samfshalcnv.meta +++ b/physics/CONV/SAMF/samfshalcnv.meta @@ -504,7 +504,7 @@ [omegain] standard_name = prognostic_updraft_velocity_in_convection long_name = convective updraft velocity - units = frac + units = Pa s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys @@ -513,7 +513,7 @@ [omegaout] standard_name = updraft_velocity_updated_by_physics long_name = convective updraft velocity updated by physics - units = frac + units = Pa s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys diff --git a/physics/GWD/cires_tauamf_data.F90 b/physics/GWD/cires_tauamf_data.F90 index 364c79409..323cea9a8 100644 --- a/physics/GWD/cires_tauamf_data.F90 +++ b/physics/GWD/cires_tauamf_data.F90 @@ -36,7 +36,7 @@ subroutine read_tau_amf(me, master, errmsg, errflg) if(iernc.ne.0) then write(errmsg,'(*(a))') "read_tau_amf: cannot open file_limb_tab data-file ", & trim(ugwp_taufile) - print *, 'cannot open ugwp-v1 tau-file=',trim(ugwp_taufile) + print *, 'cannot open ugwp-v1 tau-file=',trim(ugwp_taufile) errflg = 1 return else @@ -51,26 +51,26 @@ subroutine read_tau_amf(me, master, errmsg, errflg) status = nf90_inquire_dimension(ncid, DimID, len =ntau_d2t ) if (me == master) print *, ntau_d1y, ntau_d2t, ' dimd of tau_ngw ugwp-v1 ' - if (ntau_d2t .le. 0 .or. ntau_d1y .le. 0) then - print *, 'ugwp-v1 tau-file=', trim(ugwp_taufile) - print *, ' ugwp-v1: ', 'ntau_d2t=',ntau_d2t, 'ntau_d2t=',ntau_d1y - stop - endif + if (ntau_d2t .le. 0 .or. ntau_d1y .le. 0) then + print *, 'ugwp-v1 tau-file=', trim(ugwp_taufile) + print *, ' ugwp-v1: ', 'ntau_d2t=',ntau_d2t, 'ntau_d2t=',ntau_d1y + stop + endif if (.not.allocated(ugwp_taulat)) allocate (ugwp_taulat(ntau_d1y )) if (.not.allocated(days_limb)) allocate (days_limb(ntau_d2t)) - if (.not.allocated(tau_limb)) allocate (tau_limb(ntau_d1y, ntau_d2t )) + if (.not.allocated(tau_limb)) allocate (tau_limb(ntau_d1y, ntau_d2t )) - iernc=nf90_inq_varid( ncid, 'DAYS', vid ) + iernc=nf90_inq_varid( ncid, 'DAYS', vid ) iernc= nf90_get_var( ncid, vid, days_limb) - iernc=nf90_inq_varid( ncid, 'LATS', vid ) + iernc=nf90_inq_varid( ncid, 'LATS', vid ) iernc= nf90_get_var( ncid, vid, ugwp_taulat) - iernc=nf90_inq_varid( ncid, 'ABSMF', vid ) + iernc=nf90_inq_varid( ncid, 'ABSMF', vid ) iernc= nf90_get_var( ncid, vid, tau_limb) - iernc=nf90_close(ncid) + iernc=nf90_close(ncid) - endif + endif end subroutine read_tau_amf @@ -102,22 +102,22 @@ subroutine cires_indx_ugwp (npts, me, master, dlat,j1_tau,j2_tau, w1_j1tau, w2_j j2_tau(j) = min(j2_tau(j),ntau_d1y) - j1_tau(j) = max(j2_tau(j)-1,1) + j1_tau(j) = max(j2_tau(j)-1,1) if (j1_tau(j) /= j2_tau(j) ) then w2_j2tau(j) = (dlat(j) - ugwp_taulat(j1_tau(j))) & - / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) + / (ugwp_taulat(j2_tau(j))-ugwp_taulat(j1_tau(j))) else w2_j2tau(j) = 1.0 endif - w1_j1tau(j) = 1.0 - w2_j2tau(j) + w1_j1tau(j) = 1.0 - w2_j2tau(j) enddo return end subroutine cires_indx_ugwp !> subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, ddy_j2, tau_ddd) - use machine, only: kind_phys + use machine, only: kind_phys implicit none !input @@ -141,30 +141,30 @@ subroutine tau_amf_interp(me, master, im, idate, fhour, j1_tau,j2_tau, ddy_j1, d it1 = 2 do iday=1, ntau_d2t - if (fddd .lt. days_limb(iday) ) then - it2 = iday - exit - endif - enddo + if (fddd .lt. days_limb(iday) ) then + it2 = iday + exit + endif + enddo - it2 = min(it2,ntau_d2t) - it1 = max(it2-1,1) - if (it2 > ntau_d2t ) then - print *, ' Error in time-interpolation for tau_amf_interp ' - print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t - print *, ' Error in time-interpolation see cires_tauamf_data.F90 ' - stop - endif + it2 = min(it2,ntau_d2t) + it1 = max(it2-1,1) + if (it2 > ntau_d2t ) then + print *, ' Error in time-interpolation for tau_amf_interp ' + print *, ' it1, it2, ntau_d2t ', it1, it2, ntau_d2t + print *, ' Error in time-interpolation see cires_tauamf_data.F90 ' + stop + endif - w2 = (fddd-days_limb(it1))/(days_limb(it2)-days_limb(it1)) - w1 = 1.0-w2 + w2 = (fddd-days_limb(it1))/(days_limb(it2)-days_limb(it1)) + w1 = 1.0-w2 - do i=1, im - j1 = j1_tau(i) - j2 = j2_tau(i) - tx1 = tau_limb(j1, it1)*ddy_j1(i)+tau_limb(j2, it1)*ddy_j2(i) - tx2 = tau_limb(j1, it2)*ddy_j1(i)+tau_limb(j2, it2)*ddy_j2(i) - tau_ddd(i) = tx1*w1 + w2*tx2 + do i=1, im + j1 = j1_tau(i) + j2 = j2_tau(i) + tx1 = tau_limb(j1, it1)*ddy_j1(i)+tau_limb(j2, it1)*ddy_j2(i) + tx2 = tau_limb(j1, it2)*ddy_j1(i)+tau_limb(j2, it2)*ddy_j2(i) + tau_ddd(i) = tx1*w1 + w2*tx2 enddo end subroutine tau_amf_interp @@ -172,7 +172,7 @@ end subroutine tau_amf_interp !> subroutine gfs_idate_calendar(idate, fhour, ddd, fddd) - use machine, only: kind_phys + use machine, only: kind_phys implicit none ! input integer, intent(in) :: idate(4) diff --git a/physics/GWD/cires_ugwpv1_oro.F90 b/physics/GWD/cires_ugwpv1_oro.F90 index 423a21348..12f9d0d13 100644 --- a/physics/GWD/cires_ugwpv1_oro.F90 +++ b/physics/GWD/cires_ugwpv1_oro.F90 @@ -222,7 +222,8 @@ subroutine orogw_v1 (im, km, imx, me, master, dtp, kdt, do_tofd, & dusfc(i) = 0.0 dvsfc(i) = 0.0 ipt(i) = 0 - enddo + enddo + zlwb(:) = 0.0 ! ---- for lm and gwd calculation points !cires_ugwp_initialize.F90: real, parameter :: hpmax=2400.0, hpmin=25.0 diff --git a/physics/GWD/cires_ugwpv1_triggers.F90 b/physics/GWD/cires_ugwpv1_triggers.F90 index 009d91775..29d66f823 100644 --- a/physics/GWD/cires_ugwpv1_triggers.F90 +++ b/physics/GWD/cires_ugwpv1_triggers.F90 @@ -298,7 +298,7 @@ subroutine get_spectra_tau_okw(nw, im, levs, trig_okw, xlatd, sinlat, coslat, t if (dmax >= tlim_okw) kex = kex+1 do k=klow+1, ktop dtot = abs(trig_okw(i,k)) - if (dtot >= tlim_fgf ) kex = kex+1 + if (dtot >= tlim_okw ) kex = kex+1 if ( dtot > dmax) then klev(i) = k dmax = dtot diff --git a/physics/GWD/ecmwf_ngw.F90 b/physics/GWD/ecmwf_ngw.F90 new file mode 100644 index 000000000..09d5b80cd --- /dev/null +++ b/physics/GWD/ecmwf_ngw.F90 @@ -0,0 +1,956 @@ +!>\file ecmwf_ngw.F90 +!! + +module ecmwf_ngw + + +contains +!------------------------------------------------------------------------------------------ +! April 2025 Adding ECMWF Non-stationary gravity wave scheme option by Bo Yang +!------------------------------------------------------------------------------------------ +! different orientation at vertical +! 1 is the highest level for ECMWF, 1 is the lowest level for GFS +! Vertical levels are reversed after entering the subroutine ecmwf_ngw_emc and reversed back before exiting +! This non-stationary GWD module was obtained by Fanglin Yang from ECMWF, with permission for operational use at NCEP. We would +! like to thank Andy Brown, Michael Sleigh, Peter Bechtold, and Nils Wedi at ECMWF for their support in porting this code to the +! UFS. +!! Original Fortran Code by J. SCINOCCIA +! Rewritten in IFS format by A. ORR E.C.M.W.F. August 2008 +! PURPOSE +! ------- + +! THIS ROUTINE COMPUTES NON-OROGRAPHIC GRAVITY WAVE DRAG +! AFTER SCINOCCA (2003) AND Mc LANDRESS AND SCINOCCIA (JAS 2005) +! HYDROSTATIC NON-ROTATIONAL SIMPLIFIED VERSION OF THE +! WARNER AND MCINTYRE (1996) NON-OROGRAPHIC GRAVITY WAVE PARAMETERIZATION +! CONSTANTS HAVE BEEN OPTIMIZED FOLLOWING M. ERN ET AL. (ATMOS. CHEM. PHYS. 2006) + +! REFERENCE: Orr, A., P. Bechtold, J. Scinoccia, M. Ern, M. Janiskova, 2010: +! Improved middle atmosphere climate and analysis in the ECMWF forecasting system +! through a non-orographic gravity wave parametrization. J. Climate., 23, 5905-5926. + +! LAUNCH SPECTRUM - GENERALIZED DESAUBIES +! INCLUDES A CRITICAL-LEVEL CORRECTION THAT PREVENTS THE +! MOMEMTUM DEPOSITION IN EACH AZIMUTH FROM DRIVING THE FLOW TO SPEEDS FASTER +! THAN THE PHASE SPEED OF THE WAVES, I.E. WHEN WAVES BREAK THEY DRAG THE MEAN +! FLOW TOWARDS THEIR PHASE SPEED - NOT PAST IT. +!!! different orientation for vertical +!!! 1 is the highest level for ECMWF, 1 is the lowest level for GFS +!--------------------------------------------------- +! subroutine cires_ugwpv1_ngw_solv2(mpi_id, master, im, levs, kdt, dtp, & +! tau_ngw, tm , um, vm, qm, prsl, prsi, zmet, zmeti, prslk, & +! xlatd, sinlat, coslat, & +! pdudt, pdvdt, pdtdt, dked, zngw) + +! (C) Copyright 1989- ECMWF. +! +! This software is licensed under the terms of the Apache Licence Version 2.0 +! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +! +! In applying this licence, ECMWF does not waive the privileges and immunities +! granted to it by virtue of its status as an intergovernmental organisation +! nor does it submit to any jurisdiction. + + subroutine ecmwf_ngw_emc(mpi_id, master, KLON, KLEV, kdt, PTSTEP, DX, & + tau_ngw, PTM11, PUM11, PVM11, qm1, PAPM11, PAPHM11, PGEO11, zmeti1, prslk1, & + xlatd, sinlat, coslat, & + PTENU, PTENV, pdtdt, dked, zngw) + + +! + use machine, only : kind_phys + + + use cires_ugwpv1_module,only : psrc => knob_ugwp_palaunch + + use cires_ugwpv1_module,only : maxdudt, maxdtdt, max_eps, dked_min, dked_max +!! maxdudt=250.e-5; maxdtdt=15.e-2; dked_min=0.01; dked_max=250.0 +!! max_eps=max_kdis*4.e-4=450*4.e-4 + + use ugwp_common , only : rgrav, grav, cpd, rd, rv, rcpdl, grav2cpd, & + omega2, rcpd, rcpd2, pi, pi2, fv, & + rad_to_deg, deg_to_rad, & + rdi, gor, grcp, gocp, & + bnv2min, bnv2max, dw2min, velmin, gr2, & + hpscale, rhp, rh4, grav2, rgrav2, mkzmin, mkz2min + +!!! grav=con_g; rgrav=1/grav; cpd=con_cp; rd=con_rd; rv=con_rv; rcpdl=cpd*rgrav=cpd/g +!!!grav2cpd= grav*grcp=grav*grav*rcpd= g**2/cpd omega=con_omega; omega2=2*omega1 +!! rcpd2=0.5*rcpd=1/(2*cpd) +!! pi=con_pi; pi2=2*pi +!! fv=con_fvirt; rad_to_deg=180.0/pi; deg_to_rad=pi2/180.0 +!! rdi= 1.0/rd; gor=grav/rd; grcp= grav*rcpd=g/Cpd; gocp=grcp=grav*rcpd= g/cpd +!! bnv2min=(pi2/1800.)*(pi2/1800.); bnv2max=(pi2/30.)*(pi2/30.) +!! dw2min=1.0, velmin=sqrt(dw2min) +!! gr2=grav*gor=grav*grav/rd=g**2/rd +!! hpscale=7000; rhp = 1./hpscale = 1/7000; rh4=rhp2*rhp2=(0.5*rhp)**2=1/4*1/7000=1/28000 +!! rgrav2=rgrav*rgrav=1/(g**2); grav2=grav+grav=2*g; mkzmin=pi2/80.0e-3=2*pi/80.0e3 +!! mkz2min= mkzmin*mkzmin=(2*pi/80.0E3)**2 + + + use ugwp_wmsdis_init, only : v_kxw, rv_kxw, v_kxw2, tamp_mpa, tau_min, ucrit, & + gw_eff, & +! zms, & + zci4, zci3, zci2, & + rimin, sc2, sc2u, ric +! v_kxw=kxw=pi2/lhmet=pi2/200e3; rv_kxw=200e3/pi2 +! v_kxw2=v_kxw*v_kxw=(pi2/200e3)**2; tamp_mpa=knob_ugwp_tauamp amplitude for GEOS-5/MERRA-2 +! tau_min=min of GW MF 0.25mPa +! ucrit=cdmin=2e-2/mkzmax=2e-2/((2pie)/500) = 10/(2pie) +! gw_eff=effac=1.0 +! zci4=(zms*zci(inc))**4; zci2=(zms*zci(inc))**2; zci3(inc)=(zms*zci(inc))**3 +! rimin=-10.0; sc2=lturb*lturb=30m*30m; sc2u=ulturb*ulturb=150*150 + + + implicit none + +!in +!work + + +! integer, intent(in) :: KLAUNCH ! index for launch level + integer, intent(in) :: KLEV ! vertical level + integer, intent(in) :: KLON ! horiz tiles + integer, intent(in) :: mpi_id, master, kdt + + real(kind=kind_phys) ,intent(in) :: PTSTEP ! model time step + real(kind=kind_phys) ,intent(in) :: DX(KLON) ! model grid size + + real(kind=kind_phys) ,intent(in) :: tau_ngw(KLON) + + real(kind=kind_phys) ,intent(in) :: PVM11(KLON,KLEV) ! meridional wind + real(kind=kind_phys) ,intent(in) :: PUM11(KLON,KLEV) ! zonal wind + real(kind=kind_phys) ,intent(in) :: qm1(KLON,KLEV) ! spec. humidity + real(kind=kind_phys) ,intent(in) :: PTM11(KLON,KLEV) ! kinetic temperature + real(kind=kind_phys) ,intent(in) :: PAPM11(KLON,KLEV) ! mid-layer pressure + real(kind=kind_phys) ,intent(in) :: PAPHM11(KLON,KLEV+1) ! interface pressure + real(kind=kind_phys) ,intent(in) :: PGEO11(KLON,KLEV) ! full model level geopotential in meters + + real(kind=kind_phys) :: PVM1(KLON,KLEV) ! meridional wind + real(kind=kind_phys) :: PUM1(KLON,KLEV) ! zonal wind + real(kind=kind_phys) :: qm(KLON,KLEV) ! spec. humidity + real(kind=kind_phys) :: PTM1(KLON,KLEV) ! kinetic temperature + real(kind=kind_phys) :: PAPM1(KLON,KLEV) ! mid-layer pressure + real(kind=kind_phys) :: PAPHM1(KLON,KLEV+1) ! interface pressure + real(kind=kind_phys) :: PGEO1(KLON,KLEV) ! full model level geopotential in meters + +! real(kind=kind_phys) :: PGAW(KLON) !normalised gaussian quadrature weight/nb of longitude pts + ! local sub-area == 4*RPI*RA**2 * PGAW +! real(kind=kind_phys) ,intent(in) :: PPRECIP(KLON) ! total surface precipitation + + + + + real(kind=kind_phys) ,intent(in) :: prslk1(KLON,KLEV) ! mid-layer exner function + real(kind=kind_phys) :: prslk(KLON,KLEV) ! mid-layer exner function +! real(kind=kind_phys) ,intent(in) :: zmet(KLON,KLEV) ! meters phil =philg/grav ! use PGEO1 instead + + real(kind=kind_phys) ,intent(in) :: zmeti1(KLON,KLEV+1) ! interface geopi/meters + real(kind=kind_phys) :: zmeti(KLON,KLEV+1) ! interface geopi/meters + real(kind=kind_phys) ,intent(in) :: xlatd(KLON) ! xlat_d in degrees + real(kind=kind_phys) ,intent(in) :: sinlat(KLON) + real(kind=kind_phys) ,intent(in) :: coslat(KLON) +! +! out-gw effects +! + real(kind=kind_phys) ,intent(out) :: PTENU(KLON,KLEV) ! zonal momentum tendency + real(kind=kind_phys) ,intent(out) :: PTENV(KLON,KLEV) ! meridional momentum tendency + real(kind=kind_phys) ,intent(out) :: pdtdt(KLON,KLEV) ! gw-heating (u*ax+v*ay)/cp and cooling + + + real(kind=kind_phys) :: PFLUXU(KLON,KLEV+1) ! zonal momentum tendency + real(kind=kind_phys) :: PFLUXV(KLON,KLEV+1) ! meridional momentum tendency + + real(kind=kind_phys) ,intent(out) :: dked(KLON,KLEV) ! gw-eddy diffusion + + real(kind=kind_phys) ,intent(out) :: zngw(KLON) ! launch height +! +!work + INTEGER, PARAMETER :: IAZIDIM=4 !number of azimuths + INTEGER, PARAMETER :: INCDIM=20 !number of discretized c spectral elements in launch spectrum + + REAL(kind=kind_phys), PARAMETER :: RA=6370.e3 !half-model level zonal velocity + REAL(kind=kind_phys), PARAMETER :: GPTWO=2.0 ! 2p in equation + + REAL(kind=kind_phys) :: ZUHM1(KLON,KLEV) !half-model level zonal velocity + REAL(kind=kind_phys) :: ZVHM1(KLON,KLEV) !half-model level meridional velocity + + REAL(kind=kind_phys) :: ZBVFHM1(KLON,KLEV) !half-model level Brunt-Vaisalla frequency + REAL(kind=kind_phys) :: ZRHOHM1(KLON,KLEV) !half-model level density + REAL(kind=kind_phys) :: ZX(INCDIM) !coordinate transformation + REAL(kind=kind_phys) :: ZCI(INCDIM) !phase speed element + REAL(kind=kind_phys) :: ZDCI(INCDIM) + REAL(kind=kind_phys) :: ZUI(KLON,KLEV,IAZIDIM) !intrinsic velocity + REAL(kind=kind_phys) :: ZUL(KLON,IAZIDIM) !velocity in azimuthal direction at launch level + REAL(kind=kind_phys) :: ZBVFL(KLON) !buoyancy at launch level + REAL(kind=kind_phys) :: ZCOSANG(IAZIDIM) !cos of azimuth angle + REAL(kind=kind_phys) :: ZSINANG(IAZIDIM) !sin of azimuth angle + REAL(kind=kind_phys) :: ZFCT(KLON,KLEV) + REAL(kind=kind_phys) :: ZFNORM(KLON) !normalisation factor (A) + REAL(kind=kind_phys) :: ZCI_MIN(KLON,IAZIDIM) + REAL(kind=kind_phys) :: ZTHM1(KLON,KLEV) !temperature on half-model levels + REAL(kind=kind_phys) :: ZFLUX(KLON,INCDIM,IAZIDIM) !momentum flux at each vertical level and azimuth + REAL(kind=kind_phys) :: ZPU(KLON,KLEV,IAZIDIM) !momentum flux + REAL(kind=kind_phys) :: ZDFL(KLON,KLEV,IAZIDIM) + REAL(kind=kind_phys) :: ZACT(KLON,INCDIM,IAZIDIM) !if =1 then critical level encountered + REAL(kind=kind_phys) :: ZACC(KLON,INCDIM,IAZIDIM) + REAL(kind=kind_phys) :: ZCRT(KLON,KLEV,IAZIDIM) + + INTEGER :: ILAUNCH !model level from which GW spectrum is launched + INTEGER :: INC, JK, JL, IAZI + + + REAL(KIND=kind_phys) :: ZRADTODEG, ZGELATDEG + REAL(KIND=kind_phys) :: ZCIMIN, ZCIMAX + REAL(KIND=kind_phys) :: ZGAM, ZPEXP, ZXMAX, ZXMIN, ZXRAN + REAL(KIND=kind_phys) :: ZDX + + REAL(KIND=kind_phys) :: ZX1, ZX2, ZDXA, ZDXB, ZDXS + REAL(KIND=kind_phys) :: ZANG, ZAZ_FCT, ZNORM, ZANG1, ZTX + REAL(KIND=kind_phys) :: ZU, ZCIN, ZCPEAK + REAL(KIND=kind_phys) :: ZCIN4, ZBVFL4, ZCIN2, ZBVFL2, ZCIN3, ZBVFL3, ZCINC + REAL(KIND=kind_phys) :: ZATMP, ZFLUXS, ZDEP, ZFLUXSQ, ZULM, ZDFT, ZE1, ZE2 + REAL(KIND=kind_phys) :: ZMS_L,ZMS, Z0P5, Z0P0, Z50S + REAL(KIND=kind_phys) :: ZGAUSS(KLON), ZFLUXLAUN(KLON), ZCNGL(KLON) + REAL(KIND=kind_phys) :: ZCONS1,ZCONS2,ZDELP,ZRGPTS + +!!! try to assign values for the following + + REAL(KIND=kind_phys) :: GSSEC + REAL(KIND=kind_phys) :: ZGAUSSB,ZFLUXGLOB + +! REAL(KIND=kind_phys) :: PGAW(KLON) don't need this value, set ZDX directly + + +! REAL(KIND=kind_phys) :: PGELAT(KLON) !!! use xlatd from gfs instead + REAL(KIND=kind_phys) :: GCOEFF, GGAUSSA !!! GCOEFF link to precip +! REAL(KIND=kind_phys) :: GGAUSSB !!! GGAUSSB->ZGAUSS + !!!! GGAUSSA + REAL(KIND=kind_phys) :: GCSTAR + + + LOGICAL :: LGACALC, LGSATL, LOZPR + + integer :: NGAUSS, NSLOPE + + + NSLOPE=1 + LGACALC=.false. + LGSATL=.false. + LOZPR=.true. +! NGAUSS=4 + NGAUSS=1 +! GGAUSSA=20._kind_phys +! GGAUSSA=10._kind_phys + GGAUSSA=5._kind_phys +! GGAUSSB=1.0_kind_phys +! ZGAUSSB=0.25_kind_phys +! ZGAUSSB=0.3_kind_phys +! ZGAUSSB=0.35_kind_phys + ZGAUSSB=0.38_kind_phys +! ZGAUSSB=-0.25_kind_phys +! ZGAUSSB=0.5_kind_phys +! ZGAUSSB=0.3_kind_phys + GCSTAR=1.0_kind_phys + + + +! GSSEC=(pi2/1800.)*(pi2/1800.) + GSSEC=1.e-24 + GCOEFF=1.0_kind_phys !!do not know the value, but never use it when NGAUSS is not equal 1 + + + +!! LOGIC :: LGINDL !!LGINDL=.true. using standard atm values to calculate!! comment out +!! REAL(KIND=kind_phys) :: STPHI(KM),STTEM(KM), STPREH(KM) +!! REAL(KIND=kind_phys) :: ZTHSTD,ZRHOSTD,ZBVFSTD + +! Set parameters which are a function of launch height +!!! need to set the parameter ILAUCH, ZFLUXGLOB,ZGAUSSB,ZMS_L directly +!ILAUNCH=NLAUNCHL(KLAUNCH) +!ZFLUXGLOB=GFLUXLAUNL(KLAUNCH) +!ZGAUSSB=GGAUSSB(KLAUNCH) +!ZMS_L=GMSTAR_L(KLAUNCH) + +!*INPUT PARAMETERS +!* ---------------- + ZRADTODEG=57.29577951_kind_phys + ZMS_L=2.e3_kind_phys +! ZFLUXGLOB=3.75e-3_kind_phys +! ZFLUXGLOB=3.7e-3_kind_phys +! ZFLUXGLOB=3.55e-3_kind_phys +! ZFLUXGLOB=3.65e-3_kind_phys !standard value +! ZFLUXGLOB=3.62e-3_kind_phys !standard value + ZFLUXGLOB=3.60e-3_kind_phys + +! ZFLUXGLOB=3.2e-3_kind_phys +! ZFLUXGLOB=3.0e-3_kind_phys +! ZFLUXGLOB=5.0e-3_kind_phys +! ZFLUXGLOB=4.0e-3_kind_phys +! ZFLUXGLOB=0.0_kind_phys + + ZMS=2*pi/ZMS_L + +!* INITIALIZE FIELDS TO ZERO +!* ------------------------- + + PTENU(:,:)=0.0_kind_phys + PTENV(:,:)=0.0_kind_phys + pdtdt(:,:)=0.0_kind_phys + dked(:,:)=0.0_kind_phys + + DO JK=1,KLEV+1 + DO JL=1,KLON + PFLUXU(JL,JK)=0.0_kind_phys + PFLUXV(JL,JK)=0.0_kind_phys + ENDDO + ENDDO + + + DO IAZI=1,IAZIDIM + DO JK=1,KLEV + DO JL=1,KLON + ZPU(JL,JK,IAZI)=0.0_kind_phys + ZCRT(JL,JK,IAZI)=0.0_kind_phys + ZDFL(JL,JK,IAZI)=0.0_kind_phys + ENDDO + ENDDO + ENDDO + +!!!!!!!!!!!!!!!!!!!!!!!! +! redefine ilaunch + + DO JK=1, KLEV + if (PAPM11(KLON,JK) .LT. psrc) exit + ENDDO + ILAUNCH = max(JK-1,3) + + DO JL=1,KLON + zngw(JL) = PGEO11(JL, ILAUNCH) + ENDDO + + ILAUNCH = KLEV + 1 - ILAUNCH + +!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +!* reverse vertical coordinate to ECMWF + DO JL=1,KLON + PTM1(JL,:)=transfer(PTM11(JL,KLEV:1:-1),PTM11(JL,:)) + PUM1(JL,:)=transfer(PUM11(JL,KLEV:1:-1),PUM11(JL,:)) + PVM1(JL,:)=transfer(PVM11(JL,KLEV:1:-1),PVM11(JL,:)) + qm(JL,:)=transfer(qm1(JL,KLEV:1:-1),qm1(JL,:)) + PAPM1(JL,:)=transfer(PAPM11(JL,KLEV:1:-1),PAPM11(JL,:)) + PGEO1(JL,:)=transfer(PGEO11(JL,KLEV:1:-1),PGEO11(JL,:)) + prslk(JL,:)=transfer(prslk1(JL,KLEV:1:-1),prslk1(JL,:)) + + dked(JL,:)=transfer(dked(JL,KLEV:1:-1),dked(JL,:)) + PTENU(JL,:)=transfer(PTENU(JL,KLEV:1:-1),PTENU(JL,:)) + PTENV(JL,:)=transfer(PTENV(JL,KLEV:1:-1),PTENV(JL,:)) + pdtdt(JL,:)=transfer(pdtdt(JL,KLEV:1:-1),pdtdt(JL,:)) + + + PAPHM1(JL,:)=transfer(PAPHM11(JL,KLEV+1:1:-1),PAPHM11(JL,:)) + zmeti(JL,:)=transfer(zmeti1(JL,KLEV+1:1:-1),zmeti1(JL,:)) + ENDDO +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + +!* INITIALIZE PARAMETERS FOR COORDINATE TRANSFORM +!* ---------------------------------------------- + +! ZCIMIN,ZCIMAX - min,max intrinsic launch-level phase speed (c-U_o) (m/s) +! ZGAM - half=width of coordinate stretch + + ZCIMIN=0.50_kind_phys + ZCIMAX=100.0_kind_phys + ZGAM=0.25_kind_phys + + ZPEXP=GPTWO/2.0_kind_phys + +! set initial min ci in each column and azimuth (used for critical levels) + + DO IAZI=1,IAZIDIM + DO JL=1,KLON + ZCI_MIN(JL,IAZI)=ZCIMIN + ENDDO + ENDDO + + +!* DEFINE HALF MODEL LEVEL WINDS AND TEMPERATURE +!* ----------------------------------- + + DO JK=2,KLEV + DO JL=1,KLON + ZTHM1(JL,JK) =0.5_kind_phys*(PTM1(JL,JK-1)+PTM1(JL,JK)) + ZUHM1(JL,JK) =0.5_kind_phys*(PUM1(JL,JK-1)+PUM1(JL,JK)) + ZVHM1(JL,JK) =0.5_kind_phys*(PVM1(JL,JK-1)+PVM1(JL,JK)) + ENDDO + ENDDO + + JK=1 + DO JL=1,KLON + ZTHM1(JL,JK)=PTM1(JL,JK) + ZUHM1(JL,JK)=PUM1(JL,JK) + ZVHM1(JL,JK)=PVM1(JL,JK) + ENDDO + + +!* DEFINE STATIC STABILITY AND AIR DENSITY ON HALF MODEL LEVELS +!* ------------------------------------------------------------ + +! ZCONS1=1.0_kind_phys/RD +! ZCONS2=RG**2/RCPD + + ZCONS1=1.0_kind_phys/rd + ZCONS2=grav2cpd + + + DO JK=KLEV,2,-1 + DO JL=1,KLON +! ZDELP=PAPM1(JL,JK)-PAPM1(JL,JK-1) + ZDELP=(PGEO1(JL,JK)-PGEO1(JL,JK-1))*grav !! times grav since import from zmet + ZRHOHM1(JL,JK)=PAPHM1(JL,JK)*ZCONS1/ZTHM1(JL,JK) + ZBVFHM1(JL,JK)=ZCONS2/ZTHM1(JL,JK)*& + & (1.0_kind_phys+cpd*(PTM1(JL,JK)-PTM1(JL,JK-1))/ZDELP) +! & (1.0_kind_phys-RCPD*ZRHOHM1(JL,JK)*(PTM1(JL,JK)-PTM1(JL,JK-1))/ZDELP) + ZBVFHM1(JL,JK)=MAX(ZBVFHM1(JL,JK),GSSEC) + ZBVFHM1(JL,JK)=SQRT(ZBVFHM1(JL,JK)) + ENDDO + ENDDO + +!* SET UP AZIMUTH DIRECTIONS AND SOME TRIG FACTORS +!* ----------------------------------------------- + + ZANG=2*pi/IAZIDIM + ZAZ_FCT=1.0_kind_phys + + +! get normalization factor to ensure that the same amount of momentum +! flux is directed (n,s,e,w) no mater how many azimuths are selected. +! note, however, the code below assumes a symmetric distribution of +! of azimuthal directions (ie 4,8,16,32,...) + + ZNORM=0.0_kind_phys + DO IAZI=1,IAZIDIM + ZANG1=(IAZI-1)*ZANG + ZCOSANG(IAZI)=COS(ZANG1) + ZSINANG(IAZI)=SIN(ZANG1) + ZNORM=ZNORM+ABS(ZCOSANG(IAZI)) + ENDDO + ZAZ_FCT=2._kind_phys*ZAZ_FCT/ZNORM + + +!* DEFINE COORDINATE TRANSFORM +!* ----------------------------------------------- + +! note that this is expresed in terms of the intrinsic phase speed +! at launch ci=c-u_o so that the transformation is identical at every +! launch site. +! See Eq. 28-30 of Scinocca 2003. + + ZXMAX=1.0_kind_phys/ZCIMIN + ZXMIN=1.0_kind_phys/ZCIMAX + + ZXRAN=ZXMAX-ZXMIN + ZDX=ZXRAN/REAL(INCDIM-1) + IF(LGACALC) ZGAM=(ZXMAX-ZXMIN)/LOG(ZXMAX/ZXMIN) +!! LGACALC=.false. ZGAM =0.25 ZX1=0.0007 +!! LGACALC=.true. ZGAM =0.37559 ZX1=0.01 + + ZX1=ZXRAN/(EXP(ZXRAN/ZGAM)-1.0_kind_phys) + ZX2=ZXMIN-ZX1 + + + + + DO INC=1,INCDIM + ZTX=REAL(INC-1)*ZDX+ZXMIN + ZX(INC)=ZX1*EXP((ZTX-ZXMIN)/ZGAM)+ZX2 !Eq. 29 of Scinocca 2003 + ZCI(INC)=1.0_kind_phys/ZX(INC) !Eq. 28 of Scinocca 2003 + ZDCI(INC)=ZCI(INC)**2*(ZX1/ZGAM)*EXP((ZTX-ZXMIN)/ZGAM)*ZDX !Eq. 30 of Scinocca 2003 + ENDDO + + +!* DEFINE INTRINSIC VELOCITY (RELATIVE TO LAUNCH LEVEL VELOCITY) U(Z)-U(Zo), AND COEFFICINETS +!* ------------------------------------------------------------------------------------------ + + DO IAZI=1,IAZIDIM + DO JL=1,KLON + ZUL(JL,IAZI)=ZCOSANG(IAZI)*ZUHM1(JL,ILAUNCH)& + & +ZSINANG(IAZI)*ZVHM1(JL,ILAUNCH) + ENDDO + ENDDO + DO JL=1,KLON + ZBVFL(JL)=ZBVFHM1(JL,ILAUNCH) + ENDDO + + DO JK=2,ILAUNCH + DO IAZI=1,IAZIDIM + DO JL=1,KLON + ZU=ZCOSANG(IAZI)*ZUHM1(JL,JK)+ZSINANG(IAZI)*ZVHM1(JL,JK) + ZUI(JL,JK,IAZI)=ZU-ZUL(JL,IAZI) + ENDDO + ENDDO + ENDDO + +!* DEFINE RHO(Zo)/N(Zo) +!* ------------------- + DO JK=2,ILAUNCH + DO JL=1,KLON + ZFCT(JL,JK)=ZRHOHM1(JL,JK)/ZBVFHM1(JL,JK) + ENDDO + ENDDO + +! Optionally set ZFCT at launch level using standard atmos values, to ensure saturation is +! independent of location +! IF (LGINDL) THEN +! ZCONS1=1.0_kind_phys/rd +! ZCONS2=grav2cpd +! ZDELP=STPHI(ILAUNCH)-STPHI(ILAUNCH-1) !!probably need to time grav depending on input +! THSTD=0.5_kind_phys*(STTEM(ILAUNCH-1)+STTEM(ILAUNCH)) +! ZRHOSTD=STPREH(ILAUNCH-1)*ZCONS1/ZTHSTD +! ZBVFSTD=ZCONS2/ZTHSTD*(1.0_kind_phys+rcpd* +! & (STTEM(ILAUNCH)-STTEM(ILAUNCH-1))/ZDELP) +! +! ZBVFSTD=MAX(ZBVFSTD,GSSEC) +! ZBVFSTD=SQRT(ZBVFSTD) +! DO JL=1,KLON +! ZFCT(JL,ILAUNCH)=ZRHOSTD/ZBVFSTD +! ENDDO +! ENDIF + +!* SET LAUNCH MOMENTUM FLUX SPECTRAL DENSITY +!* ----------------------------------------- + +! Eq. (25) of Scinocca 2003 (not including the 'A' component), and with U-Uo=0 +! do this for only one azimuth since it is identical to all azimuths, and it will be renormalized +! Initial spectrum fully saturated if LGSATL + + IF(NSLOPE==1) THEN +! s=1 case + DO INC=1,INCDIM + ZCIN=ZCI(INC) + ZCIN4=(ZMS*ZCIN)**4 + DO JL=1,KLON + ZBVFL4=ZBVFL(JL)**4 + IF(LGSATL) THEN + ZFLUX(JL,INC,1)=ZFCT(JL,ILAUNCH)*ZBVFL4*MIN(ZCIN/ZCIN4,& + & ZCIN/ZBVFL4) + ELSE + ZFLUX(JL,INC,1)=ZFCT(JL,ILAUNCH)*ZBVFL4*ZCIN/(ZBVFL4+ZCIN4) + ENDIF + ZACT(JL,INC,1)=1.0_kind_phys + ENDDO + ENDDO + + ELSEIF(NSLOPE==2) THEN +! s=2 case + DO INC=1,INCDIM + ZCIN=ZCI(INC) + ZCIN4=(ZMS*ZCIN)**4 + DO JL=1,KLON + ZBVFL4=ZBVFL(JL)**4 + ZCPEAK=ZBVFL(JL)/ZMS + IF(LGSATL) THEN + ZFLUX(JL,INC,1)=ZFCT(JL,ILAUNCH)*ZBVFL4*MIN& + & (ZCPEAK/ZCIN4,ZCIN/ZBVFL4) + ELSE + ZFLUX(JL,INC,1)=ZFCT(JL,ILAUNCH)*ZBVFL4*ZCIN*ZCPEAK/(ZBVFL4& + & *ZCPEAK+ZCIN4*ZCIN) + ENDIF + ZACT(JL,INC,1)=1.0_kind_phys + ENDDO + ENDDO + + ELSEIF(NSLOPE==-1) THEN +! s=-1 case + DO INC=1,INCDIM + ZCIN=ZCI(INC) + ZCIN2=(ZMS*ZCIN)**2 + DO JL=1,KLON + ZBVFL2=ZBVFL(JL)**2 + ZFLUX(JL,INC,1)=ZFCT(JL,ILAUNCH)*ZBVFL2*ZCIN/(ZBVFL2+ZCIN2) + ZACT(JL,INC,1)=1.0_kind_phys + ENDDO + ENDDO + + ELSEIF(NSLOPE==0) THEN +! s=0 case + DO INC=1,INCDIM + ZCIN=ZCI(INC) + ZCIN3=(ZMS*ZCIN)**3 + DO JL=1,KLON + ZBVFL3=ZBVFL(JL)**3 + ZFLUX(JL,INC,1)=ZFCT(JL,ILAUNCH)*ZBVFL3*ZCIN/(ZBVFL3+ZCIN3) + ZACT(JL,INC,1)=1.0_kind_phys + ZACC(JL,INC,1)=1.0_kind_phys + ENDDO + ENDDO + + ENDIF + +!* NORMALIZE LAUNCH MOMENTUM FLUX +!* ------------------------------ + +! (rho x F^H = rho_o x F_p^total) + +! integrate (ZFLUX x dX) + DO INC=1,INCDIM + ZCINC=ZDCI(INC) + DO JL=1,KLON + ZPU(JL,ILAUNCH,1)=ZPU(JL,ILAUNCH,1)+ZFLUX(JL,INC,1)*ZCINC + ENDDO + ENDDO + + +!* NORMALIZE GFLUXLAUN TO INCLUDE SENSITIVITY TO PRECIPITATION +!* ----------------------------------------------------------- + +! Also other options to alter tropical values + +! A=ZFNORM in Scinocca 2003. A is independent of height. + ZDXA=1.0_kind_phys/29.E3_kind_phys + ZDXB=1.0_kind_phys/3.5E3_kind_phys + DO JL=1,KLON +!! ZDX=MAX(1.E2_kind_phys,2*RA*SQRT(pi*PGAW(JL))) !grid resolution (m) +!! ZDX=50.E3 ! c192 for c192 usage +!!! ZDX=25.E3 !C384 +!!! ZDX=13.E3 !C768 + + + !Scaling factor for launch flux depending on grid resolution + ! smooth reduction below 30 km + ZDXS=1.0_kind_phys-MIN(1.0_kind_phys,ATAN((MAX(1.0_kind_phys& + & /DX(JL),ZDXA)-ZDXA)/(ZDXB-ZDXA))) + ZFLUXLAUN(JL)=ZFLUXGLOB*ZDXS + ZFNORM(JL)=ZFLUXLAUN(JL)/ZPU(JL,ILAUNCH,1) + ENDDO + +! If LOZPR=TRUE then vary EPLAUNCH over tropics + IF (LOZPR) THEN + IF (NGAUSS==1) THEN + Z50S=-50.0_kind_phys + + DO JL=1,KLON + +! ZFLUXLAUN(JL)=ZFLUXLAUN(JL)*(1.0_kind_phys+MIN& +! & (0.5_kind_phys,GCOEFF*PPRECIP(JL))) !precip +! ZFNORM(JL)=ZFLUXLAUN(JL)/ZPU(JL,ILAUNCH,1) + + ZGELATDEG=xlatd(JL)-Z50S + ZGAUSS(JL)=ZGAUSSB*EXP((-ZGELATDEG*ZGELATDEG)& + & /(2*GGAUSSA*GGAUSSA)) + +! ZGELATDEG=xlatd(JL) +! ZGAUSS(JL)=-0.1_kind_phys*EXP((-ZGELATDEG*ZGELATDEG)& +! & /(2*GGAUSSA*GGAUSSA))+ZGAUSS(JL) + + +! ZGELATDEG=xlatd(JL) +! ZGAUSS(JL)=-0.05_kind_phys*EXP((-ZGELATDEG*ZGELATDEG)& +! & /(2*GGAUSSA*GGAUSSA))+ZGAUSS(JL) + + ZGELATDEG=xlatd(JL) + ZGAUSS(JL)=0.08_kind_phys*EXP((-ZGELATDEG*ZGELATDEG)& + & /(2*GGAUSSA*GGAUSSA))+ZGAUSS(JL) + + ZGELATDEG=xlatd(JL)-50.0_kind_phys + ZGAUSS(JL)= 0.0022_kind_phys*EXP((-ZGELATDEG*ZGELATDEG)& + & /(2*10.*10.))+ZGAUSS(JL) + + + ZFLUXLAUN(JL)=(1.0_kind_phys+ZGAUSS(JL))*ZFLUXLAUN(JL) + + + + ZFNORM(JL)=ZFLUXLAUN(JL)/ZPU(JL,ILAUNCH,1) + + + ENDDO + ELSEIF (NGAUSS==2) THEN + + DO JL=1,KLON +! ZGELATDEG=PGELAT(JL)*ZRADTODEG + ZGELATDEG=xlatd(JL) + ZGAUSS(JL)=ZGAUSSB*EXP((-ZGELATDEG*ZGELATDEG)& + & /(2*GGAUSSA*GGAUSSA)) + ZFLUXLAUN(JL)=(1.0_kind_phys+ZGAUSS(JL))*ZFLUXLAUN(JL) + ZFNORM(JL)=ZFLUXLAUN(JL)/ZPU(JL,ILAUNCH,1) + ENDDO + + + + ELSEIF (NGAUSS==4) THEN + +! Set latitudinal dependence to optimize stratospheric winds for 36r1 + Z50S=-50.0_kind_phys + DO JL=1,KLON +! ZGELATDEG=PGELAT(JL)*ZRADTODEG-Z50S + ZGELATDEG=xlatd(JL)-Z50S + ZGAUSS(JL)=ZGAUSSB*EXP((-ZGELATDEG*ZGELATDEG)/(2*GGAUSSA*GGAUSSA)) + ZFLUXLAUN(JL)=(1.0_kind_phys+ZGAUSS(JL))*ZFLUXLAUN(JL) + ZFNORM(JL)=ZFLUXLAUN(JL)/ZPU(JL,ILAUNCH,1) + ENDDO + + ENDIF + ENDIF + + DO IAZI=1,IAZIDIM + DO JL=1,KLON + ZPU(JL,ILAUNCH,IAZI)=ZFLUXLAUN(JL) + ENDDO + ENDDO + +!* ADJUST CONSTANT ZFCT +!* -------------------- + DO JK=2,ILAUNCH + DO JL=1,KLON + ZFCT(JL,JK)=ZFNORM(JL)*ZFCT(JL,JK) + ENDDO + ENDDO + +!* RENORMALIZE EACH SPECTRAL ELEMENT IN FIRST AZIMUTH +!* -------------------------------------------------- + DO INC=1,INCDIM + DO JL=1,KLON + ZFLUX(JL,INC,1)=ZFNORM(JL)*ZFLUX(JL,INC,1) + ENDDO + ENDDO + + + +!* COPY ZFLUX INTO ALL OTHER AZIMUTHS +!* -------------------------------- + +! ZACT=1 then no critical level +! ZACT=0 then critical level + + DO IAZI=2,IAZIDIM + DO INC=1,INCDIM + DO JL=1,KLON + ZFLUX(JL,INC,IAZI)=ZFLUX(JL,INC,1) + ZACT(JL,INC,IAZI)=1.0_kind_phys + ZACC(JL,INC,IAZI)=1.0_kind_phys + ENDDO + ENDDO + ENDDO + +! ----------------------------------------------------------------------------- + +!* BEGIN MAIN LOOP OVER LEVELS +!* --------------------------- + +!* begin IAZIDIM do-loop +!* -------------------- + + DO IAZI=1,IAZIDIM + +!* begin JK do-loop +!* ---------------- + + DO JK=ILAUNCH-1,2,-1 + +!* first do critical levels +!* ------------------------ + + DO JL=1,KLON + ZCI_MIN(JL,IAZI)=MAX(ZCI_MIN(JL,IAZI),ZUI(JL,JK,IAZI)) + ENDDO + +!* set ZACT to zero if critical level encountered +!* ---------------------------------------------- + + Z0P5=0.5_kind_phys + DO INC=1,INCDIM + ZCIN=ZCI(INC) + DO JL=1,KLON + ZATMP=Z0P5+SIGN(Z0P5,ZCIN-ZCI_MIN(JL,IAZI)) + ZACC(JL,INC,IAZI)=ZACT(JL,INC,IAZI)-ZATMP + ZACT(JL,INC,IAZI)=ZATMP + ENDDO + ENDDO + +!* integrate to get critical-level contribution to mom deposition on this level, i.e. ZACC=1 +!* ---------------------------------------------------------------------------------------- + + DO INC=1,INCDIM + ZCINC=ZDCI(INC) + DO JL=1,KLON + ZDFL(JL,JK,IAZI)=ZDFL(JL,JK,IAZI)+& + & ZACC(JL,INC,IAZI)*ZFLUX(JL,INC,IAZI)*ZCINC + ENDDO + ENDDO + +!* get weighted average of phase speed in layer + + DO JL=1,KLON + IF(ZDFL(JL,JK,IAZI)>0.0_kind_phys) THEN + ZATMP=ZCRT(JL,JK,IAZI) + DO INC=1,INCDIM + ZATMP=ZATMP+ZCI(INC)*& + & ZACC(JL,INC,IAZI)*ZFLUX(JL,INC,IAZI)*ZDCI(INC) + ENDDO + ZCRT(JL,JK,IAZI)=ZATMP/ZDFL(JL,JK,IAZI) + ELSE + ZCRT(JL,JK,IAZI)=ZCRT(JL,JK+1,IAZI) + ENDIF + ENDDO + +!* do saturation (Eq. (26) and (27) of Scinocca 2003) +!* ------------------------------------------------- + + IF(GPTWO==3.0_kind_phys) THEN + DO INC=1,INCDIM + ZCIN=ZCI(INC) + ZCINC=1.0_kind_phys/ZCIN + DO JL=1,KLON + ZE1=ZCIN-ZUI(JL,JK,IAZI) + ZE2=GCSTAR*ZFCT(JL,JK)*ZE1 + ZFLUXSQ=ZE2*ZE2*ZE1*ZCINC + ! ZFLUXSQ=ZE2*ZE2*ZE1/ZCIN + ZDEP=ZACT(JL,INC,IAZI)*(ZFLUX(JL,INC,IAZI)**2-ZFLUXSQ) + IF(ZDEP>0.0_kind_phys) THEN + ZFLUX(JL,INC,IAZI)=SQRT(ZFLUXSQ) + ENDIF + ENDDO + ENDDO + ELSEIF(GPTWO==2.0_kind_phys) THEN + DO INC=1,INCDIM + ZCIN=ZCI(INC) + ZCINC=1.0_kind_phys/ZCIN + DO JL=1,KLON + ZFLUXS=GCSTAR*ZFCT(JL,JK)*& + & (ZCIN-ZUI(JL,JK,IAZI))**2*ZCINC + ! ZFLUXS=GCSTAR*ZFCT(JL,JK)*(ZCIN-ZUI(JL,JK,IAZI))**2/ZCIN + ZDEP=ZACT(JL,INC,IAZI)*(ZFLUX(JL,INC,IAZI)-ZFLUXS) + IF(ZDEP>0.0_kind_phys) THEN + ZFLUX(JL,INC,IAZI)=ZFLUXS + ENDIF + ENDDO + ENDDO + ENDIF + +!* integrate spectrum +!* ------------------ + + DO INC=1,INCDIM + ZCINC=ZDCI(INC) + DO JL=1,KLON + ZPU(JL,JK,IAZI)=ZPU(JL,JK,IAZI)+& + & ZACT(JL,INC,IAZI)*ZFLUX(JL,INC,IAZI)*ZCINC + ENDDO + ENDDO + +!* end JK do-loop +!* -------------- + + ENDDO +!* end IAZIDIM do-loop +!* --------------- + + ENDDO + +! ----------------------------------------------------------------------------- + +!* MAKE CORRECTION FOR CRITICAL-LEVEL MOMENTUM DEPOSITION +!* ------------------------------------------------------ + + Z0P0=0._kind_phys +! ZRGPTS=1.0_kind_phys/(RG*PTSTEP) + ZRGPTS=1.0_kind_phys/(grav*PTSTEP) + DO IAZI=1,IAZIDIM + DO JL=1,KLON + ZCNGL(JL)=0.0_kind_phys + ENDDO + DO JK=2,ILAUNCH + DO JL=1,KLON + ZULM=ZCOSANG(IAZI)*PUM1(JL,JK)+ZSINANG(IAZI)*& + & PVM1(JL,JK)-ZUL(JL,IAZI) + ZDFL(JL,JK-1,IAZI)=ZDFL(JL,JK-1,IAZI)+ZCNGL(JL) + ZDFT=MIN(ZDFL(JL,JK-1,IAZI),2.0_kind_phys*(PAPM1(JL,JK-1)-& + & PAPM1(JL,JK))*(ZCRT(JL,JK-1,IAZI)-ZULM)*ZRGPTS) + + ZDFT=MAX(ZDFT,Z0P0) + ZCNGL(JL)=(ZDFL(JL,JK-1,IAZI)-ZDFT) + ZPU(JL,JK,IAZI)=ZPU(JL,JK,IAZI)-ZCNGL(JL) + ENDDO + ENDDO + ENDDO + + +!* SUM CONTRIBUTION FOR TOTAL ZONAL AND MERIDIONAL FLUX +!* --------------------------------------------------- + + DO IAZI=1,IAZIDIM + DO JK=ILAUNCH,2,-1 + DO JL=1,KLON + PFLUXU(JL,JK)=PFLUXU(JL,JK)+ZPU(JL,JK,IAZI)*ZAZ_FCT*ZCOSANG(IAZI) + PFLUXV(JL,JK)=PFLUXV(JL,JK)+ZPU(JL,JK,IAZI)*ZAZ_FCT*ZSINANG(IAZI) + ENDDO + ENDDO + ENDDO + + +!* UPDATE U AND V TENDENCIES +!* ---------------------------- + +! ZCONS1=1.0_kind_phys/RCPD + ZCONS1=rcpd + DO JK=1,ILAUNCH + DO JL=1, KLON +! ZDELP= RG/(PAPHM1(JL,JK+1)-PAPHM1(JL,JK)) + ZDELP= grav/(PAPHM1(JL,JK+1)-PAPHM1(JL,JK)) + ZE1=(PFLUXU(JL,JK+1)-PFLUXU(JL,JK))*ZDELP + ZE2=(PFLUXV(JL,JK+1)-PFLUXV(JL,JK))*ZDELP + + if (abs(ZE1) >= maxdudt ) then + ZE1 = sign(maxdudt, ZE1) + endif + if (abs(ZE2) >= maxdudt ) then + ZE2 = sign(maxdudt, ZE2) + endif + + + PTENU(JL,JK)=ZE1 + PTENV(JL,JK)=ZE2 +! add the tendency of dT/dt + ZE2=-(PUM1(JL,JK)*PTENU(JL,JK)+PVM1(JL,JK)*PTENV(JL,JK))/cpd + if (abs(ZE2) >= max_eps) pdtdt(JL,JK) = sign(max_eps, ZE2) + +! end of the tendency of dT/dt + ENDDO + ENDDO + + +!* reverse vertical coordinate back to GFS for outbound variables only + DO JL=1,KLON + dked(JL,:)=transfer(dked(JL,KLEV:1:-1),dked(JL,:)) + PTENU(JL,:)=transfer(PTENU(JL,KLEV:1:-1),PTENU(JL,:)) + PTENV(JL,:)=transfer(PTENV(JL,KLEV:1:-1),PTENV(JL,:)) + pdtdt(JL,:)=transfer(pdtdt(JL,KLEV:1:-1),pdtdt(JL,:)) + ENDDO + + +! DO JL=1,KLON +! dked(JL,:)=0.0 +! PTENU(JL,:)=0.0 +! PTENV(JL,:)=0.0 +! pdtdt(JL,:)=0.0 +! ENDDO + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + return + end subroutine ecmwf_ngw_emc + + +end module ecmwf_ngw + + + + diff --git a/physics/GWD/ugwp_driver_v0.F b/physics/GWD/ugwp_driver_v0.F index 0fc4a2274..845323e43 100644 --- a/physics/GWD/ugwp_driver_v0.F +++ b/physics/GWD/ugwp_driver_v0.F @@ -348,7 +348,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, BVF2 = grav2 * RDZ * (VTK(I,K+1)-VTK(I,K)) & / (VTK(I,K+1)+VTK(I,K)) bnv2(i,k+1) = max( BVF2, bnv2min ) - RI_N(I,K+1) = Bnv2(i,k)/SHR2 ! Richardson number consistent with BNV2 + ! https://github.com/NCAR/ccpp-physics/issues/1103 + !RI_N(I,K+1) = Bnv2(i,k)/SHR2 ! Richardson number consistent with BNV2 + RI_N(I,K+1) = Bnv2(i,max(k,2))/SHR2 ! Richardson number consistent with BNV2 ! ! add here computation for Ktur and OGW-dissipation fro VE-GFS ! @@ -814,7 +816,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, IF( do_tofd ) then axtms(:,:) = 0.0 ; aytms(:,:) = 0.0 - + DO I = 1,npt J = ipt(i) zpbl =rgrav*phil( j, kpbl(j) ) diff --git a/physics/GWD/ugwpv1_gsldrag.F90 b/physics/GWD/ugwpv1_gsldrag.F90 index 094588a35..459e29362 100644 --- a/physics/GWD/ugwpv1_gsldrag.F90 +++ b/physics/GWD/ugwpv1_gsldrag.F90 @@ -43,6 +43,9 @@ module ugwpv1_gsldrag use cires_ugwpv1_module, only: cires_ugwpv1_init, ngwflux_update, calendar_ugwp use cires_ugwpv1_module, only: knob_ugwp_version, cires_ugwp_dealloc, tamp_mpa use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2 +! use cires_ugwpv1_solv2, only: cires_ugwpv1_ngw_solv2, ecmwf_ngw + use ecmwf_ngw, only: ecmwf_ngw_emc + use cires_ugwpv1_oro, only: orogw_v1 use drag_suite, only: drag_suite_run, drag_suite_psl @@ -70,7 +73,8 @@ subroutine ugwpv1_gsldrag_init ( & con_pi, con_rerth, con_p0, & con_g, con_omega, con_cp, con_rd, con_rv,con_fvirt, & do_ugwp,do_ugwp_v0, do_ugwp_v0_orog_only, do_gsl_drag_ls_bl, & - do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & + do_gsl_drag_ss, do_gsl_drag_tofd, do_ngw_ec, do_ugwp_v1, & +!! do_gsl_drag_ss, do_gsl_drag_tofd, do_ugwp_v1, & do_ugwp_v1_orog_only, do_ugwp_v1_w_gsldrag, errmsg, errflg) use ugwp_common @@ -94,9 +98,10 @@ subroutine ugwpv1_gsldrag_init ( & real(kind=kind_phys), intent (in) :: con_g, con_cp, con_rd, con_rv, con_omega, con_fvirt logical, intent (in) :: do_ugwp - logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & - do_gsl_drag_ls_bl, do_gsl_drag_ss, & - do_gsl_drag_tofd, do_ugwp_v1, & + logical, intent (in) :: do_ugwp_v0, do_ugwp_v0_orog_only, & + do_gsl_drag_ls_bl, do_gsl_drag_ss, & +!! do_gsl_drag_tofd, do_ugwp_v1, & + do_gsl_drag_tofd, do_ugwp_v1, do_ngw_ec, & do_ugwp_v1_orog_only,do_ugwp_v1_w_gsldrag character(len=*), intent (in) :: fn_nml2 @@ -302,7 +307,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ak, bk, ntrac, lonr, dtp, fhzero, kdt, ldiag3d, lssav, flag_for_gwd_generic_tend, do_gsl_drag_ls_bl, & do_gsl_drag_ss, do_gsl_drag_tofd, & do_gwd_opt_psl, psl_gwd_dx_factor, & - do_ugwp_v1, do_ugwp_v1_orog_only, & + do_ngw_ec, do_ugwp_v1, do_ugwp_v1_orog_only, & do_ugwp_v1_w_gsldrag, gwd_opt, do_tofd, ldiag_ugwp, ugwp_seq_update, & cdmbgwd, alpha_fd, jdat, nmtvr, hprime, oc, theta, sigma, gamma, & elvmax, clx, oa4, varss,oc1ss,oa4ss,ol4ss, dx, xlat, xlat_d, sinlat, coslat, & @@ -356,7 +361,7 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ak, bk, ntrac, lonr, dtp, ! flags for choosing combination of GW drag schemes to run logical, intent (in) :: do_gsl_drag_ls_bl, do_gsl_drag_ss, do_gsl_drag_tofd - logical, intent (in) :: do_ugwp_v1, do_ugwp_v1_orog_only, do_tofd + logical, intent (in) :: do_ugwp_v1, do_ngw_ec, do_ugwp_v1_orog_only, do_tofd logical, intent (in) :: ldiag_ugwp, ugwp_seq_update logical, intent (in) :: do_ugwp_v1_w_gsldrag ! combination of ORO and NGW schemes @@ -698,10 +703,21 @@ subroutine ugwpv1_gsldrag_run(me, master, im, levs, ak, bk, ntrac, lonr, dtp, call ngwflux_update(me, master, im, levs, kdt, ddd_ugwp,curdate, & tau_amf, xlat_d, sinlat,coslat, rain, tau_ngw) - call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & + if (do_ngw_ec) then + + call ecmwf_ngw_emc(me, master, im, levs, kdt, dtp, dx, & + tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & + zmet, zmeti,prslk, xlat_d, sinlat, coslat, & + dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) + else + + call cires_ugwpv1_ngw_solv2(me, master, im, levs, kdt, dtp, & tau_ngw, tgrs, ugrs, vgrs, q1, prsl, prsi, & zmet, zmeti,prslk, xlat_d, sinlat, coslat, & dudt_ngw, dvdt_ngw, dtdt_ngw, kdis_ngw, zngw) + + endif + ! ! => con_g, con_cp, con_rd, con_rv, con_omega, con_pi, con_fvirt ! diff --git a/physics/GWD/ugwpv1_gsldrag.meta b/physics/GWD/ugwpv1_gsldrag.meta index 376a562bb..24d8b0688 100644 --- a/physics/GWD/ugwpv1_gsldrag.meta +++ b/physics/GWD/ugwpv1_gsldrag.meta @@ -2,7 +2,7 @@ name = ugwpv1_gsldrag type = scheme dependencies = ../hooks/machine.F,drag_suite.F90 - dependencies = cires_ugwpv1_module.F90,cires_ugwpv1_triggers.F90,cires_ugwpv1_initialize.F90,cires_ugwpv1_solv2.F90 + dependencies = cires_ugwpv1_module.F90,cires_ugwpv1_triggers.F90,cires_ugwpv1_initialize.F90,cires_ugwpv1_solv2.F90,ecmwf_ngw.F90 dependencies = cires_ugwpv1_sporo.F90,cires_ugwpv1_oro.F90 ######################################################################## [ccpp-arg-table] @@ -218,6 +218,13 @@ dimensions = () type = logical intent = in +[do_ngw_ec] + standard_name = flag_for_ngw_ec + long_name = flag to activate ecmwf ngwd + units = flag + dimensions = () + type = logical + intent = in [do_ugwp_v1] standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP @@ -417,6 +424,13 @@ type = real kind = kind_phys intent = in +[do_ngw_ec] + standard_name = flag_for_ngw_ec + long_name = flag to activate ecmwf ngwd + units = flag + dimensions = () + type = logical + intent = in [do_ugwp_v1] standard_name = flag_for_ugwp_version_1 long_name = flag to activate ver 1 CIRES UGWP diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 index 129b3203e..97d9b138d 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.F90 @@ -16,13 +16,13 @@ module GFS_MP_generic_post !! \htmlinclude GFS_MP_generic_post_run.html !! subroutine GFS_MP_generic_post_run( & - im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_nssl, & - imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, rhowater, rainmin, dtf, & - frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, phil, htop, refl_10cm, & - imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf, con_t0c, snow, graupel, save_t, save_q, & - rain0, ice0, snow0, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, cnvprcp,& - totprcp, totice, totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, snow_cpl, & - pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, exticeden, & + im, levs, kdt, nrcm, nncl, ntcw, ntrac, imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_tempo, & + imp_physics_nssl, imp_physics_mg, imp_physics_fer_hires, cal_pre, cplflx, cplchm, cpllnd, progsigma, con_g, & + rhowater, rainmin, dtf, frain, rainc, rain1, rann, xlat, xlon, gt0, gq0, prsl, prsi, phii, tsfc, ice, phil, htop, & + refl_10cm, imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf, con_t0c, snow, graupel, save_t, & + save_q, rain0, ice0, snow0, graupel0, del, rain, domr_diag, domzr_diag, domip_diag, doms_diag, tprcp, srflag, sr, & + cnvprcp, totprcp, totice, totsnw, totgrp, cnvprcpb, totprcpb, toticeb, totsnwb, totgrpb, rain_cpl, rainc_cpl, & + snow_cpl, pwat, frzr, frzrb, frozr, frozrb, tsnowp, tsnowpb, rhonewsn1, exticeden, & drain_cpl, dsnow_cpl, lsm, lsm_ruc, lsm_noahmp, raincprv, rainncprv, iceprv, snowprv, & graupelprv, draincprv, drainncprv, diceprv, dsnowprv, dgraupelprv, dtp, & dtend, dtidx, index_of_temperature, index_of_process_mp,ldiag3d, qdiag3d,dqdt_qmicro, lssav, num_dfi_radar, & @@ -35,7 +35,7 @@ subroutine GFS_MP_generic_post_run( integer, intent(in) :: im, levs, kdt, nrcm, nncl, ntcw, ntrac, num_dfi_radar, index_of_process_dfi_radar integer, intent(in) :: imp_physics, imp_physics_gfdl, imp_physics_thompson, imp_physics_mg, imp_physics_fer_hires - integer, intent(in) :: imp_physics_nssl, iopt_lake_clm, iopt_lake, lkm + integer, intent(in) :: imp_physics_nssl, iopt_lake_clm, iopt_lake, lkm, imp_physics_tempo logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm, cpllnd, progsigma, exticeden integer, intent(in) :: index_of_temperature,index_of_process_mp,use_lake_model(:) integer, intent(in) :: imfshalcnv,imfshalcnv_gf,imfdeepcnv,imfdeepcnv_gf,imfdeepcnv_samf @@ -133,7 +133,7 @@ subroutine GFS_MP_generic_post_run( ! ! Combine convective reflectivity with MP reflectivity for selected ! parameterizations. - if ( (imp_physics==imp_physics_thompson .or. imp_physics==imp_physics_nssl) .and. & + if ( (imp_physics==imp_physics_thompson .or. imp_physics==imp_physics_tempo .or. imp_physics==imp_physics_nssl) .and. & (imfdeepcnv==imfdeepcnv_samf .or. imfdeepcnv==imfdeepcnv_gf .or. imfshalcnv==imfshalcnv_gf) ) then do i=1,im factor(i) = 0.0 @@ -178,7 +178,8 @@ subroutine GFS_MP_generic_post_run( endif ! compute surface snowfall, graupel/sleet, freezing rain and precip ice density - if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then + if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. & + imp_physics == imp_physics_tempo .or. imp_physics == imp_physics_nssl ) then do i = 1, im if (gt0(i,1) .le. 273) then frzr(i) = frzr(i) + rain0(i) @@ -256,7 +257,7 @@ subroutine GFS_MP_generic_post_run( ice = ice0 snow = snow0 ! Do it right from the beginning for Thompson - else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_nssl ) then + else if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_tempo .or. imp_physics == imp_physics_nssl ) then tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip graupel = frain*graupel0 ! time-step graupel ice = frain*ice0 ! time-step ice @@ -302,7 +303,8 @@ subroutine GFS_MP_generic_post_run( ! ! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation - if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson .and. imp_physics /= imp_physics_nssl) then + if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson .and. & + imp_physics /= imp_physics_tempo .and. imp_physics /= imp_physics_nssl) then do i=1,im tprcp(i) = max(zero, rain(i) ) if(doms(i) > zero .or. domip(i) > zero) then @@ -390,7 +392,7 @@ subroutine GFS_MP_generic_post_run( !! \f$0^oC\f$. if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson .or. & - imp_physics == imp_physics_nssl ) then + imp_physics == imp_physics_tempo .or. imp_physics == imp_physics_nssl ) then ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta index c188cc555..15ad5f6b3 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_MP_generic_post.meta @@ -86,6 +86,13 @@ dimensions = () type = integer intent = in +[imp_physics_tempo] + standard_name = identifier_for_tempo_microphysics_scheme + long_name = choice of TEMPO microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [imp_physics_mg] standard_name = identifier_for_morrison_gettelman_microphysics_scheme long_name = choice of Morrison-Gettelman microphysics scheme diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_photochemistry.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_photochemistry.F90 index 921b45111..632a86597 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_photochemistry.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_photochemistry.F90 @@ -46,7 +46,7 @@ end subroutine GFS_photochemistry_init !! subroutine GFS_photochemistry_run (dtp, ozphys, oz_phys_2015, oz_phys_2006, con_1ovg, & prsl, dp, ozpl, h2o_phys, h2ophys, h2opl, h2o0, oz0, gt0, do3_dt_prd, do3_dt_ozmx, & - do3_dt_temp, do3_dt_ohoz, errmsg, errflg) + do3_dt_temp, do3_dt_ohoz, dqv_dt_prd, dqv_dt_qvmx, errmsg, errflg) ! Inputs real(kind=kind_phys), intent(in) :: & @@ -73,7 +73,9 @@ subroutine GFS_photochemistry_run (dtp, ozphys, oz_phys_2015, oz_phys_2006, con_ do3_dt_prd, & ! Physics tendency: production and loss effect do3_dt_ozmx, & ! Physics tendency: ozone mixing ratio effect do3_dt_temp, & ! Physics tendency: temperature effect - do3_dt_ohoz ! Physics tendency: overhead ozone effect + do3_dt_ohoz, & ! Physics tendency: overhead ozone effect + dqv_dt_prd, & ! Physics tendency: Climatological net production effect + dqv_dt_qvmx ! Physics tendency: specific humidity effect ! Outputs real(kind=kind_phys), intent(inout), dimension(:,:) :: & @@ -97,7 +99,7 @@ subroutine GFS_photochemistry_run (dtp, ozphys, oz_phys_2015, oz_phys_2006, con_ do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz) endif if (h2o_phys) then - call h2ophys%run(dtp, prsl, h2opl, h2o0) + call h2ophys%run(dtp, prsl, h2opl, h2o0, dqv_dt_prd, dqv_dt_qvmx) endif end subroutine GFS_photochemistry_run diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_photochemistry.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_photochemistry.meta index f8874fef7..a89773b12 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_photochemistry.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_photochemistry.meta @@ -193,6 +193,24 @@ kind = kind_phys intent = inout optional = True +[dqv_dt_prd] + standard_name = water_vapor_tendency_due_to_production_and_loss_rate + long_name = water_vapor tendency due to production and loss rate + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[dqv_dt_qvmx] + standard_name = water_vapor_tendency_due_to_water_vapor_mixing_ratio + long_name = water_vapor tendency due to water_vapor mixing ratio + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 index 1c78cccb5..06d35c17b 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.F90 @@ -18,7 +18,8 @@ module GFS_phys_time_vary use module_h2ophys, only: ty_h2ophys use aerclm_def, only : aerin, aer_pres, ntrcaer, ntrcaerm, iamin, iamax, jamin, jamax - use aerinterp, only : read_aerdata, setindxaer, aerinterpol, read_aerdataf + use aerinterp, only : read_aerdata, setindxaer, aerinterpol, read_aerdataf, & + read_aerdata_dl, aerinterpol_dl, read_aerdataf_dl use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol @@ -78,7 +79,7 @@ end subroutine copy_error !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !> @{ subroutine GFS_phys_time_vary_init ( & - me, master, ntoz, h2o_phys, iaerclm, iccn, iaermdl, iflip, im, levs, & + me, master, ntoz, h2o_phys, iaerclm, iaermdl, iccn, iflip, im, levs, & nx, ny, idate, xlat_d, xlon_d, & jindx1_o3, jindx2_o3, ddy_o3, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & @@ -227,7 +228,12 @@ subroutine GFS_phys_time_vary_init ( ntrcaer = ntrcaerm myerrflg = 0 myerrmsg = 'read_aerdata failed without a message' - call read_aerdata (me,master,iflip,idate,myerrmsg,myerrflg) + if(iaermdl == 1) then + call read_aerdata (me,master,iflip,idate,myerrmsg,myerrflg) + elseif (iaermdl == 6) then + call read_aerdata_dl(me,master,iflip, & + idate,fhour, myerrmsg,myerrflg) + end if call copy_error(myerrmsg, myerrflg, errmsg, errflg) else if(iaermdl ==2 ) then do ix=1,ntrcaerm @@ -351,7 +357,11 @@ subroutine GFS_phys_time_vary_init ( if (iaerclm) then ! This call is outside the OpenMP section, so it should access errmsg & errflg directly. - call read_aerdataf (me, master, iflip, idate, fhour, errmsg, errflg) + if(iaermdl==1) then + call read_aerdataf (me, master, iflip, idate, fhour, errmsg, errflg) + elseif (iaermdl==6) then + call read_aerdataf_dl (me, master, iflip, idate, fhour, errmsg, errflg) + end if ! If it is moved to an OpenMP section, it must use myerrmsg, myerrflg, and copy_error. if (errflg/=0) return end if @@ -704,7 +714,7 @@ end subroutine GFS_phys_time_vary_init subroutine GFS_phys_time_vary_timestep_init ( & me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, cplflx, & nsswr, fhswr, lsswr, fhour, & - imfdeepcnv, cal_pre, random_clds, nscyc, ntoz, h2o_phys, iaerclm, iccn, clstp, & + imfdeepcnv, cal_pre, random_clds, nscyc, ntoz, h2o_phys, iaerclm, iaermdl, iccn, clstp, & jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, fn_nml, & @@ -722,7 +732,7 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Interface variables integer, intent(in) :: me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, & - nsswr, imfdeepcnv, iccn, nscyc, ntoz, iflip + nsswr, imfdeepcnv, iccn, nscyc, ntoz, iflip, iaermdl integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhswr, fhour logical, intent(in) :: lsswr, cal_pre, random_clds, h2o_phys, iaerclm, cplflx @@ -790,7 +800,7 @@ subroutine GFS_phys_time_vary_timestep_init ( !$OMP parallel num_threads(nthrds) default(none) & !$OMP shared(kdt,nsswr,lsswr,clstp,imfdeepcnv,cal_pre,random_clds) & -!$OMP shared(fhswr,fhour,seed0,cnx,cny,nrcm,wrk,rannie,rndval) & +!$OMP shared(fhswr,fhour,seed0,cnx,cny,nrcm,wrk,rannie,rndval, iaermdl) & !$OMP shared(rann,im,isc,jsc,imap,jmap,ntoz,me,idate,jindx1_o3,jindx2_o3) & !$OMP shared(ozpl,ddy_o3,h2o_phys,jindx1_h,jindx2_h,h2opl,ddy_h,iaerclm,master) & !$OMP shared(levs,prsl,iccn,jindx1_ci,jindx2_ci,ddy_ci,iindx1_ci,iindx2_ci) & @@ -863,23 +873,17 @@ subroutine GFS_phys_time_vary_timestep_init ( rjday = jdoy + jdat(5) / 24. if (rjday < ozphys%time(1)) rjday = rjday + 365. - n2 = ozphys%ntime + 1 - do j=2,ozphys%ntime - if (rjday < ozphys%time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 - if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime - !> - Update ozone concentration. if (ntoz > 0) then + call find_photochem_time_index(ozphys%ntime, ozphys%time, rjday, n1, n2) + call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) endif !> - Update stratospheric h2o concentration. if (h2o_phys) then + call find_photochem_time_index(h2ophys%ntime, h2ophys%time, rjday, n1, n2) + call h2ophys%update(jindx1_h, jindx2_h, ddy_h, rjday, n1, n2, h2opl) endif @@ -908,11 +912,19 @@ subroutine GFS_phys_time_vary_timestep_init ( if (iaerclm) then ! aerinterpol is using threading inside, don't ! move into OpenMP parallel section above - call aerinterpol (me, master, nthrds, im, idate, & - fhour, iflip, jindx1_aer, jindx2_aer, & - ddy_aer, iindx1_aer, & - iindx2_aer, ddx_aer, & - levs, prsl, aer_nm, errmsg, errflg) + if (iaermdl==1) then + call aerinterpol (me, master, nthrds, im, idate, & + fhour, iflip, jindx1_aer, jindx2_aer, & + ddy_aer, iindx1_aer, & + iindx2_aer, ddx_aer, & + levs, prsl, aer_nm, errmsg, errflg) + else if (iaermdl==6) then + call aerinterpol_dl (me, master, nthrds, im, idate, & + fhour, iflip, jindx1_aer, jindx2_aer, & + ddy_aer, iindx1_aer, & + iindx2_aer, ddx_aer, & + levs, prsl, aer_nm, errmsg, errflg) + endif if(errflg /= 0) then return endif @@ -933,6 +945,29 @@ subroutine GFS_phys_time_vary_timestep_init ( endif endif + contains + !> Find the time indexes on either side of current time + subroutine find_photochem_time_index(ntime, time, rjday, n1, n2) + implicit none + !> The number of times provided in the parameter file + integer, intent(in) :: ntime + !> The indexes of the parameters just before and after the + !! current time + integer, intent(out) :: n1, n2 + !> The times provided in the parameter file + real, intent(in), dimension(ntime+1) :: time + !> The current time of year + real, intent(in) :: rjday + n2 = ntime + 1 + do j=2,ntime + if (rjday < time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + if (n2 > ntime) n2 = n2 - ntime + end subroutine find_photochem_time_index end subroutine GFS_phys_time_vary_timestep_init !> @} diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta index 8dba6760e..242cc467d 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.fv3.meta @@ -1259,6 +1259,13 @@ dimensions = () type = logical intent = in +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = in [iccn] standard_name = control_for_ice_cloud_condensation_nuclei_forcing long_name = flag for IN and CCN forcing for morrison gettelman microphysics diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 index 35b46618c..ca11daffe 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.F90 @@ -15,7 +15,8 @@ module GFS_phys_time_vary use module_h2ophys, only: ty_h2ophys use aerclm_def, only : aerin, aer_pres, ntrcaer, ntrcaerm, iamin, iamax, jamin, jamax - use aerinterp, only : read_aerdata, setindxaer, aerinterpol, read_aerdataf + use aerinterp, only : read_aerdata, setindxaer, aerinterpol, read_aerdataf, & + read_aerdata_dl, aerinterpol_dl, read_aerdataf_dl use iccn_def, only : ciplin, ccnin, ci_pres use iccninterp, only : read_cidata, setindxci, ciinterpol @@ -58,7 +59,7 @@ module GFS_phys_time_vary !>\section gen_GFS_phys_time_vary_init GFS_phys_time_vary_init General Algorithm !! @{ subroutine GFS_phys_time_vary_init ( & - me, master, ntoz, h2o_phys, iaerclm, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & + me, master, ntoz, h2o_phys, iaerclm,iaermdl, iccn, iflip, im, nx, ny, idate, xlat_d, xlon_d, & jindx1_o3, jindx2_o3, ddy_o3, ozphys, h2ophys, jindx1_h, jindx2_h, ddy_h, h2opl,fhour, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, imap, jmap, & @@ -77,7 +78,7 @@ subroutine GFS_phys_time_vary_init ( implicit none ! Interface variables - integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny + integer, intent(in) :: me, master, ntoz, iccn, iflip, im, nx, ny, iaermdl logical, intent(in) :: h2o_phys, iaerclm, lsm_cold_start integer, intent(in) :: idate(:), iopt_lake, iopt_lake_clm, iopt_lake_flake real(kind_phys), intent(in) :: fhour, lakefrac_threshold, lakedepth_threshold @@ -208,7 +209,11 @@ subroutine GFS_phys_time_vary_init ( ! If iaerclm is .true., then ntrcaer == ntrcaerm ntrcaer = size(aer_nm, dim=3) ! Read aerosol climatology - call read_aerdata (me,master,iflip,idate,errmsg,errflg) + if(iaermdl==1) then + call read_aerdata (me,master,iflip,idate,errmsg,errflg) + elseif(iaermdl==6) then + call read_aerdata_dl (me,master,iflip,idate,errmsg,errflg) + end if endif if (errflg /= 0) return else @@ -312,9 +317,12 @@ subroutine GFS_phys_time_vary_init ( endif if (errflg/=0) return - if (iaerclm) then - call read_aerdataf (me, master, iflip, idate, fhour, errmsg, errflg) + if (iaermdl==1) then + call read_aerdataf (me, master, iflip, idate, fhour, errmsg, errflg) + elseif (iaermdl==6) then + call read_aerdataf_dl (me, master, iflip, idate, fhour, errmsg, errflg) + end if if (errflg/=0) return end if @@ -646,7 +654,7 @@ end subroutine GFS_phys_time_vary_init !! @{ subroutine GFS_phys_time_vary_timestep_init ( & me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, idate, nsswr, fhswr, lsswr, fhour, & - imfdeepcnv, cal_pre, random_clds, ozphys, h2ophys, ntoz, h2o_phys, iaerclm, iccn, clstp, & + imfdeepcnv, cal_pre, random_clds, ozphys, h2ophys, ntoz, h2o_phys, iaerclm, iaermdl, iccn, clstp, & jindx1_o3, jindx2_o3, ddy_o3, ozpl, jindx1_h, jindx2_h, ddy_h, h2opl, iflip, & jindx1_aer, jindx2_aer, ddy_aer, iindx1_aer, iindx2_aer, ddx_aer, aer_nm, & jindx1_ci, jindx2_ci, ddy_ci, iindx1_ci, iindx2_ci, ddx_ci, in_nm, ccn_nm, & @@ -657,7 +665,7 @@ subroutine GFS_phys_time_vary_timestep_init ( ! Interface variables integer, intent(in) :: me, master, cnx, cny, isc, jsc, nrcm, im, levs, kdt, & - nsswr, imfdeepcnv, iccn, ntoz, iflip + nsswr, imfdeepcnv, iccn, ntoz, iflip, iaermdl integer, intent(in) :: idate(:) real(kind_phys), intent(in) :: fhswr, fhour logical, intent(in) :: lsswr, cal_pre, random_clds, h2o_phys, iaerclm @@ -769,23 +777,17 @@ subroutine GFS_phys_time_vary_timestep_init ( rjday = jdoy + jdat(5) / 24. if (rjday < ozphys%time(1)) rjday = rjday + 365. - n2 = ozphys%ntime + 1 - do j=2,ozphys%ntime - if (rjday < ozphys%time(j)) then - n2 = j - exit - endif - enddo - n1 = n2 - 1 - if (n2 > ozphys%ntime) n2 = n2 - ozphys%ntime - !> - Update ozone concentration. if (ntoz > 0) then + call find_photochemistry_index(ozphys%ntime, ozphys%time, rjday, n1, n2) + call ozphys%update_o3prog(jindx1_o3, jindx2_o3, ddy_o3, rjday, n1, n2, ozpl) endif !> - Update stratospheric h2o concentration. if (h2o_phys) then + call find_photochemistry_index(h2ophys%ntime, h2ophys%time, rjday, n1, n2) + call h2ophys%update(jindx1_h, jindx2_h, ddy_h, rjday, n1, n2, h2opl) endif @@ -809,13 +811,18 @@ subroutine GFS_phys_time_vary_timestep_init ( if (iaerclm) then ! aerinterpol is using threading inside, don't ! move into OpenMP parallel section above - call aerinterpol (me, master, nthrds, im, idate, & - fhour, iflip, jindx1_aer, jindx2_aer, & - ddy_aer, iindx1_aer, & - iindx2_aer, ddx_aer, & - levs, prsl, aer_nm, errmsg, errflg) - if(errflg /= 0) then - return + if (iaermdl==1) then + call aerinterpol (me, master, nthrds, im, idate, & + fhour, iflip, jindx1_aer, jindx2_aer, & + ddy_aer, iindx1_aer, & + iindx2_aer, ddx_aer, & + levs, prsl, aer_nm) + elseif (iaermdl==6) then + call aerinterpol_dl (me, master, nthrds, im, idate, & + fhour, iflip, jindx1_aer, jindx2_aer, & + ddy_aer, iindx1_aer, & + iindx2_aer, ddx_aer, & + levs, prsl, aer_nm) endif endif @@ -834,6 +841,29 @@ subroutine GFS_phys_time_vary_timestep_init ( ! endif ! endif + contains + !> Find the time indexes on either side of current time + subroutine find_photochemistry_index(ntime, time, rjday, n1, n2) + implicit none + !> The number of times provided in the parameter file + integer, intent(in) :: ntime + !> The indexes of the parameters just before and after the + !! current time + integer, intent(out) :: n1, n2 + !> The times provided in the parameter file + real, intent(in), dimension(ntime+1) :: time + !> The current time of year + real, intent(in) :: rjday + n2 = ntime + 1 + do j=2,ntime + if (rjday < time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + if (n2 > ntime) n2 = n2 - ntime + end subroutine find_photochemistry_index end subroutine GFS_phys_time_vary_timestep_init !! @} diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta index 5dae234ea..9bc9c39b9 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_phys_time_vary.scm.meta @@ -50,6 +50,13 @@ dimensions = () type = logical intent = in +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = in [iccn] standard_name = control_for_ice_cloud_condensation_nuclei_forcing long_name = flag for IN and CCN forcing for morrison gettelman microphysics @@ -1216,6 +1223,13 @@ dimensions = () type = logical intent = in +[iaermdl] + standard_name = control_for_aerosol_radiation_scheme + long_name = control of aerosol scheme in radiation + units = 1 + dimensions = () + type = integer + intent = in [iccn] standard_name = control_for_ice_cloud_condensation_nuclei_forcing long_name = flag for IN and CCN forcing for morrison gettelman microphysics diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 index 37ac9b320..7bb3c7e6d 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.F90 @@ -18,6 +18,7 @@ module GFS_physics_post subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_summed, & dtidx, is_photochem, ldiag3d, ip_physics, ip_photochem, ip_prod_loss, ip_ozmix, & ip_temp, ip_overhead_ozone, do3_dt_prd, do3_dt_ozmx, do3_dt_temp, do3_dt_ohoz, & + ntqv, dqv_dt_prd, dqv_dt_qvmx, & dtend, errmsg, errflg) ! Inputs @@ -25,6 +26,7 @@ subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_ nCol, & !< Horizontal dimension nLev, & !< Number of vertical layers ntoz, & !< Index for ozone mixing ratio + ntqv, & !< Index for water vapor mixing ratio ntracp100, & !< Number of tracers plus 100 nprocess, & !< Number of processes that cause changes in state variables nprocess_summed,& !< Number of causes in dtidx per tracer summed for total physics tendency @@ -46,7 +48,9 @@ subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_ do3_dt_prd, & !< Physics tendency: production and loss effect do3_dt_ozmx, & !< Physics tendency: ozone mixing ratio effect do3_dt_temp, & !< Physics tendency: temperature effect - do3_dt_ohoz !< Physics tendency: overhead ozone effect + do3_dt_ohoz, & !< Physics tendency: overhead ozone effect + dqv_dt_prd, & !< Physics tendency: climatological net production effect + dqv_dt_qvmx !< Physics tendency: water vapor mixing ratio effect ! Outputs real(kind=kind_phys), intent(inout), dimension(:,:,:), optional :: & @@ -104,6 +108,32 @@ subroutine GFS_physics_post_run(nCol, nLev, ntoz, ntracp100, nprocess, nprocess_ call sum_it(ichem, itrac, is_photochem) endif + ! ####################################################################################### + ! + ! Water vapor photochemistry diagnostics + ! + ! ####################################################################################### + idtend = dtidx(100+ntqv, ip_prod_loss) + if (idtend >= 1 .and. associated(dqv_dt_prd)) then + dtend(:, :, idtend) = dtend(:, :, idtend) + dqv_dt_prd + endif + ! + idtend = dtidx(100+ntqv,ip_ozmix) + if (idtend >= 1 .and. associated(dqv_dt_qvmx)) then + dtend(:, :, idtend) = dtend(:, :, idtend) + dqv_dt_qvmx + endif + + ! ####################################################################################### + ! + ! Total photochemical tendencies + ! + ! ####################################################################################### + itrac = ntqv + 100 + ichem = dtidx(itrac, ip_photochem) + if (ichem >= 1) then + call sum_it(ichem, itrac, is_photochem) + endif + ! ####################################################################################### ! ! Total (physics) tendencies diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta index c42da0166..823870a0e 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_physics_post.meta @@ -157,6 +157,31 @@ kind = kind_phys intent = in optional = True +[ntqv] + standard_name = index_of_specific_humidity_in_tracer_concentration_array + long_name = tracer index for water_vapor mixing ratio + units = index + dimensions = () + type = integer + intent = in +[dqv_dt_prd] + standard_name = water_vapor_tendency_due_to_production_and_loss_rate + long_name = water_vapor tendency due to production and loss rate + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = True +[dqv_dt_qvmx] + standard_name = water_vapor_tendency_due_to_water_vapor_mixing_ratio + long_name = water_vapor tendency due to water_vapor mixing ratio + units = kg kg-1 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in + optional = True [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_post.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_post.F90 index cb0093d2e..5c7f300dd 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_post.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_post.F90 @@ -1,6 +1,16 @@ +! ############################################################################################# !> \file GFS_radiation_post.F90 -!! RRTMGP post-processing routine. !! +!! Radiation post-processing routine. +!! +!! This module has two purposes: +!! 1*) Perform coupling from the radiation scheme(s) to other physical parameterizations. +!! 2) Compute diagnostics +!! +!! *For RRTMG, this coupling is handled in the SCHEME. +!! *For RRTMGP, this coupling is handled HERE (more on this below). +!! +! ############################################################################################# module GFS_radiation_post use machine, only: kind_phys use module_radlw_parameters, only: topflw_type, sfcflw_type @@ -12,58 +22,108 @@ module GFS_radiation_post public GFS_radiation_post_run contains - +! ############################################################################################# !> \section arg_table_GFS_radiation_post_run Argument Table !! \htmlinclude GFS_radiation_post_run.html !! -!!The all-sky radiation tendency is computed, the clear-sky tendency is computed -!! if requested. +!! This routine needs to be called AFTER the RRTMG (radlw_main.F90 and radsw_main.F90) +!! or the RRTMGP (rrtmgp_lw_main.F90 and rrtmgp_sw_main.F90) radiaiton schemes in the +!! CCPP enabled UFS. +!! +!! For RRTMG, not much is done here, since the scheme outputs the fields needed by the +!! UFS. For example, RRTMG provides the heating-rate profiles and has been modified to use +!! UFS native DDTs for storing the fluxes. +!! fluxes. !! -!! RRTMGP surface and TOA fluxes are copied to fields that persist between radiation/physics -!! calls. +!! For RRTMGP*: +!! - The all-sky radiation tendency is computed. The clear-sky tendency is computed, if +!! requested. +!! - Surface and TOA fluxes are copied to UFS native DDTs that persist between radiation/physics +!! calls. !! -!! (optional) Save additional diagnostics. - subroutine GFS_radiation_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad, doSWrad, & - do_lw_clrsky_hr, do_sw_clrsky_hr, do_RRTMGP, sfc_alb_nir_dir, & - sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, p_lev, tsfa, & - fluxlwDOWN_clrsky, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, & - fluxswDOWN_clrsky, fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, scmpsw, & - sfcdlw, sfculw, sfcflw, tsflw, htrlw, htrlwu, topflw, nirbmdi, nirdfdi, visbmdi, & - visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, sfcdsw, htrsw, sfcfsw, topfsw, & - htrswc, htrlwc, total_albedo, errmsg, errflg) +!! *Note on RTE-RRTMGP implementation in CCPP +!! This is done in an attempt to make the CCPP enabled RRTMGP LW/SW drivers more host agnostic. +!! The drivers are outputting the same fields as RTE, flux profiles, maintaining the same scheme +!! interface at the lowest CCPP entrypoint, the "Scheme-level" interstitial. Any host specific +!! coupling to the scheme happens here, a layer above, within the "Suite-level" interstitial. +!! +!! For ALL Radiaiton Schemes: +!! - Compute SW total cloud albedo +!! - Compute diagnostics +!! +! ############################################################################################# + + ! ########################################################################################### + ! GFS_radiation_post_run + ! ########################################################################################### + subroutine GFS_radiation_post_run (nCol, nLev, nDay, nfxr, nspc1, iSFC, iTOA, idxday, & + doLWrad, doSWrad, lssav, do_lw_clrsky_hr, do_sw_clrsky_hr, do_RRTMGP, sfc_alb_nir_dir, & + sfc_alb_nir_dif, sfc_alb_uvvis_dir, sfc_alb_uvvis_dif, p_lev, tgrs, tsfa, & + fluxlwDOWN_clrsky, fluxlwUP_allsky, fluxlwDOWN_allsky, fluxlwUP_clrsky, & + fluxswDOWN_clrsky, fluxswUP_allsky, fluxswDOWN_allsky, fluxswUP_clrsky, scmpsw, & + fhlwr, fhswr, coszen, coszdg, raddt, aerodp, cldsa, mtopa, mbota, cldtausw, cldtaulw, & + kb, kd, kt, sfcdlw, sfculw, sfcflw, tsflw, htrlw, htrlwu, topflw, nirbmdi, nirdfdi, & + visbmdi, visdfdi, nirbmui, nirdfui, visbmui, visdfui, sfcnsw, sfcdsw, htrsw, sfcfsw, & + topfsw, htrswc, htrlwc, total_albedo, fluxr, errmsg, errflg) ! Inputs integer, intent(in) :: & nCol, & !< Horizontal loop extent nLev, & !< Number of vertical layers nDay, & !< Number of daylit columns + nfxr, & !< Number of variables stored in the fluxr array + nspc1, & !< Number of species for output aerosol optical depth iSFC, & !< Vertical index for surface level - iTOA !< Vertical index for TOA level + iTOA, & !< Vertical index for TOA level + kb, & !< Vertical index difference between layer and lower bound (H/M/L diag) + kd, & !< Vertical index difference between in/out and local (H/M/L diag) + kt !< Vertical index difference between layer and upper bound (H/M/L diag) integer, intent(in), dimension(:) :: & - idxday ! Index array for daytime points + idxday !< Index array for daytime points logical, intent(in) :: & - doLWrad, & ! Logical flags for lw radiation calls - doSWrad, & ! Logical flags for sw radiation calls - do_lw_clrsky_hr, & ! Output clear-sky LW heating-rate? - do_sw_clrsky_hr, & ! Output clear-sky SW heating-rate? - do_RRTMGP ! Flag for using RRTMGP scheme - real(kind_phys), dimension(:), intent(in) :: & - tsfa, & ! Lowest model layer air temperature for radiation (K) - sfc_alb_nir_dir, & ! Surface albedo (direct) - sfc_alb_nir_dif, & ! Surface albedo (diffuse) - sfc_alb_uvvis_dir, & ! Surface albedo (direct) - sfc_alb_uvvis_dif ! Surface albedo (diffuse) - real(kind_phys), dimension(:,:), intent(in), optional :: & - p_lev, & ! Pressure @ model layer-interfaces (Pa) - fluxlwUP_allsky, & ! RRTMGP longwave all-sky flux (W/m2) - fluxlwDOWN_allsky, & ! RRTMGP longwave all-sky flux (W/m2) - fluxlwUP_clrsky, & ! RRTMGP longwave clear-sky flux (W/m2) - fluxlwDOWN_clrsky, & ! RRTMGP longwave clear-sky flux (W/m2) - fluxswUP_allsky, & ! RRTMGP shortwave all-sky flux (W/m2) - fluxswDOWN_allsky, & ! RRTMGP shortwave all-sky flux (W/m2) - fluxswUP_clrsky, & ! RRTMGP shortwave clear-sky flux (W/m2) - fluxswDOWN_clrsky ! RRTMGP shortwave clear-sky flux (W/m2) - type(cmpfsw_type), dimension(:), intent(in) :: & + doLWrad, & !< Logical flags for lw radiation calls + doSWrad, & !< Logical flags for sw radiation calls + do_lw_clrsky_hr, & !< Output clear-sky LW heating-rate? + do_sw_clrsky_hr, & !< Output clear-sky SW heating-rate? + do_RRTMGP, & !< Flag for using RRTMGP scheme + lssav !< Flag for radiation diagnostics + real(kind_phys), intent(in) :: & + fhlwr, & !< Frequency for longwave radiation (sec) + fhswr, & !< Frequency for shortwave radiation (sec) + raddt !< Radiation time step (sec) + real(kind_phys), dimension(nCol), intent(in) :: & + tsfa, & !< Lowest model layer air temperature for radiation (K) + sfc_alb_nir_dir, & !< Surface albedo (direct) + sfc_alb_nir_dif, & !< Surface albedo (diffuse) + sfc_alb_uvvis_dir, & !< Surface albedo (direct) + sfc_alb_uvvis_dif, & !< Surface albedo (diffuse) + coszen, & !< Mean cos of zenith angle over rad call period + coszdg !< Daytime mean cosz over rad call period + real(kind_phys), dimension(nCol,nLev+1), intent(in) :: & + p_lev !< Pressure @ model layer-interfaces (Pa) + real(kind_phys), dimension(nCol,nLev), intent(in) :: & + tgrs !< Temperature @ model layer-centers (K) + real(kind_phys), dimension(nCol,nLev+1), intent(in), optional :: & + fluxlwUP_allsky, & !< RRTMGP longwave all-sky flux (W/m2) + fluxlwDOWN_allsky, & !< RRTMGP longwave all-sky flux (W/m2) + fluxlwUP_clrsky, & !< RRTMGP longwave clear-sky flux (W/m2) + fluxlwDOWN_clrsky, & !< RRTMGP longwave clear-sky flux (W/m2) + fluxswUP_allsky, & !< RRTMGP shortwave all-sky flux (W/m2) + fluxswDOWN_allsky, & !< RRTMGP shortwave all-sky flux (W/m2) + fluxswUP_clrsky, & !< RRTMGP shortwave clear-sky flux (W/m2) + fluxswDOWN_clrsky !< RRTMGP shortwave clear-sky flux (W/m2) + real(kind_phys), dimension(nCol,nspc1), intent(in) :: & + aerodp !< Vertical integrated optical depth for aerosol species + real(kind_phys), dimension(nCol,nLev), intent(in) :: & + cldtausw, & !< .55mu band layer cloud optical depth (SW) + cldtaulw !< 10mu band layer cloud optical depth (LW) + real(kind_phys), dimension(nCol,5), intent(in) :: & + cldsa !< Fraction of clouds for High/Mid/Low diagnostics: + !< low(1), middle(2), high(3), total(4) and BL(5) + integer, intent(in), dimension(nCol,3) :: & + mtopa, & !< Vertical indices for low, middle and high cloud tops (H/M/L diag) + mbota !< Vertical indices for low, middle and high cloud bases (H/M/L diag) + type(cmpfsw_type), dimension(nCol), intent(in) :: & scmpsw !< 2D surface fluxes, components: !!\n uvbfc - total sky downward uv-b flux at (W/m2) !!\n uvbf0 - clear sky downward uv-b flux at (W/m2) @@ -73,7 +133,7 @@ subroutine GFS_radiation_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad !!\n visdf - downward uv+vis diffused flux (W/m2) ! Outputs (mandatory) - real(kind_phys), dimension(:), intent(inout) :: & + real(kind_phys), dimension(nCol), intent(inout) :: & tsflw, & !< LW sfc air temp during calculation (K) sfcdlw, & !< LW sfc all-sky downward flux (W/m2) sfculw, & !< LW sfc all-sky upward flux (W/m2) @@ -88,20 +148,22 @@ subroutine GFS_radiation_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad sfcnsw, & !< SW sfc all-sky net flux (W/m2) flux into ground sfcdsw !< SW sfc all-sky downward flux (W/m2) real(kind_phys), dimension(:,:), intent(inout) :: & - htrlw, & ! LW all-sky heating rate (K/s) - htrsw ! SW all-sky heating rate (K/s) + htrlw, & !< LW all-sky heating rate (K/s) + htrsw !< SW all-sky heating rate (K/s) real(kind_phys), dimension(nCol), intent(inout) :: & - total_albedo ! Total sky albedo at TOA (W/m2) + total_albedo !< Total sky albedo at TOA (W/m2) real(kind_phys), dimension(:,:), intent(inout), optional :: & htrlwu !< LW all-sky heating-rate updated in-between radiation calls. - type(sfcflw_type), dimension(:), intent(inout) :: & + type(sfcflw_type), dimension(nCol), intent(inout) :: & sfcflw !< LW radiation fluxes at sfc - type(sfcfsw_type), dimension(:), intent(inout) :: & + type(sfcfsw_type), dimension(nCol), intent(inout) :: & sfcfsw !< SW radiation fluxes at sfc type(topfsw_type), dimension(:), intent(inout) :: & topfsw !< SW fluxes at top atmosphere - type(topflw_type), dimension(:), intent(inout) :: & + type(topflw_type), dimension(nCol), intent(inout) :: & topflw !< LW fluxes at top atmosphere + real(kind_phys), dimension(nCol,nfxr), intent(inout) :: & + fluxr !< LW/SW diagnostics character(len=*), intent(out) :: & errmsg !< CCPP error message integer, intent(out) :: & @@ -113,7 +175,7 @@ subroutine GFS_radiation_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad htrswc !< SW clear-sky heating rate (K/s) ! Local variables - integer :: i, j, k, itop, ibtc + integer :: i real(kind_phys) :: tem0d, tem1, tem2 real(kind_phys), dimension(nDay, nLev) :: thetaTendClrSky, thetaTendAllSky @@ -121,14 +183,14 @@ subroutine GFS_radiation_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad errmsg = '' errflg = 0 + ! Only proceed if radiation is being called. if (.not. (doLWrad .or. doSWrad)) return + ! ####################################################################################### + ! Longwave Radiation + ! ####################################################################################### if (doLWRad) then if (do_RRTMGP) then - ! ####################################################################################### - ! Compute LW heating-rates. - ! ####################################################################################### - ! Clear-sky heating-rate (optional) if (do_lw_clrsky_hr) then call check_error_msg('GFS_radiation_post',compute_heating_rate( & @@ -145,12 +207,9 @@ subroutine GFS_radiation_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad p_lev, & ! IN - Pressure @ layer-interfaces (Pa) htrlw)) ! OUT - Longwave all-sky heating rate (K/sec) - ! ####################################################################################### - ! Save LW outputs. ! (Copy fluxes from RRTMGP types into model radiation types.) - ! ####################################################################################### - ! TOA fluxes + ! TOA fluxes topflw(:)%upfxc = fluxlwUP_allsky(:,iTOA) topflw(:)%upfx0 = fluxlwUP_clrsky(:,iTOA) @@ -169,102 +228,249 @@ subroutine GFS_radiation_post_run (nCol, nLev, nDay, iSFC, iTOA, idxday, doLWrad ! Heating-rate at radiation timestep, used for adjustment between radiation calls. htrlwu = htrlw - endif - -! --- The total sky (with clouds) shortwave albedo - total_albedo = 0.0 - where(topfsw(:)%dnfxc>0) total_albedo(:) = topfsw(:)%upfxc/topfsw(:)%dnfxc - endif - ! ####################################################################################### - ! ####################################################################################### - ! ####################################################################################### - ! ####################################################################################### + endif ! RRTMGP Longwave Radiaiton + endif ! ALL Longwave Radiation + ! ####################################################################################### + ! Shortwave Radiation ! ####################################################################################### - if (doSWRad .and. do_RRTMGP) then - if (nDay .gt. 0) then - ! ################################################################################# - ! Compute SW heating-rates - ! ################################################################################# - - ! Clear-sky heating-rate (optional) - if (do_sw_clrsky_hr) then - htrswc(:,:) = 0._kind_phys - call check_error_msg('GFS_radiation_post',compute_heating_rate( & - fluxswUP_clrsky(idxday(1:nDay),:), & ! IN - Shortwave upward clear-sky flux profiles (W/m2) - fluxswDOWN_clrsky(idxday(1:nDay),:), & ! IN - Shortwave downward clear-sky flux profiles (W/m2) - p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) - thetaTendClrSky)) ! OUT - Clear-sky heating-rate (K/sec) - htrswc(idxday(1:nDay),:)=thetaTendClrSky !**NOTE** GP doesn't use radiation levels, it uses the model fields. Not sure if this is necessary - endif - - ! All-sky heating-rate (mandatory) - htrsw(:,:) = 0._kind_phys - call check_error_msg('GFS_radiation_post',compute_heating_rate( & - fluxswUP_allsky(idxday(1:nDay),:), & ! IN - Shortwave upward all-sky flux profiles (W/m2) - fluxswDOWN_allsky(idxday(1:nDay),:), & ! IN - Shortwave downward all-sky flux profiles (W/m2) - p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) - thetaTendAllSky)) ! OUT - All-sky heating-rate (K/sec) - htrsw(idxday(1:nDay),:) = thetaTendAllSky - - ! ################################################################################# - ! Save SW outputs - ! (Copy fluxes from RRTMGP types into model radiation types.) - ! ################################################################################# - - ! TOA fluxes - topfsw(:)%upfxc = fluxswUP_allsky(:,iTOA) - topfsw(:)%upfx0 = fluxswUP_clrsky(:,iTOA) - topfsw(:)%dnfxc = fluxswDOWN_allsky(:,iTOA) + if (doSWRad) then + if (do_RRTMGP) then + if (nDay .gt. 0) then + ! Clear-sky heating-rate (optional) + if (do_sw_clrsky_hr) then + htrswc(:,:) = 0._kind_phys + call check_error_msg('GFS_radiation_post',compute_heating_rate( & + fluxswUP_clrsky(idxday(1:nDay),:), & ! IN - Shortwave upward clear-sky flux profiles (W/m2) + fluxswDOWN_clrsky(idxday(1:nDay),:), & ! IN - Shortwave downward clear-sky flux profiles (W/m2) + p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) + thetaTendClrSky)) ! OUT - Clear-sky heating-rate (K/sec) + htrswc(idxday(1:nDay),:)=thetaTendClrSky !**NOTE** GP doesn't use radiation levels, it uses the model fields. Not sure if this is necessary + endif - ! Surface fluxes - sfcfsw(:)%upfxc = fluxswUP_allsky(:,iSFC) - sfcfsw(:)%upfx0 = fluxswUP_clrsky(:,iSFC) - sfcfsw(:)%dnfxc = fluxswDOWN_allsky(:,iSFC) - sfcfsw(:)%dnfx0 = fluxswDOWN_clrsky(:,iSFC) + ! All-sky heating-rate (mandatory) + htrsw(:,:) = 0._kind_phys + call check_error_msg('GFS_radiation_post',compute_heating_rate( & + fluxswUP_allsky(idxday(1:nDay),:), & ! IN - Shortwave upward all-sky flux profiles (W/m2) + fluxswDOWN_allsky(idxday(1:nDay),:), & ! IN - Shortwave downward all-sky flux profiles (W/m2) + p_lev(idxday(1:nDay),:), & ! IN - Pressure at model-interface (Pa) + thetaTendAllSky)) ! OUT - All-sky heating-rate (K/sec) + htrsw(idxday(1:nDay),:) = thetaTendAllSky + + ! (Copy fluxes from RRTMGP types into model radiation types.) + + ! TOA fluxes + topfsw(:)%upfxc = fluxswUP_allsky(:,iTOA) + topfsw(:)%upfx0 = fluxswUP_clrsky(:,iTOA) + topfsw(:)%dnfxc = fluxswDOWN_allsky(:,iTOA) + + ! Surface fluxes + sfcfsw(:)%upfxc = fluxswUP_allsky(:,iSFC) + sfcfsw(:)%upfx0 = fluxswUP_clrsky(:,iSFC) + sfcfsw(:)%dnfxc = fluxswDOWN_allsky(:,iSFC) + sfcfsw(:)%dnfx0 = fluxswDOWN_clrsky(:,iSFC) + + ! Surface down and up spectral component fluxes + ! - Save two spectral bands' surface downward and upward fluxes for output. + do i=1,nCol + nirbmdi(i) = scmpsw(i)%nirbm + nirdfdi(i) = scmpsw(i)%nirdf + visbmdi(i) = scmpsw(i)%visbm + visdfdi(i) = scmpsw(i)%visdf + nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(i) + nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(i) + visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(i) + visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(i) + enddo + else ! if_nday_block + ! Dark everywhere + htrsw(:,:) = 0.0 + sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) + topfsw = topfsw_type( 0.0, 0.0, 0.0 ) + do i=1,nCol + nirbmdi(i) = 0.0 + nirdfdi(i) = 0.0 + visbmdi(i) = 0.0 + visdfdi(i) = 0.0 + nirbmui(i) = 0.0 + nirdfui(i) = 0.0 + visbmui(i) = 0.0 + visdfui(i) = 0.0 + enddo - ! Surface down and up spectral component fluxes - ! - Save two spectral bands' surface downward and upward fluxes for output. - do i=1,nCol - nirbmdi(i) = scmpsw(i)%nirbm - nirdfdi(i) = scmpsw(i)%nirdf - visbmdi(i) = scmpsw(i)%visbm - visdfdi(i) = scmpsw(i)%visdf - nirbmui(i) = scmpsw(i)%nirbm * sfc_alb_nir_dir(i) - nirdfui(i) = scmpsw(i)%nirdf * sfc_alb_nir_dif(i) - visbmui(i) = scmpsw(i)%visbm * sfc_alb_uvvis_dir(i) - visdfui(i) = scmpsw(i)%visdf * sfc_alb_uvvis_dif(i) - enddo - else ! if_nday_block - ! ################################################################################# - ! Dark everywhere - ! ################################################################################# - htrsw(:,:) = 0.0 - sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) - topfsw = topfsw_type( 0.0, 0.0, 0.0 ) + if (do_sw_clrsky_hr) then + htrswc(:,:) = 0 + endif + endif ! end_if_nday + + ! Radiation fluxes for other physics processes + ! *NOTE* For RRTMG, sfcnsw and sfcdsw are provided. + ! For RRTMGP, we compute them here. do i=1,nCol - nirbmdi(i) = 0.0 - nirdfdi(i) = 0.0 - visbmdi(i) = 0.0 - visdfdi(i) = 0.0 - nirbmui(i) = 0.0 - nirdfui(i) = 0.0 - visbmui(i) = 0.0 - visdfui(i) = 0.0 + sfcnsw(i) = sfcfsw(i)%dnfxc - sfcfsw(i)%upfxc + sfcdsw(i) = sfcfsw(i)%dnfxc enddo + endif ! RRTMGP Shortwave Radiaiton + endif ! ALL Shortwave Radiation + + ! The total sky (with clouds) shortwave albedo + total_albedo = 0.0 + where(topfsw(:)%dnfxc>0) total_albedo(:) = topfsw(:)%upfxc/topfsw(:)%dnfxc + + ! ######################################################################################### + ! Compute radiation diagnostics + ! ######################################################################################### + if (lssav) then + call GFS_radiation_diagnostics(doLWrad, doSWrad, fhlwr, fhswr, coszen, coszdg, raddt, & + aerodp, cldsa, mtopa, mbota, cldtausw, cldtaulw, p_lev, tgrs, kb, kd, kt, sfcflw, & + sfcfsw, topfsw, topflw, scmpsw, nCol, nDay, nLev, nfxr, nspc1, fluxr) + endif + + end subroutine GFS_radiation_post_run + + ! ########################################################################################### + ! GFS_radiation_diagnostics + ! + ! For time averaged output quantities (including total-sky and clear-sky SW and LW fluxes at + ! TOA and surface; conventional 3-domain cloud amount, cloud top and base pressure, and cloud + ! top temperature; aerosols AOD, etc.), store computed results in corresponding slots of + ! array with appropriate time weights. + ! + ! ########################################################################################### + subroutine GFS_radiation_diagnostics(doLWrad, doSWrad, fhlwr, fhswr, coszen, coszdg, raddt, & + aerodp, cldsa, mtopa, mbota, cldtausw, cldtaulw, p_lev, tgrs, kb, kd, kt, sfcflw, & + sfcfsw, topfsw, topflw, scmpsw, nCol, nDay, nLev, nfxr, nspc1, fluxr) + ! Inputs + logical, intent(in) :: doLWrad, doSWrad + integer, intent(in) :: nCol, nLev, nfxr, nspc1, nDay + real(kind_phys), intent(in) :: fhlwr, fhswr, coszen(nCol), coszdg(nCol), raddt + real(kind_phys), intent(in) :: aerodp(nCol,nspc1) + real(kind_phys), intent(in) :: cldtausw(nCol,nLev), cldtaulw(nCol,nLev) + real(kind_phys), intent(in) :: p_lev(nCol,nLev+1), tgrs(nCol,nLev) + type(cmpfsw_type), intent(in) :: scmpsw(nCol) + type(sfcflw_type), intent(in) :: sfcflw(nCol) + type(sfcfsw_type), intent(in) :: sfcfsw(nCol) + type(topfsw_type), intent(in) :: topfsw(nCol) + type(topflw_type), intent(in) :: topflw(nCol) + ! For High/Mid/Low cloud flux diagnsotics + integer, intent(in) :: kb, kd, kt + integer, intent(in) :: mtopa(nCol,3), mbota(nCol,3) + real(kind_phys), intent(in) :: cldsa(nCol,5) + + ! Outputs + real(kind_phys), intent(inout) :: fluxr(nCol,nfxr) + ! Locals + integer :: i, j, k, itop, ibtc + real(kind_phys) :: tem0d, tem1, tem2 + + ! Save LW toa and sfc fluxes + if (doLWrad) then + do i=1,nCol + ! LW total-sky fluxes + fluxr(i,1 ) = fluxr(i,1 ) + fhlwr * topflw(i)%upfxc ! total sky TOA LW up + fluxr(i,19) = fluxr(i,19) + fhlwr * sfcflw(i)%dnfxc ! total sky SFC LW down + fluxr(i,20) = fluxr(i,20) + fhlwr * sfcflw(i)%upfxc ! total sky SFC LW up + ! LW clear-sky fluxes + fluxr(i,28) = fluxr(i,28) + fhlwr * topflw(i)%upfx0 ! clear sky TOA LW up + fluxr(i,30) = fluxr(i,30) + fhlwr * sfcflw(i)%dnfx0 ! clear sky SFC LW down + fluxr(i,33) = fluxr(i,33) + fhlwr * sfcflw(i)%upfx0 ! clear sky SFC LW up + enddo + endif ! END DOLWRAD + + ! Save SW toa and sfc fluxes with proper diurnal sw wgt. coszen=mean cosz over daylight + ! part of sw calling interval, while coszdg= mean cosz over entire interval + if (doSWrad) then + do i=1,nCol + ! Aerosol optical-depths + fluxr(i,34) = aerodp(i,1) ! Total aod at 550nm + fluxr(i,35) = aerodp(i,2) ! Dust aod at 550nm + fluxr(i,36) = aerodp(i,3) ! Soot aod at 550nm + fluxr(i,37) = aerodp(i,4) ! Waso aod at 550nm + fluxr(i,38) = aerodp(i,5) ! Suso aod at 550nm + fluxr(i,39) = aerodp(i,6) ! Salt aod at 550nm - if (do_sw_clrsky_hr) then - htrswc(:,:) = 0 + if (coszen(i) > 0.) then + ! SW total-sky fluxes + tem0d = fhswr * coszdg(i) / coszen(i) + fluxr(i,2 ) = fluxr(i,2) + topfsw(i)%upfxc * tem0d ! total sky TOA SW up + fluxr(i,3 ) = fluxr(i,3) + sfcfsw(i)%upfxc * tem0d ! total sky SFC SW up + fluxr(i,4 ) = fluxr(i,4) + sfcfsw(i)%dnfxc * tem0d ! total sky SFC SW down + ! SW uv-b fluxes + fluxr(i,21) = fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b SW down + fluxr(i,22) = fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b SW down + ! SW toa incoming fluxes + fluxr(i,23) = fluxr(i,23) + topfsw(i)%dnfxc * tem0d ! TOA SW down + ! SW sfc flux components + fluxr(i,24) = fluxr(i,24) + scmpsw(i)%visbm * tem0d ! uv/vis beam SW down + fluxr(i,25) = fluxr(i,25) + scmpsw(i)%visdf * tem0d ! uv/vis diff SW down + fluxr(i,26) = fluxr(i,26) + scmpsw(i)%nirbm * tem0d ! nir beam SW down + fluxr(i,27) = fluxr(i,27) + scmpsw(i)%nirdf * tem0d ! nir diff SW down + ! SW clear-sky fluxes + fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d ! clear sky TOA SW up + fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d ! clear sky SFC SW up + fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d ! clear sky SFC SW down endif - endif ! end_if_nday - - ! Radiation fluxes for other physics processes + enddo + endif ! END DOSWRAD + + ! + ! High/Mid/Low diagnostics + ! + if (doLWrad .or. doSWrad) then + ! Save total and boundary layer clouds do i=1,nCol - sfcnsw(i) = sfcfsw(i)%dnfxc - sfcfsw(i)%upfxc - sfcdsw(i) = sfcfsw(i)%dnfxc + fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) + fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) enddo - - endif - end subroutine GFS_radiation_post_run + ! Save cld frac,toplyr,botlyr and top temp, note that the order + ! of h,m,l cloud is reversed for the fluxr output. + ! save interface pressure (pa) of top/bot + do j = 1, 3 + do i = 1, nCol + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) - kd + ibtc = mbota(i,j) - kd + fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d + fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop+kt) + fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc+kb) + fluxr(i,17-j) = fluxr(i,17-j) + tem0d * tgrs(i,itop) + enddo + enddo + + ! In-cloud (shortwave) optical depth at approx .55 um channel + if (doSWrad .and. (nDay > 0)) then + do j = 1, 3 + do i = 1, nCol + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) - kd + ibtc = mbota(i,j) - kd + tem1 = 0. + do k=ibtc,itop + tem1 = tem1 + cldtausw(i,k) + enddo + fluxr(i,43-j) = fluxr(i,43-j) + tem0d * tem1 + enddo + enddo + endif ! END DOSWRAD + + ! In-cloud (longwave) optical depth at approx 10. um channel + if (doLWrad) then + do j = 1, 3 + do i = 1, nCol + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) - kd + ibtc = mbota(i,j) - kd + tem2 = 0. + do k=ibtc,itop + tem2 = tem2 + cldtaulw(i,k) + enddo + fluxr(i,46-j) = fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) + enddo + enddo + endif ! END DOLWRAD + endif ! END DOSWRAD OR DOLWRAD + + end subroutine GFS_radiation_diagnostics + end module GFS_radiation_post diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_post.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_post.meta index 9dad5ff3c..7820a59eb 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_post.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_radiation_post.meta @@ -23,6 +23,20 @@ dimensions = () type = integer intent = in +[nfxr] + standard_name = number_of_diagnostics_variables_for_radiation + long_name = number of variables stored in the fluxr array + units = count + dimensions = () + type = integer + intent = in +[nspc1] + standard_name = number_of_species_for_aerosol_optical_depth + long_name = number of species for output aerosol optical depth plus total + units = count + dimensions = () + type = integer + intent = in [iSFC] standard_name = vertical_index_for_surface_in_RRTMGP long_name = index for surface layer in RRTMGP @@ -86,6 +100,13 @@ dimensions = () type = logical intent = in +[lssav] + standard_name = flag_for_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in [sfc_alb_nir_dir] standard_name = surface_albedo_due_to_near_IR_direct long_name = surface albedo due to near IR direct beam @@ -127,14 +148,21 @@ kind = kind_phys intent = in [p_lev] - standard_name = air_pressure_at_interface_for_RRTMGP + standard_name = air_pressure_at_interface long_name = air pressure level units = Pa dimensions = (horizontal_loop_extent,vertical_interface_dimension) type = real kind = kind_phys intent = in - optional = True +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [fluxlwUP_allsky] standard_name = RRTMGP_lw_flux_profile_upward_allsky long_name = RRTMGP upward longwave all-sky flux profile @@ -214,6 +242,113 @@ dimensions = (horizontal_loop_extent) type = cmpfsw_type intent = in +[fhlwr] + standard_name = period_of_longwave_radiation_calls + long_name = frequency for longwave radiation + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[fhswr] + standard_name = period_of_shortwave_radiation_calls + long_name = frequency for shortwave radiation + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[coszen] + standard_name = cosine_of_solar_zenith_angle_for_daytime_points_on_radiation_timestep + long_name = mean cos of zenith angle over rad call period + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[coszdg] + standard_name = cosine_of_solar_zenith_angle_on_radiation_timestep + long_name = daytime mean cosz over rad call period + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[raddt] + standard_name = time_step_for_radiation + long_name = radiation time step + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[aerodp] + standard_name = atmosphere_optical_thickness_due_to_ambient_aerosol_particles + long_name = vertical integrated optical depth for various aerosol species + units = none + dimensions = (horizontal_loop_extent,number_of_species_for_aerosol_optical_depth) + type = real + kind = kind_phys + intent = in +[cldsa] + standard_name = cloud_area_fraction_for_radiation + long_name = fraction of clouds for low, middle, high, total and BL + units = frac + dimensions = (horizontal_loop_extent,5) + type = real + kind = kind_phys + intent = in +[mtopa] + standard_name = model_layer_number_at_cloud_top + long_name = vertical indices for low, middle and high cloud tops + units = index + dimensions = (horizontal_loop_extent,3) + type = integer + intent = in +[mbota] + standard_name = model_layer_number_at_cloud_base + long_name = vertical indices for low, middle and high cloud bases + units = index + dimensions = (horizontal_loop_extent,3) + type = integer + intent = in +[cldtaulw] + standard_name = cloud_optical_depth_layers_at_10mu_band + long_name = approx 10mu band layer cloud optical depth + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[cldtausw] + standard_name = cloud_optical_depth_layers_at_0p55mu_band + long_name = approx .55mu band layer cloud optical depth + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[kb] + standard_name = vertical_index_difference_between_layer_and_lower_bound + long_name = vertical index difference between layer and lower bound + units = index + dimensions = () + type = integer + intent = in +[kd] + standard_name = vertical_index_difference_between_inout_and_local + long_name = vertical index difference between in/out and local + units = index + dimensions = () + type = integer + intent = in +[kt] + standard_name = vertical_index_difference_between_layer_and_upper_bound + long_name = vertical index difference between layer and upper bound + units = index + dimensions = () + type = integer + intent = in [sfcdlw] standard_name = surface_downwelling_longwave_flux_on_radiation_timestep long_name = total sky sfc downward lw flux @@ -379,6 +514,7 @@ type = real kind = kind_phys intent = inout + optional = True [htrlwc] standard_name = tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky_on_radiation_timestep long_name = longwave clear sky heating rate @@ -387,6 +523,7 @@ type = real kind = kind_phys intent = inout + optional = True [total_albedo] standard_name = total_sky_albedo long_name = total sky albedo at toa @@ -395,6 +532,14 @@ type = real kind = kind_phys intent = inout +[fluxr] + standard_name = cumulative_radiation_diagnostic + long_name = time-accumulated 2D radiation-related diagnostic fields + units = mixed + dimensions = (horizontal_loop_extent,number_of_diagnostics_variables_for_radiation) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 index 3ed7547dc..b7f69ca7a 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.F90 @@ -26,7 +26,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& ntdu1, ntdu2, ntdu3, ntdu4, ntdu5, ntss1, ntss2, & ntss3, ntss4, ntss5, ntsu, ntbcb, ntbcl, ntocb, ntocl, ntchm, & imp_physics,imp_physics_nssl, nssl_ccn_on, nssl_invertccn, & - imp_physics_thompson, imp_physics_gfdl, imp_physics_zhao_carr, & + imp_physics_thompson, imp_physics_tempo, imp_physics_gfdl, & + imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, imp_physics_mg, imp_physics_wsm6, & imp_physics_fer_hires, iovr, iovr_rand, iovr_maxrand, iovr_max, & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, idcor_hogan, & @@ -45,7 +46,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& gasvmr_ccl4, gasvmr_cfc113, aerodp,ext550, clouds6, clouds7, clouds8, & clouds9, cldsa, cldfra, cldfra2d, lwp_ex,iwp_ex, lwp_fc,iwp_fc, & faersw1, faersw2, faersw3, faerlw1, faerlw2, faerlw3, alpha, rrfs_sd, & - aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, ozphys, & + aero_dir_fdb, fdb_coef, spp_wts_rad, spp_rad, ico2, ozphys, tempo_cfg, & errmsg, errflg) use machine, only: kind_phys @@ -72,15 +73,37 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& use surface_perturbation, only: cdfnor,ppfbet ! For Thompson MP - use module_mp_thompson, only: calc_effectRad, & - Nt_c_l, Nt_c_o, & - re_qc_min, re_qc_max, & - re_qi_min, re_qi_max, & - re_qs_min, re_qs_max + use module_mp_thompson, only: calc_effectRad_thmpsn => calc_effectRad, & + Nt_c_l_thmpsn => Nt_c_l, & + Nt_c_o_thmpsn => Nt_c_o, & + re_qc_min_thmpsn => re_qc_min, & + re_qc_max_thmpsn => re_qc_max, & + re_qi_min_thmpsn => re_qi_min, & + re_qi_max_thmpsn => re_qi_max, & + re_qs_min_thmpsn => re_qs_min, & + re_qs_max_thmpsn => re_qs_max use module_mp_thompson_make_number_concentrations, only: & - make_IceNumber, & - make_DropletNumber, & - make_RainNumber + make_IceNumber_thmpsn => make_IceNumber, & + make_DropletNumber_thmpsn => make_DropletNumber, & + make_RainNumber_thmpsn => make_RainNumber + + use module_mp_tempo_params, only: & + ty_tempo_cfg, & + Nt_c_l_tempo => Nt_c_l, & + Nt_c_o_tempo => Nt_c_o, & + re_qc_min_tempo => re_qc_min, & + re_qc_max_tempo => re_qc_max, & + re_qi_min_tempo => re_qi_min, & + re_qi_max_tempo => re_qi_max, & + re_qs_min_tempo => re_qs_min, & + re_qs_max_tempo => re_qs_max + + use module_mp_tempo_utils, only: & + calc_effectRad_tempo => calc_effectRad, & + make_IceNumber_tempo => make_IceNumber, & + make_DropletNumber_tempo => make_DropletNumber, & + make_RainNumber_tempo => make_RainNumber + ! For NRL Ozone use module_ozphys, only: ty_ozphys implicit none @@ -98,6 +121,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& lndp_type, & kdt, imp_physics, & imp_physics_thompson, & + imp_physics_tempo, & imp_physics_gfdl, & imp_physics_zhao_carr, & imp_physics_zhao_carr_pdf, & @@ -235,6 +259,9 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& real (kind=kind_phys), dimension(lm) :: cldfra1d, qv1d, & & qc1d, qi1d, qs1d, dz1d, p1d, t1d + ! For TEMPO MP + type(ty_tempo_cfg), intent(in) :: tempo_cfg + ! for F-A MP real(kind=kind_phys), dimension(im,lm+LTP+1) :: tem2db, hz @@ -276,7 +303,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& LP1 = LM + 1 ! num of in/out levels - if (imp_physics == imp_physics_thompson) then + if (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_tempo) then max_relh = 1.5 else max_relh = 1.1 @@ -737,7 +764,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& enddo enddo ! for Thompson MP - prepare variables for calc_effr - if_thompson: if (imp_physics == imp_physics_thompson .and. (ltaerosol .or. mraerosol)) then + if_thompson: if ((imp_physics == imp_physics_thompson .or. & + imp_physics == imp_physics_tempo) .and. (ltaerosol .or. mraerosol)) then do k=1,LMK do i=1,IM qvs = qlyr(i,k) @@ -752,7 +780,7 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& nwfa (i,k) = tracer1(i,k,ntwa) enddo enddo - elseif (imp_physics == imp_physics_thompson) then + elseif (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_tempo) then do k=1,LMK do i=1,IM qvs = qlyr(i,k) @@ -763,9 +791,17 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) if(nint(slmsk(i)) == 1) then - nc_mp (i,k) = Nt_c_l*orho(i,k) + if (imp_physics == imp_physics_thompson) then + nc_mp (i,k) = Nt_c_l_thmpsn*orho(i,k) + else + nc_mp (i,k) = Nt_c_l_tempo*orho(i,k) + endif else - nc_mp (i,k) = Nt_c_o*orho(i,k) + if (imp_physics == imp_physics_thompson) then + nc_mp (i,k) = Nt_c_o_thmpsn*orho(i,k) + else + nc_mp (i,k) = Nt_c_o_tempo*orho(i,k) + endif endif ni_mp (i,k) = tracer1(i,k,ntinc)/(1.-qvs) enddo @@ -878,18 +914,26 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& ! not used yet -- effr_in should always be true for now endif - elseif (imp_physics == imp_physics_thompson) then ! Thompson MP + elseif (imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_tempo) then ! Thompson MP ! ! Compute effective radii for QC, QI, QS with (GF, MYNN) or without (all others) sub-grid clouds ! ! Update number concentration, consistent with sub-grid clouds (GF, MYNN) or without (all others) do k=1,lm do i=1,im - if ((ltaerosol .or. mraerosol) .and. qc_mp(i,k)>1.e-12 .and. nc_mp(i,k)<100.) then - nc_mp(i,k) = make_DropletNumber(qc_mp(i,k)*rho(i,k), nwfa(i,k)*rho(i,k)) * orho(i,k) + if ((ltaerosol .or. mraerosol) .and. qc_mp(i,k)>1.e-12 .and. nc_mp(i,k)<100.) then + if (imp_physics == imp_physics_thompson) then + nc_mp(i,k) = make_DropletNumber_thmpsn(qc_mp(i,k)*rho(i,k), nwfa(i,k)*rho(i,k)) * orho(i,k) + else + nc_mp(i,k) = make_DropletNumber_tempo(qc_mp(i,k)*rho(i,k), nwfa(i,k)*rho(i,k)) * orho(i,k) + endif endif if (qi_mp(i,k)>1.e-12 .and. ni_mp(i,k)<100.) then - ni_mp(i,k) = make_IceNumber(qi_mp(i,k)*rho(i,k), tlyr(i,k)) * orho(i,k) + if (imp_physics == imp_physics_thompson) then + ni_mp(i,k) = make_IceNumber_thmpsn(qi_mp(i,k)*rho(i,k), tlyr(i,k)) * orho(i,k) + else + ni_mp(i,k) = make_IceNumber_tempo(qi_mp(i,k)*rho(i,k), tlyr(i,k)) * orho(i,k) + endif endif end do end do @@ -900,18 +944,36 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& !tgs: progclduni has different limits for ice radii (10.0-150.0) than ! calc_effectRad (4.99-125.0 for WRFv3.8.1; 2.49-125.0 for WRFv4+) ! it will raise the low limit from 5 to 10, but the high limit will remain 125. - call calc_effectRad (tlyr(i,:), plyr(i,:)*100., qv_mp(i,:), qc_mp(i,:), & - nc_mp(i,:), qi_mp(i,:), ni_mp(i,:), qs_mp(i,:), & - effrl(i,:), effri(i,:), effrs(i,:), islmsk, 1, lm ) - ! Scale Thompson's effective radii from meter to micron - do k=1,lm - effrl(i,k) = MAX(re_qc_min, MIN(effrl(i,k), re_qc_max))*1.e6 - effri(i,k) = MAX(re_qi_min, MIN(effri(i,k), re_qi_max))*1.e6 - effrs(i,k) = MAX(re_qs_min, MIN(effrs(i,k), re_qs_max))*1.e6 - end do - effrl(i,lmk) = re_qc_min*1.e6 - effri(i,lmk) = re_qi_min*1.e6 - effrs(i,lmk) = re_qs_min*1.e6 + + if (imp_physics == imp_physics_thompson) then + call calc_effectRad_thmpsn(tlyr(i,:), plyr(i,:)*100., qv_mp(i,:), qc_mp(i,:), & + nc_mp(i,:), qi_mp(i,:), ni_mp(i,:), qs_mp(i,:), & + effrl(i,:), effri(i,:), effrs(i,:), islmsk, 1, lm ) + ! Scale Thompson's effective radii from meter to micron + do k=1,lm + effrl(i,k) = MAX(re_qc_min_thmpsn, MIN(effrl(i,k), re_qc_max_thmpsn))*1.e6 + effri(i,k) = MAX(re_qi_min_thmpsn, MIN(effri(i,k), re_qi_max_thmpsn))*1.e6 + effrs(i,k) = MAX(re_qs_min_thmpsn, MIN(effrs(i,k), re_qs_max_thmpsn))*1.e6 + end do + effrl(i,lmk) = re_qc_min_thmpsn*1.e6 + effri(i,lmk) = re_qi_min_thmpsn*1.e6 + effrs(i,lmk) = re_qs_min_thmpsn*1.e6 + else + call calc_effectRad_tempo(t1d=tlyr(i,:), p1d=plyr(i,:)*100., qv1d=qv_mp(i,:), qc1d=qc_mp(i,:), & + nc1d=nc_mp(i,:), qi1d=qi_mp(i,:), ni1d=ni_mp(i,:), qs1d=qs_mp(i,:), & + re_qc1d=effrl(i,:), re_qi1d=effri(i,:), re_qs1d=effrs(i,:), kts=1, kte=lm, & + lsml=islmsk, configs=tempo_cfg) + ! Scale Thompson's effective radii from meter to micron + do k=1,lm + effrl(i,k) = MAX(re_qc_min_tempo, MIN(effrl(i,k), re_qc_max_tempo))*1.e6 + effri(i,k) = MAX(re_qi_min_tempo, MIN(effri(i,k), re_qi_max_tempo))*1.e6 + effrs(i,k) = MAX(re_qs_min_tempo, MIN(effrs(i,k), re_qs_max_tempo))*1.e6 + end do + effrl(i,lmk) = re_qc_min_tempo*1.e6 + effri(i,lmk) = re_qi_min_tempo*1.e6 + effrs(i,lmk) = re_qs_min_tempo*1.e6 + endif + end do effrr(:,:) = 1000. ! rrain_def=1000. ! Update global arrays @@ -976,7 +1038,8 @@ subroutine GFS_rrtmg_pre_run (im, levs, lm, lmk, lmp, n_var_lndp, lextop,& & deltaq, sup, dcorr_con, me, icloud, kdt, & & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & - & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_gfdl, imp_physics_thompson, & + & imp_physics_wsm6, imp_physics_tempo, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta index a0981c833..2be1e570e 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_pre.meta @@ -3,7 +3,8 @@ type = scheme relative_path = ../../ dependencies = tools/funcphys.f90,hooks/machine.F - dependencies = MP/module_mp_radar.F90,MP/Thompson/module_mp_thompson.F90,MP/Thompson/module_mp_thompson_make_number_concentrations.F90 + dependencies = MP/TEMPO/TEMPO/module_mp_tempo_params.F90,MP/TEMPO/TEMPO/module_mp_tempo_utils.F90 + dependencies = MP/Thompson/module_mp_thompson.F90,MP/Thompson/module_mp_thompson_make_number_concentrations.F90 dependencies = Radiation/RRTMG/radcons.f90,Radiation/radiation_aerosols.f dependencies = Radiation/radiation_astronomy.f,Radiation/radiation_clouds.f,Radiation/radiation_gases.f dependencies = Radiation/RRTMG/radlw_param.f,Radiation/RRTMG/radsw_param.f,Radiation/radiation_cloud_overlap.F90 @@ -266,6 +267,13 @@ dimensions = () type = ty_ozphys intent = in +[tempo_cfg] + standard_name = configuration_for_TEMPO_microphysics + long_name = configuration information for TEMPO microphysics + units = mixed + dimensions = () + type = ty_tempo_cfg + intent = in [iaermdl] standard_name = control_for_aerosol_radiation_scheme long_name = control of aerosol scheme in radiation @@ -469,6 +477,13 @@ dimensions = () type = integer intent = in +[imp_physics_tempo] + standard_name = identifier_for_tempo_microphysics_scheme + long_name = choice of TEMPO microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [imp_physics_gfdl] standard_name = identifier_for_gfdl_microphysics_scheme long_name = choice of GFDL microphysics scheme diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 index cc8e950e8..804638f8a 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmg_setup.F90 @@ -184,12 +184,6 @@ subroutine GFS_rrtmg_setup_init ( si, levr, ictm, isol, solar_file, ico2, & iaerflg = mod(iaer, 1000) endif iaermdl = iaer/1000 ! control flag for aerosol scheme selection - if ( iaermdl < 0 .or. (iaermdl>2 .and. iaermdl/=5) ) then - print *, ' Error -- IAER flag is incorrect, Abort' - errflg = 1 - errmsg = 'ERROR(GFS_rrtmg_setup): IAER flag is incorrect' - return - endif ! --- assign initial permutation seed for mcica cloud-radiation if ( isubcsw>0 .or. isubclw>0 ) then diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 index 0ed936410..7c95d726d 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_rrtmgp_setup.F90 @@ -88,11 +88,6 @@ subroutine GFS_rrtmgp_setup_init(do_RRTMGP, imp_physics, imp_physics_fer_hires, iaerflg = mod(iaer, 1000) endif iaermdl = iaer/1000 ! control flag for aerosol scheme selection - if ( iaermdl < 0 .or. (iaermdl>2 .and. iaermdl/=5) ) then - errmsg = trim(errmsg) // ' Error -- IAER flag is incorrect, Abort' - errflg = 1 - return - endif ! Assign initial permutation seed for mcica cloud-radiation if ( isubc_sw>0 .or. isubc_lw>0 ) then diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.F90 index d5278bd42..b3d59c095 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.F90 @@ -20,7 +20,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, dtidx, ntlnc, & imp_physics_wsm6, imp_physics_fer_hires, prsi, ntinc, & - imp_physics_nssl, & + imp_physics_nssl, imp_physics_tempo, & prsl, prslk, rhcbot,rhcpbl, rhctop, rhcmax, islmsk, & work1, work2, kpbl, kinver, ras, me, save_lnc, save_inc, & ldiag3d, qdiag3d, index_of_process_conv_trans, & @@ -35,7 +35,7 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & integer, intent(in ) :: im, levs, nn, ntrac, ntcw, ntiw, ntclamt, ntrw, ntsw,& ntrnc, ntsnc, ntgl, ntgnc, imp_physics, imp_physics_mg, imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6,imp_physics_fer_hires, & - imp_physics_nssl, me, index_of_process_conv_trans + imp_physics_nssl, imp_physics_tempo, me, index_of_process_conv_trans integer, intent(in ), dimension(:) :: islmsk, kpbl, kinver logical, intent(in ) :: cscnv, satmedmf, trans_trac, do_shoc, ltaerosol, ras, progsigma logical, intent(in ) :: first_time_step, restart, progomega @@ -206,7 +206,8 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & enddo elseif (imp_physics == imp_physics_gfdl) then clw(1:im,:,1) = gq0(1:im,:,ntcw) - elseif (imp_physics == imp_physics_thompson) then + elseif (imp_physics == imp_physics_thompson .or. & + imp_physics == imp_physics_tempo) then do k=1,levs do i=1,im clw(i,k,1) = gq0(i,k,ntiw) ! ice @@ -238,7 +239,8 @@ subroutine GFS_suite_interstitial_3_run (otsptflag, & enddo endif - if(imp_physics == imp_physics_thompson .and. ldiag3d .and. qdiag3d) then + if((imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_tempo) & + .and. ldiag3d .and. qdiag3d) then if(dtidx(100+ntlnc,index_of_process_conv_trans)>0) then save_lnc = gq0(:,:,ntlnc) endif diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta index c79182679..4cf339e4d 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_3.meta @@ -273,7 +273,7 @@ [omegain] standard_name = prognostic_updraft_velocity_in_convection long_name = convective updraft velocity - units = frac + units = Pa s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys @@ -282,11 +282,11 @@ [omegaout] standard_name = updraft_velocity_updated_by_physics long_name = convective updraft velocity updated by physics - units = frac + units = Pa s-1 dimensions = (horizontal_loop_extent,vertical_layer_dimension) type = real kind = kind_phys - intent = out + intent = inout optional = True [imp_physics] standard_name = control_for_microphysics_scheme @@ -330,6 +330,13 @@ dimensions = () type = integer intent = in +[imp_physics_tempo] + standard_name = identifier_for_tempo_microphysics_scheme + long_name = choice of TEMPO microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [imp_physics_wsm6] standard_name = identifier_for_wsm6_microphysics_scheme long_name = choice of WSM6 microphysics scheme diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.F90 index d1aadb731..635360af2 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.F90 @@ -10,13 +10,19 @@ module GFS_suite_interstitial_4 !! subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntrac, ntcw, ntiw, ntclamt, & ntrw, ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_nssl, nssl_invertccn, nssl_ccn_on, & + imp_physics_nssl, imp_physics_tempo, nssl_invertccn, nssl_ccn_on, & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, convert_dry_rho, dtf, save_qc, save_qi, con_pi, dtidx, dtend,& index_of_process_conv_trans, gq0, clw, prsl, save_tcp, con_rd, con_eps, nssl_cccn, nwfa, spechum, ldiag3d, & qdiag3d, save_lnc, save_inc, ntk, ntke, otsptflag, errmsg, errflg) use machine, only: kind_phys - use module_mp_thompson_make_number_concentrations, only: make_IceNumber, make_DropletNumber + use module_mp_thompson_make_number_concentrations, only: & + make_IceNumber_thmpsn => make_IceNumber, & + make_DropletNumber_thmpsn => make_DropletNumber + + use module_mp_tempo_utils, only: & + make_IceNumber_tempo => make_IceNumber, & + make_DropletNumber_tempo => make_DropletNumber implicit none @@ -25,7 +31,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr logical, intent(in) :: otsptflag(:)! on/off switch for tracer transport by updraft and integer, intent(in ) :: im, levs, tracers_total, ntrac, ntcw, ntiw, ntclamt, ntrw, & ntsw, ntrnc, ntsnc, ntgl, ntgnc, ntlnc, ntinc, ntccn, nn, imp_physics, imp_physics_gfdl, imp_physics_thompson, & - imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl + imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, imp_physics_nssl, imp_physics_tempo logical, intent(in) :: ltaerosol, convert_dry_rho logical, intent(in) :: nssl_ccn_on, nssl_invertccn @@ -211,7 +217,8 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr enddo endif - if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then + if ((imp_physics == imp_physics_thompson .or. imp_physics == imp_physics_tempo) .and. & + (ntlnc>0 .or. ntinc>0)) then if_convert_dry_rho: if (convert_dry_rho) then do k=1,levs do i=1,im @@ -225,7 +232,11 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry nc_mp(i,k) = gq0(i,k,ntlnc) / (one-spechum(i,k)) - nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + if (imp_physics == imp_physics_thompson) then + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber_thmpsn(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + else + nc_mp(i,k) = max(zero, nc_mp(i,k) + make_DropletNumber_tempo(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + endif !> - Convert number concentrations from dry to moist gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) endif @@ -233,8 +244,12 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr !> - Convert moist mixing ratio to dry mixing ratio qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) / (one-spechum(i,k)) !> - Convert number concentration from moist to dry - ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) - ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + ni_mp(i,k) = gq0(i,k,ntinc) / (one-spechum(i,k)) + if (imp_physics == imp_physics_thompson) then + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber_thmpsn(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + else + ni_mp(i,k) = max(zero, ni_mp(i,k) + make_IceNumber_tempo(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + endif !> - Convert number concentrations from dry to moist gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) endif @@ -250,13 +265,21 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, tracers_total, ntr !> - Update cloud water mixing ratio qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k)) !> - Update cloud water number concentration - gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + if (imp_physics == imp_physics_thompson) then + gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber_thmpsn(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + else + gq0(i,k,ntlnc) = max(zero, gq0(i,k,ntlnc) + make_DropletNumber_tempo(qc_mp(i,k) * rho, nwfa(i,k)*rho) * orho) + endif endif if (ntinc>0) then !> - Update cloud ice mixing ratio qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k)) !> - Update cloud ice number concentration - gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + if (imp_physics == imp_physics_thompson) then + gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber_thmpsn(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + else + gq0(i,k,ntinc) = max(zero, gq0(i,k,ntinc) + make_IceNumber_tempo(qi_mp(i,k) * rho, save_tcp(i,k)) * orho) + endif endif enddo enddo diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta index c6a330ccb..dff0375b2 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/GFS_suite_interstitial_4.meta @@ -4,6 +4,7 @@ type = scheme relative_path = ../../ dependencies = hooks/machine.F + dependencies = MP/TEMPO/TEMPO/module_mp_tempo_utils.F90 dependencies = MP/Thompson/module_mp_thompson_make_number_concentrations.F90 ######################################################################## @@ -157,6 +158,13 @@ dimensions = () type = integer intent = in +[imp_physics_tempo] + standard_name = identifier_for_tempo_microphysics_scheme + long_name = choice of TEMPO microphysics scheme + units = flag + dimensions = () + type = integer + intent = in [imp_physics_zhao_carr] standard_name = identifier_for_zhao_carr_microphysics_scheme long_name = choice of Zhao-Carr microphysics scheme diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.f b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.f index dcb46a3fb..749f778c1 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.f +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.f @@ -88,40 +88,6 @@ module dcyc2t3 ! levs - integer, vertical layer dimension ! ! deltim - real, physics time step in seconds ! ! fhswr - real, Short wave radiation time step in seconds ! -! fhlwr - real, Long wave radiation time step in seconds ! -! lslwr - logical, flag for sw radiation calls ! -! fluxr (im, nfxr) - real, time-accum 2d rad diag fields ! -! topflw (im) - topfsw_type, lw radiation fluxes at toa ! -! sfcflw (im) - sfcflw_type, lw radiation fluxes at sfc ! -! lsswr - logical, flag for lw radiation calls ! -! coszdg - real, Cosine(SZA), daytime ! -! topfsw (im) - topfsw_type, sw radiation fluxes at TOA ! -! sfcfsw (im) - sfcfsw_type, sw radiation fluxes at sfc ! -! scmpsw (im) - cmpfsw_type, special components of sw down fluxes ! -! raddt - real, radiation timestep ! -! cldsa (im,5) - real, frac of clouds in low, mid, high, total, BL ! -! mtopa (im,3) - integer, Vertical indices for low, middle and high ! -! cloud bases ! -! mbota (im,3) - integer, Vertical indices for low, middle and high ! -! cloud tops ! -! cldtausw (im, im+LTP) - real, approx .55mu band layer cloud ! -! optical depth ! -! cldtaulw (im, im+LTP) - real, approx 10 mu band layer cloud ! -! optical depth ! -! tgrs (im,levs) - real, model layer mean temperature ! -! aerodp (im, nspc1) - real, Vertical integrated optical depth for ! -! various aerosol species ! -! nfxr - integer, num variables stored in fluxr array ! -! lm - integer, number vertical layers for rad calc ! -! ltp - integer, extra top layers ! -! nday - integer, daytime points dimension ! -! kb - integer, vertical index diff. b/w layer and lower ! -! bound ! -! kd - integer, vertical index diff. b/w in/out and local ! -! kt - integer, vertical index diff. b/w in/out and upper ! -! bound -! lssav - logical, flag for storing radiation diagnostics ! -! nspc1 - logical, num. species for optical dept plus total ! ! dry - logical, true over land ! ! icy - logical, true over ice ! ! wet - logical, true over water ! @@ -194,8 +160,6 @@ module dcyc2t3 !!- Mar 2019 s. moorthi - modify xmu calculation in a time centered !! way and add more accuracy when physics !! time step is close to radiation time step -!!- Dec 2024 l. reames - move fluxr calculations from *_post -!! routines to dcyc3t3_run !> \section arg_table_dcyc2t3_run Argument Table !! \htmlinclude dcyc2t3_run.html !! @@ -215,9 +179,6 @@ subroutine dcyc2t3_run & & use_LW_jacobian, sfculw, use_med_flux, sfculw_med, & & fluxlwUP_jac, t_lay, p_lay, p_lev, flux2D_lwUP, & & flux2D_lwDOWN,pert_radtend,do_sppt,ca_global,tsfc_radtime, & - & lslwr,fluxr,fhlwr,topflw,sfcflw,lsswr,coszdg,topfsw,sfcfsw,& - & scmpsw,raddt,cldsa,mtopa,mbota,cldtausw,cldtaulw,tgrs, & - & aerodp, nfxr, lm, ltp, nday, kb, kd , kt, lssav, nspc1, & ! & dry, icy, wet, lprnt, ipr, & ! --- input/output: & dtdt,dtdtnp,htrlw, & @@ -230,11 +191,7 @@ subroutine dcyc2t3_run & & ) ! use machine, only : kind_phys - use module_radsw_parameters, only: topfsw_type, & - & sfcfsw_type, & - & cmpfsw_type - use module_radlw_parameters, only: topflw_type, & - & sfcflw_type + implicit none ! ! --- constant parameters: @@ -246,13 +203,13 @@ subroutine dcyc2t3_run & & czlimt = 0.0001_kind_phys ! ~ cos(89.99427) ! --- inputs: - integer, intent(in) :: im, kb, kd, kt, levs, nday, nspc1 + integer, intent(in) :: im, levs ! integer, intent(in) :: ipr ! logical lprnt logical, dimension(:), intent(in) :: dry, icy, wet logical, intent(in) :: use_LW_jacobian, damp_LW_fluxadj, & - & pert_radtend, use_med_flux, lssav + & pert_radtend, use_med_flux logical, intent(in) :: do_sppt,ca_global real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec, & & deltim, fhswr, lfnc_k, lfnc_p0 @@ -281,34 +238,13 @@ subroutine dcyc2t3_run & & con_pi, con_sbc real(kind_phys) :: pid12 - - logical, intent(in) :: lsswr, lslwr - real(kind=kind_phys), intent(in) :: raddt, fhlwr - integer, intent(in) :: lm, ltp, nfxr - real(kind=kind_phys), dimension(im), intent(in) :: coszdg - - real(kind=kind_phys), dimension(im,5), intent(in) :: cldsa - integer, dimension(im,3), intent(in) :: mbota - integer, dimension(im,3), intent(in) :: mtopa - - real(kind=kind_phys), dimension(im,lm+LTP),intent(in) :: cldtausw - real(kind=kind_phys), dimension(im,lm+LTP),intent(in) :: cldtaulw - - real(kind=kind_phys), dimension(im,levs), intent(in) :: tgrs - - type(sfcflw_type), dimension(im), intent(in) :: sfcflw - type(sfcfsw_type), dimension(im), intent(in) :: sfcfsw - type(cmpfsw_type), dimension(im), intent(in) :: scmpsw - type(topflw_type), dimension(im), intent(in) :: topflw - type(topfsw_type), dimension(im), intent(in) :: topfsw - - real(kind=kind_phys), dimension(im,NSPC1), intent(in) :: aerodp + ! --- input/output: real(kind=kind_phys), dimension(:,:), intent(inout) :: dtdt real(kind=kind_phys), dimension(:,:), intent(inout), optional :: & & dtdtnp, htrlw - real(kind=kind_phys), dimension(im,nfxr), intent(inout) :: fluxr + ! --- outputs: real(kind=kind_phys), dimension(:), intent(out) :: & & adjsfcdsw, adjsfcnsw, adjsfcdlw, xmu, xcosz, & @@ -322,9 +258,9 @@ subroutine dcyc2t3_run & integer, intent(out) :: errflg ! --- locals: - integer :: i, j, k, nstp, nstl, it, istsun(im),iSFC,iTOA,itop,ibtc + integer :: i, k, nstp, nstl, it, istsun(im),iSFC,iTOA real(kind=kind_phys) :: cns, coszn, tem1, tem2, anginc, & - & rstl, solang, dT, tem0d + & rstl, solang, dT real(kind=kind_phys), dimension(im,levs+1) :: flxlwup_adj, & & flxlwdn_adj real(kind=kind_phys) :: fluxlwnet_adj,fluxlwnet,dT_sfc, & @@ -355,141 +291,6 @@ subroutine dcyc2t3_run & nstp = max(6, nint(tem1)) nstl = max(1, nint(nstp/tem1)) pid12 = con_pi / hour12 - -! - For time averaged output quantities (including total-sky and -! clear-sky SW and LW fluxes at TOA and surface; conventional -! 3-domain cloud amount, cloud top and base pressure, and cloud top -! temperature; aerosols AOD, etc.), store computed results in -! corresponding slots of array fluxr with appropriate time weights. - -! --- ... collect the fluxr data for wrtsfc - - if (lssav) then - !if (lsswr) then - do i=1,im -! fluxr(i,34) = fluxr(i,34) + fhswr*aerodp(i,1) ! total aod at 550nm -! fluxr(i,35) = fluxr(i,35) + fhswr*aerodp(i,2) ! DU aod at 550nm -! fluxr(i,36) = fluxr(i,36) + fhswr*aerodp(i,3) ! BC aod at 550nm -! fluxr(i,37) = fluxr(i,37) + fhswr*aerodp(i,4) ! OC aod at 550nm -! fluxr(i,38) = fluxr(i,38) + fhswr*aerodp(i,5) ! SU aod at 550nm -! fluxr(i,39) = fluxr(i,39) + fhswr*aerodp(i,6) ! SS aod at 550nm - fluxr(i,34) = aerodp(i,1) ! total aod at 550nm - fluxr(i,35) = aerodp(i,2) ! DU aod at 550nm - fluxr(i,36) = aerodp(i,3) ! BC aod at 550nm - fluxr(i,37) = aerodp(i,4) ! OC aod at 550nm - fluxr(i,38) = aerodp(i,5) ! SU aod at 550nm - fluxr(i,39) = aerodp(i,6) ! SS aod at 550nm - enddo - !endif - -! --- save lw toa and sfc fluxes - !if (lslwr) then - do i=1,im -! --- lw total-sky fluxes - fluxr(i,1 ) = fluxr(i,1 ) + fhlwr * topflw(i)%upfxc ! total sky top lw up - fluxr(i,19) = fluxr(i,19) + fhlwr * sfcflw(i)%dnfxc ! total sky sfc lw dn - fluxr(i,20) = fluxr(i,20) + fhlwr * sfcflw(i)%upfxc ! total sky sfc lw up -! --- lw clear-sky fluxes - fluxr(i,28) = fluxr(i,28) + fhlwr * topflw(i)%upfx0 ! clear sky top lw up - fluxr(i,30) = fluxr(i,30) + fhlwr * sfcflw(i)%dnfx0 ! clear sky sfc lw dn - fluxr(i,33) = fluxr(i,33) + fhlwr * sfcflw(i)%upfx0 ! clear sky sfc lw up - enddo - !endif - -! --- save sw toa and sfc fluxes with proper diurnal sw wgt. coszen=mean cosz over daylight -! part of sw calling interval, while coszdg= mean cosz over entire interval - !if (lsswr) then - do i = 1, IM - if (coszen(i) > 0.) then -! --- sw total-sky fluxes -! ------------------- - tem0d = fhswr * coszdg(i) / coszen(i) - fluxr(i,2 ) = fluxr(i,2) + topfsw(i)%upfxc * tem0d ! total sky top sw up - fluxr(i,3 ) = fluxr(i,3) + sfcfsw(i)%upfxc * tem0d ! total sky sfc sw up - fluxr(i,4 ) = fluxr(i,4) + sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn -! --- sw uv-b fluxes -! -------------- - fluxr(i,21) = fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn - fluxr(i,22) = fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn -! --- sw toa incoming fluxes -! ---------------------- - fluxr(i,23) = fluxr(i,23) + topfsw(i)%dnfxc * tem0d ! top sw dn -! --- sw sfc flux components -! ---------------------- - fluxr(i,24) = fluxr(i,24) + scmpsw(i)%visbm * tem0d ! uv/vis beam sw dn - fluxr(i,25) = fluxr(i,25) + scmpsw(i)%visdf * tem0d ! uv/vis diff sw dn - fluxr(i,26) = fluxr(i,26) + scmpsw(i)%nirbm * tem0d ! nir beam sw dn - fluxr(i,27) = fluxr(i,27) + scmpsw(i)%nirdf * tem0d ! nir diff sw dn -! --- sw clear-sky fluxes -! ------------------- - fluxr(i,29) = fluxr(i,29) + topfsw(i)%upfx0 * tem0d ! clear sky top sw up - fluxr(i,31) = fluxr(i,31) + sfcfsw(i)%upfx0 * tem0d ! clear sky sfc sw up - fluxr(i,32) = fluxr(i,32) + sfcfsw(i)%dnfx0 * tem0d ! clear sky sfc sw dn - endif - enddo - !endif - -! --- save total and boundary layer clouds - - !if (lsswr .or. lslwr) then - do i=1,im - fluxr(i,17) = fluxr(i,17) + raddt * cldsa(i,4) - fluxr(i,18) = fluxr(i,18) + raddt * cldsa(i,5) - enddo - -! --- save cld frac,toplyr,botlyr and top temp, note that the order -! of h,m,l cloud is reversed for the fluxr output. -! --- save interface pressure (pa) of top/bot - - do j = 1, 3 - do i = 1, IM - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - kd - ibtc = mbota(i,j) - kd - fluxr(i, 8-j) = fluxr(i, 8-j) + tem0d - fluxr(i,11-j) = fluxr(i,11-j) + tem0d * p_lev(i,itop+kt) - fluxr(i,14-j) = fluxr(i,14-j) + tem0d * p_lev(i,ibtc+kb) - fluxr(i,17-j) = fluxr(i,17-j) + tem0d * tgrs(i,itop) - enddo - enddo - -! Anning adds optical depth and emissivity output - !if (lsswr .and. (nday > 0)) then - if (nday > 0) then - do j = 1, 3 - do i = 1, IM - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - kd - ibtc = mbota(i,j) - kd - tem1 = 0. - do k=ibtc,itop - tem1 = tem1 + cldtausw(i,k) ! approx .55 um channel - enddo - fluxr(i,43-j) = fluxr(i,43-j) + tem0d * tem1 - enddo - enddo - endif - - !if (lslwr) then - do j = 1, 3 - do i = 1, IM - tem0d = raddt * cldsa(i,j) - itop = mtopa(i,j) - kd - ibtc = mbota(i,j) - kd - tem2 = 0. - do k=ibtc,itop - tem2 = tem2 + cldtaulw(i,k) ! approx 10. um channel - enddo - fluxr(i,46-j) = fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) - enddo - enddo - !endif - - !endif - - endif ! end_if_lssav - - ! ! --- ... sw time-step adjustment for current cosine of zenith angle ! ---------------------------------------------------------- diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta index e1aaafff9..bf6fb1a47 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/dcyc2t3.meta @@ -135,14 +135,6 @@ type = real kind = kind_phys intent = in -[tgrs] - standard_name = air_temperature - long_name = model layer mean temperature - units = K - dimensions = (horizontal_loop_extent,vertical_layer_dimension) - type = real - kind = kind_phys - intent = in [tsflw] standard_name = air_temperature_at_surface_adjacent_layer_on_radiation_timestep long_name = surface (first layer) air temperature saved in longwave radiation call @@ -659,196 +651,6 @@ type = real kind = kind_phys intent = out -[lslwr] - standard_name = flag_for_calling_longwave_radiation - long_name = logical flags for lw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[lsswr] - standard_name = flag_for_calling_shortwave_radiation - long_name = logical flags for sw radiation calls - units = flag - dimensions = () - type = logical - intent = in -[fluxr] - standard_name = cumulative_radiation_diagnostic - long_name = time-accumulated 2D radiation-related diagnostic fields - units = mixed - dimensions = (horizontal_loop_extent,number_of_diagnostics_variables_for_radiation) - type = real - kind = kind_phys - intent = inout -[fhlwr] - standard_name = period_of_longwave_radiation_calls - long_name = frequency for longwave radiation - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[topflw] - standard_name = lw_fluxes_top_atmosphere - long_name = lw radiation fluxes at top - units = W m-2 - dimensions = (horizontal_loop_extent) - type = topflw_type - intent = in -[sfcflw] - standard_name = surface_lw_fluxes_assuming_total_and_clear_sky_on_radiation_timestep - long_name = lw radiation fluxes at sfc - units = W m-2 - dimensions = (horizontal_loop_extent) - type = sfcflw_type - intent = in -[coszdg] - standard_name = cosine_of_solar_zenith_angle_on_radiation_timestep - long_name = daytime mean cosz over rad call period - units = none - dimensions = (horizontal_loop_extent) - type = real - kind = kind_phys - intent = in -[topfsw] - standard_name = sw_fluxes_top_atmosphere - long_name = sw radiation fluxes at toa - units = W m-2 - dimensions = (horizontal_loop_extent) - type = topfsw_type - intent = in -[sfcfsw] - standard_name = surface_sw_fluxes_assuming_total_and_clear_sky_on_radiation_timestep - long_name = sw radiation fluxes at sfc - units = W m-2 - dimensions = (horizontal_loop_extent) - type = sfcfsw_type - intent = in -[scmpsw] - standard_name = components_of_surface_downward_shortwave_fluxes - long_name = derived type for special components of surface downward shortwave fluxes - units = W m-2 - dimensions = (horizontal_loop_extent) - type = cmpfsw_type - intent = in -[raddt] - standard_name = time_step_for_radiation - long_name = radiation time step - units = s - dimensions = () - type = real - kind = kind_phys - intent = in -[cldsa] - standard_name = cloud_area_fraction_for_radiation - long_name = fraction of clouds for low, middle, high, total and BL - units = frac - dimensions = (horizontal_loop_extent,5) - type = real - kind = kind_phys - intent = in -[mtopa] - standard_name = model_layer_number_at_cloud_top - long_name = vertical indices for low, middle and high cloud tops - units = index - dimensions = (horizontal_loop_extent,3) - type = integer - intent = in -[mbota] - standard_name = model_layer_number_at_cloud_base - long_name = vertical indices for low, middle and high cloud bases - units = index - dimensions = (horizontal_loop_extent,3) - type = integer - intent = in -[cldtaulw] - standard_name = cloud_optical_depth_layers_at_10mu_band - long_name = approx 10mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) - type = real - kind = kind_phys - intent = in -[cldtausw] - standard_name = cloud_optical_depth_layers_at_0p55mu_band - long_name = approx .55mu band layer cloud optical depth - units = none - dimensions = (horizontal_loop_extent,adjusted_vertical_layer_dimension_for_radiation) - type = real - kind = kind_phys - intent = in -[aerodp] - standard_name = atmosphere_optical_thickness_due_to_ambient_aerosol_particles - long_name = vertical integrated optical depth for various aerosol species - units = none - dimensions = (horizontal_loop_extent,number_of_species_for_aerosol_optical_depth) - type = real - kind = kind_phys - intent = in -[nfxr] - standard_name = number_of_diagnostics_variables_for_radiation - long_name = number of variables stored in the fluxr array - units = count - dimensions = () - type = integer - intent = in -[lm] - standard_name = vertical_dimension_for_radiation - long_name = number of vertical layers for radiation calculation - units = count - dimensions = () - type = integer - intent = in -[ltp] - standard_name = extra_top_layer - long_name = extra top layers - units = count - dimensions = () - type = integer - intent = in -[kb] - standard_name = vertical_index_difference_between_layer_and_lower_bound - long_name = vertical index difference between layer and lower bound - units = index - dimensions = () - type = integer - intent = in -[kd] - standard_name = vertical_index_difference_between_inout_and_local - long_name = vertical index difference between in/out and local - units = index - dimensions = () - type = integer - intent = in -[kt] - standard_name = vertical_index_difference_between_layer_and_upper_bound - long_name = vertical index difference between layer and upper bound - units = index - dimensions = () - type = integer - intent = in -[nday] - standard_name = daytime_points_dimension - long_name = daytime points dimension - units = count - dimensions = () - type = integer - intent = in -[lssav] - standard_name = flag_for_diagnostics - long_name = logical flag for storing diagnostics - units = flag - dimensions = () - type = logical - intent = in -[nspc1] - standard_name = number_of_species_for_aerosol_optical_depth - long_name = number of species for output aerosol optical depth plus total - units = count - dimensions = () - type = integer - intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/module_ccpp_suite_simulator.F90 b/physics/Interstitials/UFS_SCM_NEPTUNE/module_ccpp_suite_simulator.F90 index 45d3dd4e0..56d1d0666 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/module_ccpp_suite_simulator.F90 +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/module_ccpp_suite_simulator.F90 @@ -121,7 +121,7 @@ function linterp_1D(this, var_name, year, month, day, hour, min, sec) result(err this%tend1d%q = this%tend2d%q(:,1) endif end select - + err_message = "" end function linterp_1D !> Type-bound procedure to compute tendency profile for time-of-day. @@ -153,6 +153,7 @@ function linterp_2D(this, var_name, lon, lat, year, month, day, hour, min, sec) case("q") this%tend1d%q = w1*this%tend3d%q(iNearest,:,ti(1)) + w2*this%tend3d%q(iNearest,:,tf(1)) end select + err_message = "" end function linterp_2D !> Type-bound procedure to find nearest location. diff --git a/physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F b/physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F index 78afbac42..d4dadfe0d 100644 --- a/physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F +++ b/physics/Interstitials/UFS_SCM_NEPTUNE/sfcsub.F @@ -3093,8 +3093,11 @@ subroutine subst(data,imax,jmax,dlon,dlat,ijordr) enddo enddo else - do i=1,imax - data(imax-i+1,jj) = work(i,j) + do j=1,jmax + jj = jmax - j + 1 + do i=1,imax + data(imax-i+1,jj) = work(i,j) + enddo enddo endif else diff --git a/physics/MP/GFDL/GFDL_parse_tracers.F90 b/physics/MP/GFDL/GFDL_parse_tracers.F90 deleted file mode 100644 index 670c292ee..000000000 --- a/physics/MP/GFDL/GFDL_parse_tracers.F90 +++ /dev/null @@ -1,45 +0,0 @@ -!>\file GFDL_parse_tracers.F90 -!! - -!> This module contains code to parse tracers in GFDL MP -module parse_tracers - - integer, parameter :: NO_TRACER = -99 - - public get_tracer_index, NO_TRACER - -CONTAINS - - function get_tracer_index (tracer_names, name, me, master, debug) - - character(len=32), intent(in) :: tracer_names(:) - character(len=*), intent(in) :: name - integer, intent(in) :: me - integer, intent(in) :: master - logical, intent(in) :: debug - !--- local variables - integer :: get_tracer_index - integer :: i - - get_tracer_index = NO_TRACER - - do i=1, size(tracer_names) - if (trim(name) == trim(tracer_names(i))) then - get_tracer_index = i - exit - endif - enddo - - if (debug .and. (me == master)) then - if (get_tracer_index == NO_TRACER) then - print *,' PE ',me,' tracer with name '//trim(name)//' not found' - else - print *,' PE ',me,' tracer FOUND:',trim(name) - endif - endif - - return - - end function get_tracer_index - -end module parse_tracers diff --git a/physics/MP/GFDL/fv_sat_adj.F90 b/physics/MP/GFDL/fv_sat_adj.F90 index 8a2cbca86..6fb0d73a1 100644 --- a/physics/MP/GFDL/fv_sat_adj.F90 +++ b/physics/MP/GFDL/fv_sat_adj.F90 @@ -46,7 +46,7 @@ module fv_sat_adj ! is_master ! ! -! gfdl_cloud_microphys_mod +! module_gfdl_param ! ql_gen, qi_gen, qi0_max, ql_mlt, ql0_max, qi_lim, qs_mlt, ! tau_r2g, tau_smlt, tau_i2s, tau_v2l, tau_l2v, tau_imlt, tau_l2r, ! rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land, tintqs @@ -61,10 +61,11 @@ module fv_sat_adj cp_air => con_cp_dyn ! *DH use machine, only: kind_grid, kind_dyn - use gfdl_cloud_microphys_mod, only: ql_gen, qi_gen, qi0_max, ql_mlt, ql0_max, qi_lim, qs_mlt - use gfdl_cloud_microphys_mod, only: icloud_f, sat_adj0, t_sub, cld_min - use gfdl_cloud_microphys_mod, only: tau_r2g, tau_smlt, tau_i2s, tau_v2l, tau_l2v, tau_imlt, tau_l2r - use gfdl_cloud_microphys_mod, only: rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land, tintqs + use module_gfdlmp_param, only: ql_gen, qi_gen, qi0_max, ql_mlt, ql0_max, qi_lim, qs_mlt + use module_gfdlmp_param, only: icloud_f, sat_adj0, t_sub, cld_min + use module_gfdlmp_param, only: tau_r2g, tau_smlt, tau_i2s, tau_v2l, tau_l2v, tau_imlt, tau_l2r + use module_gfdlmp_param, only: rad_rain, rad_snow, rad_graupel, dw_ocean, dw_land, tintqs + #ifdef MULTI_GASES use ccpp_multi_gases_mod, only: multi_gases_init, & multi_gases_finalize, & diff --git a/physics/MP/GFDL/fv_sat_adj.meta b/physics/MP/GFDL/fv_sat_adj.meta index 4b68de6f0..0efc24c56 100644 --- a/physics/MP/GFDL/fv_sat_adj.meta +++ b/physics/MP/GFDL/fv_sat_adj.meta @@ -2,8 +2,8 @@ name = fv_sat_adj type = scheme dependencies = ../../hooks/machine.F,../../hooks/physcons.F90 - dependencies = module_gfdl_cloud_microphys.F90,multi_gases.F90 - dependencies = ../module_mp_radar.F90 + dependencies = ../multi_gases.F90,../module_mp_radar.F90 + dependencies = module_gfdlmp_param.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/MP/GFDL/module_gfdlmp_param.F90 b/physics/MP/GFDL/module_gfdlmp_param.F90 new file mode 100644 index 000000000..c20e22946 --- /dev/null +++ b/physics/MP/GFDL/module_gfdlmp_param.F90 @@ -0,0 +1,388 @@ +! ######################################################################################### +! ######################################################################################### +module module_gfdlmp_param + use machine, only: kind_phys + implicit none + public :: read_gfdlmp_nml + private + + ! ##################################################################################### + ! GFDL MP Version 1 parameters. + ! ##################################################################################### + real(kind_phys) :: tau_g2r = 600. !< graupel melting to rain time scale (s) + real(kind_phys) :: tau_g2v = 900. !< graupel sublimation time scale (s) + real(kind_phys) :: tau_v2g = 21600. !< graupel deposition -- make it a slow process time scale (s) + real(kind_phys) :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness + real(kind_phys) :: qr0_crt = 1.0e-4 !< rain to snow or graupel/hail threshold + !< lfo used * mixing ratio * = 1.e-4 (hail in lfo) + real(kind_phys) :: c_piacr = 5.0 !< accretion: rain to ice: + real(kind_phys) :: c_cracw = 0.9 !< rain accretion efficiency + real(kind_phys) :: alin = 842.0 !< "a" in lin1983 + real(kind_phys) :: clin = 4.8 !< "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs) + logical :: fast_sat_adj = .false. !< has fast saturation adjustments + logical :: use_ccn = .false. !< must be true when prog_ccn is false + logical :: use_ppm = .false. !< use ppm fall scheme + logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme + logical :: mp_print = .false. !< cloud microphysics debugging printout + logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources + logical :: sedi_transport = .true. !< transport of momentum in sedimentation + + ! ##################################################################################### + ! GFDL MP common (v1/v3) parameters + ! ##################################################################################### + real(kind_phys) :: cld_min = 0.05 !< (v1/v3) minimum cloud fraction + real(kind_phys) :: t_min = 178. !< (v1/v3) min temp to freeze - dry all water vapor + real(kind_phys) :: t_sub = 184. !< (v1/v3) min temp for sublimation of cloud ice + real(kind_phys) :: mp_time = 150. !< (v1/v3) maximum micro - physics time step (sec) + real(kind_phys) :: rh_inc = 0.25 !< (v1/v3) rh increment for complete evaporation of cloud water and cloud ice + real(kind_phys) :: rh_inr = 0.25 !< (v1/v3) rh increment for minimum evaporation of rain + real(kind_phys) :: rh_ins = 0.25 !< (v1/v3) rh increment for sublimation of snow + real(kind_phys) :: tau_r2g = 900. !< (v1/v3) rain freezing during fast_sat time scale (s) + real(kind_phys) :: tau_smlt = 900. !< (v1/v3) snow melting time scale (s) + real(kind_phys) :: tau_i2s = 1000. !< (v1/v3) cloud ice to snow auto-conversion time scale (s) + real(kind_phys) :: tau_l2r = 900. !< (v1/v3) cloud water to rain auto-conversion time scale (s) + real(kind_phys) :: tau_v2l = 150. !< (v1/v3) water vapor to cloud water (condensation) time scale (s) + real(kind_phys) :: tau_l2v = 300. !< (v1/v3) cloud water to water vapor (evaporation) time scale (s) + real(kind_phys) :: dw_land = 0.20 !< (v1/v3) value for subgrid deviation / variability over land + real(kind_phys) :: dw_ocean = 0.10 !< (v1/v3) base value for ocean + real(kind_phys) :: ccn_o = 90. !< (v1/v3) ccn over ocean (cm^ - 3) + real(kind_phys) :: ccn_l = 270. !< (v1/v3) ccn over land (cm^ - 3) + real(kind_phys) :: sat_adj0 = 0.90 !< (v1/v3) adjustment factor (0: no, 1: full) during fast_sat_adj + real(kind_phys) :: qi_lim = 1. !< (v1/v3) cloud ice limiter (0: no, 1: full, >1: extra) to prevent large ice build up + real(kind_phys) :: ql_mlt = 2.0e-3 !< (v1/v3) max value of cloud water allowed from melted cloud ice + real(kind_phys) :: qs_mlt = 1.0e-6 !< (v1/v3) max cloud water due to snow melt + real(kind_phys) :: ql_gen = 1.0e-3 !< (v1/v3) max cloud water generation during remapping step if fast_sat_adj = .t. + real(kind_phys) :: qi_gen = 1.82e-6 !< (v1/v3) max cloud ice generation during remapping step (V1 ONLY. Computed internally in V3) + real(kind_phys) :: ql0_max = 2.0e-3 !< (v1/v3) max cloud water value (auto converted to rain) + real(kind_phys) :: qi0_max = 1.0e-4 !< (v1/v3) max cloud ice value (by other sources) + real(kind_phys) :: qi0_crt = 1.0e-4 !< (v1/v3) cloud ice to snow autoconversion threshold (was 1.e-4); + !< qi0_crt is highly dependent on horizontal resolution + real(kind_phys) :: qs0_crt = 1.0e-3 !< (v1/v3) snow to graupel density threshold (0.6e-3 in purdue lin scheme) + real(kind_phys) :: c_paut = 0.55 !< (v1/v3) autoconversion cloud water to rain (use 0.5 to reduce autoconversion) + real(kind_phys) :: vi_fac = 1. !< (v1/v3) if const_vi: 1 / 3 + real(kind_phys) :: vs_fac = 1. !< (v1/v3) if const_vs: 1. + real(kind_phys) :: vg_fac = 1. !< (v1/v3) if const_vg: 2. + real(kind_phys) :: vr_fac = 1. !< (v1/v3) if const_vr: 4. + real(kind_phys) :: vr_max = 12. !< (v1/v3) max fall speed for rain + real(kind_phys) :: rewmin = 5.0 !< (v1/v3) minimum effective radii (liquid) + real(kind_phys) :: reimin = 10.0 !< (v1/v3) minimum effective radii (ice) + real(kind_phys) :: reimax = 150.0 !< (v1/v3) maximum effective radii (ice) + real(kind_phys) :: rermax = 10000.0 !< (v1/v3) maximum effective radii (rain) + real(kind_phys) :: resmin = 150.0 !< (v1/v3) minimum effective radii (snow) + real(kind_phys) :: resmax = 10000.0 !< (v1/v3) maximum effective radii (snow) + real(kind_phys) :: regmax = 10000.0 !< (v1/v3) maximum effective radii (graupel) + ! + logical :: const_vi = .false. !< (v1/v3) if .t. the constants are specified by v * _fac + logical :: const_vs = .false. !< (v1/v3) if .t. the constants are specified by v * _fac + logical :: const_vg = .false. !< (v1/v3) if .t. the constants are specified by v * _fac + logical :: const_vr = .false. !< (v1/v3) if .t. the constants are specified by v * _fac + logical :: z_slope_liq = .true. !< (v1/v3) use linear mono slope for autocconversions + logical :: do_hail = .false. !< (v1/v3) use hail parameters instead of graupel + logical :: do_qa = .true. !< (v1/v3) do inline cloud fraction + logical :: rad_snow = .true. !< (v1/v3) consider snow in cloud fraciton calculation + logical :: rad_graupel = .true. !< (v1/v3) consider graupel in cloud fraction calculation + logical :: rad_rain = .true. !< (v1/v3) consider rain in cloud fraction calculation + logical :: do_sedi_heat = .true. !< (v1/v3) transport of heat in sedimentation + logical :: prog_ccn = .false. !< (v1/v3) do prognostic ccn (yi ming's method) + logical :: tintqs = .false. !< (v1/v3) + ! + integer :: icloud_f = 0 !< (v1/v3) GFDL cloud scheme + !< 0: subgrid variability based scheme + !< 1: same as 0, but for old fvgfs implementation + !< 2: binary cloud scheme + !< 3: extension of 0 + integer :: irain_f = 0 !< (v1/v3) cloud water to rain auto conversion scheme + !< 0: subgrid variability based scheme + !< 1: no subgrid varaibility + + ! ##################################################################################### + ! GFDL MP common (v1/v3) parameters, with different default values + ! ##################################################################################### + real(kind_phys) :: tice = 273.16 !< freezing temperature (K): ref: GFDL, GFS (DJS: V3=273.15) + real(kind_phys) :: tau_imlt = 600. !< cloud ice melting time scale (s) (DJS: V3=1200.) + real(kind_phys) :: rthresh = 10.0e-6 !< critical cloud drop radius (micro m) (DJS: v3=20.0e-6) + real(kind_phys) :: c_psaci = 0.02 !< accretion: cloud ice to snow (was 0.1 in zetac) (DJS: v3=0.05) + real(kind_phys) :: c_pgacs = 2.0e-3 !< snow to graupel "accretion" eff. (was 0.1 in zetac) (DJS: v3=0.01) + real(kind_phys) :: vi_max = 0.5 !< max fall speed for ice (DJS: v3=1.0) + real(kind_phys) :: vs_max = 5.0 !< max fall speed for snow (DJS: v3=2.0) + real(kind_phys) :: vg_max = 8.0 !< max fall speed for graupel (DJS: v3=12.0) + real(kind_phys) :: rewmax = 10.0 !< maximum effective radii (liquid) (DJS: v3=15.0) + real(kind_phys) :: rermin = 10.0 !< minimum effective radii (rain) (DJS: v3=15.0) + real(kind_phys) :: regmin = 300.0 !< minimum effective radii (graupel) (DJS: v3=150.0) + logical :: z_slope_ice = .false. !< use linear mono slope for autocconversions (DJS: v3=.true.) + logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation (DJS: v3=.true.) + logical :: fix_negative = .false. !< fix negative water species (DJS: v3=.true.) + integer :: reiflag = 1 !< cloud ice effective radius scheme (DJS: v3=5) + !< 1: Heymsfield and Mcfarquhar (1996) + !< 2: Donner et al. (1997) + !< 3: Fu (2007) + !< 4: Kristjansson et al. (2000) + !< 5: Wyser (1998) + !< 6: Sun and Rikus (1999), Sun (2001) + !< 7: effective radius + + ! ##################################################################################### + ! GFDL MP Version 3 parameters + ! ##################################################################################### + logical :: const_vw = .false. !< if .ture., the constants are specified by v * _fac + logical :: do_sedi_uv = .true. !< transport of horizontal momentum in sedimentation + logical :: do_sedi_melt = .true. !< melt cloud ice, snow, and graupel during sedimentation + logical :: liq_ice_combine = .false. !< combine all liquid water, combine all solid water + logical :: snow_grauple_combine = .true. !< combine snow and graupel + logical :: use_rhc_cevap = .false. !< cap of rh for cloud water evaporation + logical :: use_rhc_revap = .false. !< cap of rh for rain evaporation + logical :: do_cld_adj = .false. !< do cloud fraction adjustment + logical :: do_evap_timescale = .true. !< whether to apply a timescale to evaporation + logical :: do_cond_timescale = .false. !< whether to apply a timescale to condensation + logical :: consv_checker = .false. !< turn on energy and water conservation checker + logical :: do_warm_rain_mp = .false. !< do warm rain cloud microphysics only + logical :: do_wbf = .false. !< do Wegener Bergeron Findeisen process + logical :: do_psd_water_fall = .false. !< calculate cloud water terminal velocity based on PSD + logical :: do_psd_ice_fall = .false. !< calculate cloud ice terminal velocity based on PSD + logical :: do_psd_water_num = .false. !< calculate cloud water number concentration based on PSD + logical :: do_psd_ice_num = .false. !< calculate cloud ice number concentration based on PSD + logical :: do_new_acc_water = .false. !< perform the new accretion for cloud water + logical :: do_new_acc_ice = .false. !< perform the new accretion for cloud ice + logical :: cp_heating = .false. !< update temperature based on constant pressure + logical :: delay_cond_evap = .false. !< do condensation evaporation only at the last time step + logical :: do_subgrid_proc = .true. !< do temperature sentive high vertical resolution processes + logical :: fast_fr_mlt = .true. !< do freezing and melting in fast microphysics + logical :: fast_dep_sub = .true. !< do deposition and sublimation in fast microphysics + integer :: ntimes = 1 !< cloud microphysics sub cycles + integer :: nconds = 1 !< condensation sub cycles + integer :: inflag = 1 !< ice nucleation scheme + !< 1: Hong et al. (2004) + !< 2: Meyers et al. (1992) + !< 3: Meyers et al. (1992) + !< 4: Cooper (1986) + !< 5: Fletcher (1962) + integer :: igflag = 3 !< ice generation scheme + !< 1: WSM6 + !< 2: WSM6 with 0 at 0 C + !< 3: WSM6 with 0 at 0 C and fixed value at - 10 C + !< 4: combination of 1 and 3 + integer :: ifflag = 1 !< ice fall scheme + !< 1: Deng and Mace (2008) + !< 2: Heymsfield and Donner (1990) + integer :: rewflag = 1 !< cloud water effective radius scheme + !< 1: Martin et al. (1994) + !< 2: Martin et al. (1994), GFDL revision + !< 3: Kiehl et al. (1994) + !< 4: effective radius + integer :: rerflag = 1 !< rain effective radius scheme + !< 1: effective radius + integer :: resflag = 1 !< snow effective radius scheme + !< 1: effective radius + integer :: regflag = 1 !< graupel effective radius scheme + !< 1: effective radius + integer :: radr_flag = 1 !< radar reflectivity for rain + !< 1: Mark Stoelinga (2005) + !< 2: Smith et al. (1975), Tong and Xue (2005) + !< 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + integer :: rads_flag = 1 !< radar reflectivity for snow + !< 1: Mark Stoelinga (2005) + !< 2: Smith et al. (1975), Tong and Xue (2005) + !< 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + integer :: radg_flag = 1 !< radar reflectivity for graupel + !< 1: Mark Stoelinga (2005) + !< 2: Smith et al. (1975), Tong and Xue (2005) + !< 3: Marshall-Palmer formula (https://en.wikipedia.org/wiki/DBZ_(meteorology)) + integer :: sedflag = 1 !< sedimentation scheme + !< 1: implicit scheme + !< 2: explicit scheme + !< 3: lagrangian scheme + !< 4: combined implicit and lagrangian scheme + integer :: vdiffflag = 1 !< wind difference scheme in accretion + !< 1: Wisner et al. (1972) + !< 2: Mizuno (1990) + !< 3: Murakami (1990) + real(kind_phys) :: c_psacw = 1.0 !< cloud water to snow accretion efficiency + real(kind_phys) :: c_pracw = 0.8 !< cloud water to rain accretion efficiency + real(kind_phys) :: c_praci = 1.0 !< cloud ice to rain accretion efficiency + real(kind_phys) :: c_pgacw = 1.0 !< cloud water to graupel accretion efficiency + real(kind_phys) :: c_pgaci = 0.05 !< cloud ice to graupel accretion efficiency (was 0.1 in ZETAC) + real(kind_phys) :: c_pracs = 1.0 !< snow to rain accretion efficiency + real(kind_phys) :: c_psacr = 1.0 !< rain to snow accretion efficiency + real(kind_phys) :: c_pgacr = 1.0 !< rain to graupel accretion efficiency + real(kind_phys) :: alinw = 3.e7 !< "a" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990) + real(kind_phys) :: alini = 7.e2 !< "a" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990) + real(kind_phys) :: alinr = 842.0 !< "a" in Lin et al. (1983) for rain (Liu and Orville 1969) + real(kind_phys) :: alins = 4.8 !< "a" in Lin et al. (1983) for snow (straka 2009) + real(kind_phys) :: aling = 1.0 !< "a" in Lin et al. (1983), similar to a, but for graupel (Pruppacher and Klett 2010) + real(kind_phys) :: alinh = 1.0 !< "a" in Lin et al. (1983), similar to a, but for hail (Pruppacher and Klett 2010) + real(kind_phys) :: blinw = 2.0 !< "b" in Lin et al. (1983) for cloud water (Ikawa and Saito 1990) + real(kind_phys) :: blini = 1.0 !< "b" in Lin et al. (1983) for cloud ice (Ikawa and Saita 1990) + real(kind_phys) :: blinr = 0.8 !< "b" in Lin et al. (1983) for rain (Liu and Orville 1969) + real(kind_phys) :: blins = 0.25 !< "b" in Lin et al. (1983) for snow (straka 2009) + real(kind_phys) :: bling = 0.5 !< "b" in Lin et al. (1983), similar to b, but for graupel (Pruppacher and Klett 2010) + real(kind_phys) :: blinh = 0.5 !< "b" in Lin et al. (1983), similar to b, but for hail (Pruppacher and Klett 2010) + real(kind_phys) :: vw_fac = 1.0 !< + real(kind_phys) :: vw_max = 0.01 !< maximum fall speed for cloud water (m/s) + real(kind_phys) :: tice_mlt = 273.16 !< can set ice melting temperature to 268 based on observation (Kay et al. 2016) (K) + real(kind_phys) :: tau_gmlt = 600.0 !< graupel melting time scale (s) + real(kind_phys) :: tau_wbf = 300.0 !< graupel melting time scale (s) + real(kind_phys) :: tau_revp = 0.0 !< rain evaporation time scale (s) + real(kind_phys) :: is_fac = 0.2 !< cloud ice sublimation temperature factor + real(kind_phys) :: ss_fac = 0.2 !< snow sublimation temperature factor + real(kind_phys) :: gs_fac = 0.2 !< graupel sublimation temperature factor + real(kind_phys) :: rh_fac_evap = 10.0 !< cloud water evaporation relative humidity factor + real(kind_phys) :: rh_fac_cond = 10.0 !< cloud water condensation relative humidity factor + real(kind_phys) :: sed_fac = 1.0 !< coefficient for sedimentation fall, scale from 1.0 (implicit) to 0.0 (lagrangian) + real(kind_phys) :: xr_a = 0.25 !< p value in Xu and Randall (1996) + real(kind_phys) :: xr_b = 100.0 !< alpha_0 value in Xu and Randall (1996) + real(kind_phys) :: xr_c = 0.49 !< gamma value in Xu and Randall (1996) + real(kind_phys) :: te_err = 1.e-5 !< 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time + real(kind_phys) :: tw_err = 1.e-8 !< 64bit: 1.e-14, 32bit: 1.e-7; turn off to save computer time + real(kind_phys) :: rh_thres = 0.75 !< minimum relative humidity for cloud fraction + real(kind_phys) :: rhc_cevap = 0.85 !< maximum relative humidity for cloud water evaporation + real(kind_phys) :: rhc_revap = 0.85 !< maximum relative humidity for rain evaporation + real(kind_phys) :: f_dq_p = 1.0 !< cloud fraction adjustment for supersaturation + real(kind_phys) :: f_dq_m = 1.0 !< cloud fraction adjustment for undersaturation + real(kind_phys) :: fi2s_fac = 1.0 !< maximum sink of cloud ice to form snow: 0-1 + real(kind_phys) :: fi2g_fac = 1.0 !< maximum sink of cloud ice to form graupel: 0-1 + real(kind_phys) :: fs2g_fac = 1.0 !< maximum sink of snow to form graupel: 0-1 + real(kind_phys) :: n0w_sig = 1.1 !< intercept parameter (significand) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + real(kind_phys) :: n0i_sig = 1.3 !< intercept parameter (significand) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + real(kind_phys) :: n0r_sig = 8.0 !< intercept parameter (significand) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948) + real(kind_phys) :: n0s_sig = 3.0 !< intercept parameter (significand) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958) + real(kind_phys) :: n0g_sig = 4.0 !< intercept parameter (significand) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979) + real(kind_phys) :: n0h_sig = 4.0 !< intercept parameter (significand) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975) + real(kind_phys) :: n0w_exp = 41 !< intercept parameter (exponent) of cloud water (Lin et al. 1983) (1/m^4) (Martin et al. 1994) + real(kind_phys) :: n0i_exp = 18 !< intercept parameter (exponent) of cloud ice (Lin et al. 1983) (1/m^4) (McFarquhar et al. 2015) + real(kind_phys) :: n0r_exp = 6 !< intercept parameter (exponent) of rain (Lin et al. 1983) (1/m^4) (Marshall and Palmer 1948) + real(kind_phys) :: n0s_exp = 6 !< intercept parameter (exponent) of snow (Lin et al. 1983) (1/m^4) (Gunn and Marshall 1958) + real(kind_phys) :: n0g_exp = 6 !< intercept parameter (exponent) of graupel (Rutledge and Hobbs 1984) (1/m^4) (Houze et al. 1979) + real(kind_phys) :: n0h_exp = 4 !< intercept parameter (exponent) of hail (Lin et al. 1983) (1/m^4) (Federer and Waldvogel 1975) + real(kind_phys) :: muw = 6.0 !< shape parameter of cloud water in Gamma distribution (Martin et al. 1994) + real(kind_phys) :: mui = 3.35 !< shape parameter of cloud ice in Gamma distribution (McFarquhar et al. 2015) + real(kind_phys) :: mur = 1.0 !< shape parameter of rain in Gamma distribution (Marshall and Palmer 1948) + real(kind_phys) :: mus = 1.0 !< shape parameter of snow in Gamma distribution (Gunn and Marshall 1958) + real(kind_phys) :: mug = 1.0 !< shape parameter of graupel in Gamma distribution (Houze et al. 1979) + real(kind_phys) :: muh = 1.0 !< shape parameter of hail in Gamma distribution (Federer and Waldvogel 1975) + real(kind_phys) :: beta = 1.22 !< defined in Heymsfield and Mcfarquhar (1996) + real(kind_phys) :: rewfac = 1.0 !< this is a tuning parameter to compromise the inconsistency between + !< GFDL MP's PSD and cloud water radiative property's PSD assumption. + !< after the cloud water radiative property's PSD is rebuilt, + !< this parameter should be 1.0. + real(kind_phys) :: reifac = 1.0 !< this is a tuning parameter to compromise the inconsistency between + !< GFDL MP's PSD and cloud ice radiative property's PSD assumption. + !< after the cloud ice radiative property's PSD is rebuilt, + !< this parameter should be 1.0. + + ! ####################################################################################### + ! NAMELISTS + ! ####################################################################################### + + ! V1 namelist + namelist / gfdl_cloud_microphysics_nml / & + mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, vi_fac, & + vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, vs_max, vg_max, & + vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, qi0_crt, qr0_crt, fast_sat_adj, & + rh_inc, rh_ins, rh_inr, const_vi, const_vs, const_vg, const_vr, use_ccn, rthresh, & + ccn_l, ccn_o, qc_crt, tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, & + tau_l2v, tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, z_slope_liq, & + z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, rad_snow, rad_graupel, rad_rain, & + cld_min, use_ppm, mono_prof, do_sedi_heat, sedi_transport, do_sedi_w, de_ice, & + icloud_f, irain_f, mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, & + rermax, resmin, resmax, regmin, regmax, tintqs, do_hail + + ! V3 Namelist + namelist / gfdl_cloud_microphysics_v3_nml / & + t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, dw_land, dw_ocean, vw_fac, vi_fac, & + vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, & + vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, rh_inc, rh_ins,& + rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthresh, ccn_l, ccn_o, & + igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, tau_l2r, qi_lim, ql_gen, & + do_hail, inflag, c_psacw, c_psaci, c_pracs, c_psacr, c_pgacr, c_pgacs, c_pgacw, & + c_pgaci, z_slope_liq, z_slope_ice, prog_ccn, c_pracw, c_praci, rad_snow, & + rad_graupel, rad_rain, cld_min, sedflag, sed_fac, do_sedi_uv, do_sedi_w, & + do_sedi_heat, icloud_f, irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, & + do_cond_timescale, mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, & + use_rhc_revap, tau_wbf, do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, & + rhc_cevap, rhc_revap, beta, liq_ice_combine, rewflag, reiflag, rerflag, resflag, & + regflag, rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, resmax, regmin, & + regmax, fs2g_fac, fi2s_fac, fi2g_fac, do_sedi_melt, radr_flag, rads_flag, & + radg_flag, do_wbf, do_psd_water_fall, do_psd_ice_fall, n0w_sig, n0i_sig, n0r_sig, & + n0s_sig, n0g_sig, n0h_sig, n0w_exp, n0i_exp, n0r_exp, n0s_exp, n0g_exp, n0h_exp, & + muw, mui, mur, mus, mug, muh, alinw, alini, alinr, alins, aling, alinh, blinw, & + blini, blinr, blins, bling, blinh, do_new_acc_water, do_new_acc_ice, is_fac, & + ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, snow_grauple_combine, do_psd_water_num, & + do_psd_ice_num, vdiffflag, rewfac, reifac, cp_heating, nconds, do_evap_timescale, & + delay_cond_evap, do_subgrid_proc, fast_fr_mlt, fast_dep_sub + ! + public & + tau_g2r, tau_g2v, tau_v2g, qc_crt, qr0_crt, c_piacr, c_cracw, alin, clin, & + fast_sat_adj, use_ccn, use_ppm, mono_prof, mp_print, de_ice, sedi_transport, & + t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, dw_land, dw_ocean, vw_fac, vi_fac, & + vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, & + vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, rh_inc, rh_ins,& + rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthresh, ccn_l, ccn_o, & + igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, tau_l2r, qi_lim, ql_gen, & + do_hail, inflag, c_psacw, c_psaci, c_pracs, c_psacr, c_pgacr, c_pgacs, c_pgacw, & + c_pgaci, z_slope_liq, z_slope_ice, prog_ccn, c_pracw, c_praci, rad_snow, & + rad_graupel, rad_rain, cld_min, sedflag, sed_fac, do_sedi_uv, do_sedi_w, & + do_sedi_heat, icloud_f, irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, & + do_cond_timescale, mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, & + use_rhc_revap, tau_wbf, do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, & + rhc_cevap, rhc_revap, beta, liq_ice_combine, rewflag, reiflag, rerflag, resflag, & + regflag, rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, resmax, regmin, & + regmax, fs2g_fac, fi2s_fac, fi2g_fac, do_sedi_melt, radr_flag, rads_flag, & + radg_flag, do_wbf, do_psd_water_fall, do_psd_ice_fall, n0w_sig, n0i_sig, n0r_sig, & + n0s_sig, n0g_sig, n0h_sig, n0w_exp, n0i_exp, n0r_exp, n0s_exp, n0g_exp, n0h_exp, & + muw, mui, mur, mus, mug, muh, alinw, alini, alinr, alins, aling, alinh, blinw, & + blini, blinr, blins, bling, blinh, do_new_acc_water, do_new_acc_ice, is_fac, & + ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, snow_grauple_combine, do_psd_water_num, & + do_psd_ice_num, vdiffflag, rewfac, reifac, cp_heating, nconds, do_evap_timescale, & + delay_cond_evap, do_subgrid_proc, fast_fr_mlt, fast_dep_sub, qi_gen, sat_adj0, & + tice, tintqs +contains + + ! ####################################################################################### + ! Procedure to read GFDLMP namelists + ! ####################################################################################### + subroutine read_gfdlmp_nml(errmsg, errflg, unit, input_nml_file, fn_nml, version, iostat) + + character(len = *), intent(in ), optional :: input_nml_file(:) + character(len = *), intent(in ), optional :: fn_nml + integer, intent(in ), optional :: unit + integer, intent(in ), optional :: version + integer, intent(out), optional :: iostat + character(len=*), intent(out), optional :: errmsg + integer, intent(out), optional :: errflg + logical :: exists + ! Make sure that all inputs to read appropriate NML are provided, if not use default + ! parameters + if (present(unit) .and. present(iostat) .and. & + present(input_nml_file) .and. present(fn_nml) .and. & + present(version) .and. present(errflg) .and. & + present(errmsg)) then + + if ((version .ne. 1) .and. (version .ne. 3)) then + write (6, *) 'gfdl - mp :: invalid scheme version number' + errflg = 1 + errmsg = 'ERROR(module_gfdlmp_param): invalid scheme version number' + return + endif + +#ifdef INTERNAL_FILE_NML + if (version==1) read (input_nml_file, nml = gfdl_cloud_microphysics_nml) + if (version==3) read (input_nml_file, nml = gfdl_cloud_microphysics_v3_nml) +#else + inquire (file = trim (fn_nml), exist = exists) + if (.not. exists) then + write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' + errflg = 1 + errmsg = 'ERROR(module_gfdlmp_param): namelist file '//trim (fn_nml)//' does not exist' + return + else + open (unit = unit, file = fn_nml, action = 'read' , status = 'old', iostat = iostat) + endif + rewind (unit) + if (version==1) read (unit, nml = gfdl_cloud_microphysics_nml) + if (version==3) read (unit, nml = gfdl_cloud_microphysics_v3_nml) + close (unit) +#endif + endif + end subroutine read_gfdlmp_nml + ! +end module module_gfdlmp_param diff --git a/physics/MP/GFDL/gfdl_cloud_microphys.F90 b/physics/MP/GFDL/v1_2019/gfdl_cloud_microphys.F90 similarity index 98% rename from physics/MP/GFDL/gfdl_cloud_microphys.F90 rename to physics/MP/GFDL/v1_2019/gfdl_cloud_microphys.F90 index 6314b3577..5e0cf0a39 100644 --- a/physics/MP/GFDL/gfdl_cloud_microphys.F90 +++ b/physics/MP/GFDL/v1_2019/gfdl_cloud_microphys.F90 @@ -7,9 +7,9 @@ module gfdl_cloud_microphys use gfdl_cloud_microphys_mod, only: gfdl_cloud_microphys_mod_init, & - gfdl_cloud_microphys_mod_driver, & - gfdl_cloud_microphys_mod_end, & - cloud_diagnosis + gfdl_cloud_microphys_mod_driver, & + gfdl_cloud_microphys_mod_end, & + cloud_diagnosis implicit none diff --git a/physics/MP/GFDL/gfdl_cloud_microphys.meta b/physics/MP/GFDL/v1_2019/gfdl_cloud_microphys.meta similarity index 98% rename from physics/MP/GFDL/gfdl_cloud_microphys.meta rename to physics/MP/GFDL/v1_2019/gfdl_cloud_microphys.meta index 766d3e328..2b7db1961 100644 --- a/physics/MP/GFDL/gfdl_cloud_microphys.meta +++ b/physics/MP/GFDL/v1_2019/gfdl_cloud_microphys.meta @@ -1,9 +1,10 @@ [ccpp-table-properties] name = gfdl_cloud_microphys type = scheme - dependencies = ../../hooks/machine.F - dependencies = ../module_mp_radar.F90 - dependencies = module_gfdl_cloud_microphys.F90 + dependencies = ../../../hooks/machine.F + dependencies = ../../module_mp_radar.F90 + dependencies = gfdl_cloud_microphys_mod.F90 + dependencies = ../module_gfdlmp_param.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/MP/GFDL/module_gfdl_cloud_microphys.F90 b/physics/MP/GFDL/v1_2019/gfdl_cloud_microphys_mod.F90 similarity index 93% rename from physics/MP/GFDL/module_gfdl_cloud_microphys.F90 rename to physics/MP/GFDL/v1_2019/gfdl_cloud_microphys_mod.F90 index 72f3211b5..8d494f13f 100644 --- a/physics/MP/GFDL/module_gfdl_cloud_microphys.F90 +++ b/physics/MP/GFDL/v1_2019/gfdl_cloud_microphys_mod.F90 @@ -40,7 +40,22 @@ module gfdl_cloud_microphys_mod ! use fms_mod, only: write_version_number, open_namelist_file, & ! check_nml_error, file_exist, close_file + ! ----------------------------------------------------------------------- use module_mp_radar + use module_gfdlmp_param, only: read_gfdlmp_nml, mp_time, t_min, t_sub, & + tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, vi_fac, vr_fac, & + vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, vs_max, & + vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & + qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & + const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, & + qc_crt, tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, & + tau_l2v, tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, & + c_pgacs, z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, & + tice, rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, & + mono_prof, do_sedi_heat, sedi_transport, do_sedi_w, de_ice, & + icloud_f, irain_f, mp_print, reiflag, rewmin, rewmax, reimin, & + reimax, rermin, rermax, resmin, resmax, regmin, regmax, tintqs, & + do_hail implicit none @@ -57,7 +72,7 @@ module gfdl_cloud_microphys_mod logical :: module_is_initialized = .false. logical :: qsmith_tables_initialized = .false. - character (len = 17) :: mod_name = 'gfdl_cloud_microphys' + character (len = 20) :: mod_name = 'gfdl_cloud_microphys' real, parameter :: n0r = 8.0e6, n0s = 3.0e6, n0g = 4.0e6 real, parameter :: rhos = 0.1e3, rhog = 0.4e3 @@ -146,21 +161,7 @@ module gfdl_cloud_microphys_mod real :: lv00 !< the same as lv0, except that cp_vap can be cp_vap or cv_vap ! cloud microphysics switchers - - integer :: icloud_f = 0 !< cloud scheme - integer :: irain_f = 0 !< cloud water to rain auto conversion scheme - - logical :: de_ice = .false. !< to prevent excessive build - up of cloud ice from external sources - logical :: sedi_transport = .true. !< transport of momentum in sedimentation - logical :: do_sedi_w = .false. !< transport of vertical motion in sedimentation - logical :: do_sedi_heat = .true. !< transport of heat in sedimentation - logical :: prog_ccn = .false. !< do prognostic ccn (yi ming's method) - logical :: do_qa = .true. !< do inline cloud fraction - logical :: rad_snow = .true. !< consider snow in cloud fraciton calculation - logical :: rad_graupel = .true. !< consider graupel in cloud fraction calculation - logical :: rad_rain = .true. !< consider rain in cloud fraction calculation - logical :: fix_negative = .false. !< fix negative water species - logical :: do_setup = .true. !< setup constants and parameters + logical :: do_setup = .true. !< setup constants and parameters logical :: p_nonhydro = .false. !< perform hydrosatic adjustment on air density real, allocatable :: table (:), table2 (:), table3 (:), tablew (:) @@ -183,171 +184,9 @@ module gfdl_cloud_microphys_mod ! qs0_crt = 0.6e-3 ! c_psaci = 0.1 ! c_pgacs = 0.1 - - ! ----------------------------------------------------------------------- - ! namelist parameters - ! ----------------------------------------------------------------------- - - real :: cld_min = 0.05 !< minimum cloud fraction - real :: tice = 273.16 !< set tice = 165. to trun off ice - phase phys (kessler emulator) - - real :: t_min = 178. !< min temp to freeze - dry all water vapor - real :: t_sub = 184. !< min temp for sublimation of cloud ice - real :: mp_time = 150. !< maximum micro - physics time step (sec) - - ! relative humidity increment - - real :: rh_inc = 0.25 !< rh increment for complete evaporation of cloud water and cloud ice - real :: rh_inr = 0.25 !< rh increment for minimum evaporation of rain - real :: rh_ins = 0.25 !< rh increment for sublimation of snow - - ! conversion time scale - - real :: tau_r2g = 900. !< rain freezing during fast_sat - real :: tau_smlt = 900. !< snow melting - real :: tau_g2r = 600. !< graupel melting to rain - real :: tau_imlt = 600. !< cloud ice melting - real :: tau_i2s = 1000. !< cloud ice to snow auto-conversion - real :: tau_l2r = 900. !< cloud water to rain auto-conversion - real :: tau_v2l = 150. !< water vapor to cloud water (condensation) - real :: tau_l2v = 300. !< cloud water to water vapor (evaporation) - real :: tau_g2v = 900. !< graupel sublimation - real :: tau_v2g = 21600. !< graupel deposition -- make it a slow process - - ! horizontal subgrid variability - - real :: dw_land = 0.20 !< base value for subgrid deviation / variability over land - real :: dw_ocean = 0.10 !< base value for ocean - - ! prescribed ccn - - real :: ccn_o = 90. !< ccn over ocean (cm^ - 3) - real :: ccn_l = 270. !< ccn over land (cm^ - 3) - - real :: rthresh = 10.0e-6 !< critical cloud drop radius (micro m) - - ! ----------------------------------------------------------------------- - ! wrf / wsm6 scheme: qi_gen = 4.92e-11 * (1.e3 * exp (0.1 * tmp)) ** 1.33 - ! optimized: qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tmp))) - ! qi_gen ~ 4.808e-7 at 0 c; 1.818e-6 at - 10 c, 9.82679e-5 at - 40c - ! the following value is constructed such that qc_crt = 0 at zero c and @ - 10c matches - ! wrf / wsm6 ice initiation scheme; qi_crt = qi_gen * min (qi_lim, 0.1 * tmp) / den - ! ----------------------------------------------------------------------- - - real :: sat_adj0 = 0.90 !< adjustment factor (0: no, 1: full) during fast_sat_adj - - real :: qc_crt = 5.0e-8 !< mini condensate mixing ratio to allow partial cloudiness - - real :: qi_lim = 1. !< cloud ice limiter to prevent large ice build up - - real :: ql_mlt = 2.0e-3 !< max value of cloud water allowed from melted cloud ice - real :: qs_mlt = 1.0e-6 !< max cloud water due to snow melt - - real :: ql_gen = 1.0e-3 !< max cloud water generation during remapping step if fast_sat_adj = .t. - real :: qi_gen = 1.82e-6 !< max cloud ice generation during remapping step - - ! cloud condensate upper bounds: "safety valves" for ql & qi - - real :: ql0_max = 2.0e-3 !< max cloud water value (auto converted to rain) - real :: qi0_max = 1.0e-4 !< max cloud ice value (by other sources) - - real :: qi0_crt = 1.0e-4 !< cloud ice to snow autoconversion threshold (was 1.e-4); - !! qi0_crt is highly dependent on horizontal resolution - real :: qr0_crt = 1.0e-4 !< rain to snow or graupel/hail threshold - ! lfo used * mixing ratio * = 1.e-4 (hail in lfo) - real :: qs0_crt = 1.0e-3 !< snow to graupel density threshold (0.6e-3 in purdue lin scheme) - - real :: c_paut = 0.55 !< autoconversion cloud water to rain (use 0.5 to reduce autoconversion) - real :: c_psaci = 0.02 !< accretion: cloud ice to snow (was 0.1 in zetac) - real :: c_piacr = 5.0 !< accretion: rain to ice: - real :: c_cracw = 0.9 !< rain accretion efficiency - real :: c_pgacs = 2.0e-3 !< snow to graupel "accretion" eff. (was 0.1 in zetac) - - ! decreasing clin to reduce csacw (so as to reduce cloud water --- > snow) - - real :: alin = 842.0 !< "a" in lin1983 - real :: clin = 4.8 !< "c" in lin 1983, 4.8 -- > 6. (to ehance ql -- > qs) - - ! fall velocity tuning constants: - - logical :: const_vi = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vs = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vg = .false. !< if .t. the constants are specified by v * _fac - logical :: const_vr = .false. !< if .t. the constants are specified by v * _fac - - ! good values: - - real :: vi_fac = 1. !< if const_vi: 1 / 3 - real :: vs_fac = 1. !< if const_vs: 1. - real :: vg_fac = 1. !< if const_vg: 2. - real :: vr_fac = 1. !< if const_vr: 4. - - ! upper bounds of fall speed (with variable speed option) - - real :: vi_max = 0.5 !< max fall speed for ice - real :: vs_max = 5.0 !< max fall speed for snow - real :: vg_max = 8.0 !< max fall speed for graupel - real :: vr_max = 12. !< max fall speed for rain - - ! cloud microphysics switchers - - logical :: fast_sat_adj = .false. !< has fast saturation adjustments - logical :: z_slope_liq = .true. !< use linear mono slope for autocconversions - logical :: z_slope_ice = .false. !< use linear mono slope for autocconversions - logical :: use_ccn = .false. !< must be true when prog_ccn is false - logical :: use_ppm = .false. !< use ppm fall scheme - logical :: mono_prof = .true. !< perform terminal fall with mono ppm scheme - logical :: mp_print = .false. !< cloud microphysics debugging printout - logical :: do_hail = .false. !< use hail parameters instead of graupel - - ! real :: global_area = - 1. - + real :: log_10, tice0, t_wfr - integer :: reiflag = 1 - ! 1: Heymsfield and Mcfarquhar, 1996 - ! 2: Wyser, 1998 - - logical :: tintqs = .false. !< use temperature in the saturation mixing in PDF - - real :: rewmin = 5.0, rewmax = 10.0 - real :: reimin = 10.0, reimax = 150.0 - real :: rermin = 10.0, rermax = 10000.0 - real :: resmin = 150.0, resmax = 10000.0 - real :: regmin = 300.0, regmax = 10000.0 - - ! ----------------------------------------------------------------------- - ! namelist - ! ----------------------------------------------------------------------- - - namelist / gfdl_cloud_microphysics_nml / & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & - rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, & - mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, rermax, & - resmin, resmax, regmin, regmax, tintqs, do_hail - - public & - mp_time, t_min, t_sub, tau_r2g, tau_smlt, tau_g2r, dw_land, dw_ocean, & - vi_fac, vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vi_max, & - vs_max, vg_max, vr_max, qs_mlt, qs0_crt, qi_gen, ql0_max, qi0_max, & - qi0_crt, qr0_crt, fast_sat_adj, rh_inc, rh_ins, rh_inr, const_vi, & - const_vs, const_vg, const_vr, use_ccn, rthresh, ccn_l, ccn_o, qc_crt, & - tau_g2v, tau_v2g, sat_adj0, c_piacr, tau_imlt, tau_v2l, tau_l2v, & - tau_i2s, tau_l2r, qi_lim, ql_gen, c_paut, c_psaci, c_pgacs, & - z_slope_liq, z_slope_ice, prog_ccn, c_cracw, alin, clin, tice, & - rad_snow, rad_graupel, rad_rain, cld_min, use_ppm, mono_prof, & - do_sedi_heat, sedi_transport, do_sedi_w, de_ice, icloud_f, irain_f, & - mp_print, reiflag, rewmin, rewmax, reimin, reimax, rermin, rermax, & - resmin, resmax, regmin, regmax, tintqs, do_hail - contains ! ----------------------------------------------------------------------- @@ -3596,30 +3435,20 @@ subroutine gfdl_cloud_microphys_mod_init (me, master, nlunit, input_nml_file, lo errflg = 0 errmsg = '' -#ifdef INTERNAL_FILE_NML - read (input_nml_file, nml = gfdl_cloud_microphysics_nml) -#else - inquire (file = trim (fn_nml), exist = exists) - if (.not. exists) then - write (6, *) 'gfdl - mp :: namelist file: ', trim (fn_nml), ' does not exist' - errflg = 1 - errmsg = 'ERROR(gfdl_cloud_microphys_mod_init): namelist file '//trim (fn_nml)//' does not exist' - return - else - open (unit = nlunit, file = fn_nml, action = 'read' , status = 'old', iostat = ios) - endif - rewind (nlunit) - read (nlunit, nml = gfdl_cloud_microphysics_nml) - close (nlunit) -#endif + ! ----------------------------------------------------------------------- + ! Read namelist + ! ----------------------------------------------------------------------- + call read_gfdlmp_nml(errmsg = errmsg, errflg = errflg, unit = nlunit, & + input_nml_file = input_nml_file, fn_nml = fn_nml, version=1, & + iostat = ios) ! write version number and namelist to log file if (me == master) then write (logunit, *) " ================================================================== " - write (logunit, *) "gfdl_cloud_microphys_mod" - write (logunit, nml = gfdl_cloud_microphysics_nml) + write (logunit, *) "gfdl_cloud_microphysics_nml" endif + ! if (do_setup) then call setup_con call setupm diff --git a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.F90 b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.F90 new file mode 100644 index 000000000..eae68d4f3 --- /dev/null +++ b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.F90 @@ -0,0 +1,362 @@ +!> \file gfdl_cloud_microphys_v3.F90 +!! This file contains the CCPP entry point for the column GFDL cloud microphysics version 3 ( Chen and Lin (2013) +!! \cite chen_and_lin_2013 ). +module gfdl_cloud_microphys_v3 + + use gfdl_cloud_microphys_v3_mod, only: gfdl_cloud_microphys_v3_mod_init, & + gfdl_cloud_microphys_v3_mod_driver, & + gfdl_cloud_microphys_v3_mod_end, & + rad_ref, cld_eff_rad + + implicit none + + private + + public gfdl_cloud_microphys_v3_run, gfdl_cloud_microphys_v3_init, gfdl_cloud_microphys_v3_finalize + + logical :: is_initialized = .false. + +contains + +! ----------------------------------------------------------------------- +! CCPP entry points for gfdl cloud microphysics +! ----------------------------------------------------------------------- + +!>\brief The subroutine initializes the GFDL +!! cloud microphysics. +!! +!> \section arg_table_gfdl_cloud_microphys_v3_init Argument Table +!! \htmlinclude gfdl_cloud_microphys_v3_init.html +!! + + subroutine gfdl_cloud_microphys_v3_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml, imp_physics, imp_physics_gfdl, do_shoc, & + hydrostatic, errmsg, errflg) + + implicit none + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + integer, intent (in) :: logunit + character(len=*), intent (in) :: fn_nml + character(len=*), intent (in) :: input_nml_file(:) + integer, intent( in) :: imp_physics + integer, intent( in) :: imp_physics_gfdl + logical, intent( in) :: do_shoc + logical, intent( in) :: hydrostatic + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (is_initialized) return + + if (imp_physics/=imp_physics_gfdl) then + write(errmsg,'(*(a))') 'Namelist option for microphysics does not match choice in suite definition file' + errflg = 1 + return + end if + + if (do_shoc) then + write(errmsg,'(*(a))') 'SHOC is not currently compatible with GFDL MP v3' + errflg = 1 + return + endif + + call gfdl_cloud_microphys_v3_mod_init(me, master, nlunit, input_nml_file, logunit, fn_nml, hydrostatic, errmsg, errflg) + + is_initialized = .true. + + end subroutine gfdl_cloud_microphys_v3_init + + +! ======================================================================= +!>\brief The subroutine 'gfdl_cloud_microphys_v3_finalize' terminates the GFDL +!! cloud microphysics. +!! +!! \section arg_table_gfdl_cloud_microphys_v3_finalize Argument Table +!! \htmlinclude gfdl_cloud_microphys_v3_finalize.html +!! + subroutine gfdl_cloud_microphys_v3_finalize(errmsg, errflg) + + implicit none + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + call gfdl_cloud_microphys_v3_mod_end() + + is_initialized = .false. + + end subroutine gfdl_cloud_microphys_v3_finalize + +!>\defgroup gfdlmp GFDL Cloud Microphysics Module +!! This is cloud microphysics package for GFDL global cloud resolving model. +!! The algorithms are originally derived from Lin et al. (1983) \cite lin_et_al_1983. +!! Most of the key elements have been simplified/improved. This code at this stage +!! bears little to no similarity to the original Lin MP. +!! Therefore, it is best to be called GFDL microphysics (GFDL MP) . +!! +!>\brief The module contains the GFDL cloud +!! microphysics (Chen and Lin (2013) \cite chen_and_lin_2013 ). +!> The module is paired with \ref fast_sat_adj, which performs the "fast" +!! processes. +!! +!>\brief The subroutine executes the full GFDL cloud microphysics. +!! \section arg_table_gfdl_cloud_microphys_v3_run Argument Table +!! \htmlinclude gfdl_cloud_microphys_v3_run.html +!! + subroutine gfdl_cloud_microphys_v3_run(fast_mp_consv, & + levs, im, rainmin, con_g, con_fvirt, con_rd, con_eps, garea, slmsk, snowd, & + gq0, gq0_ntcw, gq0_ntrw, gq0_ntiw, gq0_ntsw, gq0_ntgl, gq0_ntclamt, aerfld, & + gt0, gu0, gv0, vvl, prsl, phii, del, & + rain0, ice0, snow0, graupel0, prcp0, sr, oro, & + dtp, hydrostatic, lradar, refl_10cm, & + reset, effr_in, rew, rei, rer, res, reg, & + cplchm, pfi_lsan, pfl_lsan, con_one, con_p001, con_secinday, errmsg, errflg) + + use machine, only: kind_phys, kind_dyn, kind_dbl_prec + + implicit none + + ! interface variables + integer, intent(in ) :: levs, im + real(kind=kind_phys), intent(in ) :: con_g, con_fvirt, con_rd, con_eps, rainmin + real(kind=kind_phys), intent(in ) :: con_one, con_p001, con_secinday + real(kind=kind_phys), intent(in ), dimension(:) :: garea, slmsk, snowd, oro + real(kind=kind_phys), intent(inout), dimension(:,:) :: gq0, gq0_ntcw, gq0_ntrw, gq0_ntiw, & + gq0_ntsw, gq0_ntgl, gq0_ntclamt + real(kind_phys), intent(in ), dimension(:,:,:) :: aerfld + real(kind=kind_phys), intent(inout), dimension(:,:) :: gt0, gu0, gv0 + real(kind=kind_phys), intent(in ), dimension(:,:) :: vvl, prsl, del + real(kind=kind_phys), intent(in ), dimension(:,:) :: phii + + ! rain/snow/ice/graupel/precip amounts, fraction of frozen precip + !real(kind_phys), dimension(:) :: water0 + real(kind_phys), intent(out ), dimension(:), optional :: rain0 + real(kind_phys), intent(out ), dimension(:), optional :: snow0 + real(kind_phys), intent(out ), dimension(:), optional :: ice0 + real(kind_phys), intent(out ), dimension(:), optional :: graupel0 + real(kind_phys), intent(out ), dimension(:) :: prcp0 + real(kind_phys), intent(out ), dimension(:) :: sr + + real(kind_phys), intent(in) :: dtp ! physics time step + logical, intent (in) :: hydrostatic, fast_mp_consv + + logical, intent (in) :: lradar + real(kind=kind_phys), intent(inout), dimension(:,:) :: refl_10cm + logical, intent (in) :: reset, effr_in + real(kind=kind_phys), intent(inout), dimension(:,:), optional :: rew, rei, rer, res, reg + logical, intent (in) :: cplchm + ! ice and liquid water 3d precipitation fluxes - only allocated if cplchm is .true. + real(kind=kind_phys), intent(inout), dimension(:,:), optional :: pfi_lsan, pfl_lsan + + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + ! local variables + integer :: iis, iie, jjs, jje, kks, kke, kbot, ktop + integer :: i, k, kk + real(kind=kind_phys), dimension(1:im,1:levs) :: delp, dz, uin, vin, pt, qv1, ql1, qi1, qr1, qs1, qg1, & + qa1, qnl, qni, pt_dt, qa_dt, u_dt, v_dt, w, qv_dt, ql_dt,& + qr_dt, qi_dt, qs_dt, qg_dt, p123, refl + real(kind=kind_phys), dimension(1:im,1:levs) :: q_con, cappa !for inline MP option + real(kind=kind_phys), dimension(1:im,1,1:levs) :: pfils, pflls + real(kind=kind_phys), dimension(1:im,1,1:levs) :: adj_vmr, te + real(kind=kind_phys), dimension(1:im,1:levs) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + real(kind=kind_phys), dimension(1:im) :: hs, gsize + real(kind=kind_dbl_prec), dimension(1:im) :: dte + !real(kind=kind_phys), dimension(:,:), allocatable :: den + real(kind=kind_phys), dimension(1:im) :: water0 + real(kind=kind_phys) :: onebg + real(kind=kind_phys) :: tem + logical last_step, do_inline_mp + + ! Initialize CCPP error handling variables + errmsg = '' + errflg = 0 + + iis = 1 + iie = im + jjs = 1 + jje = 1 + kks = 1 + kke = levs + ! flipping of vertical direction + ktop = 1 + kbot = levs + + onebg = con_one/con_g + + do k = 1, levs + kk = levs-k+1 + do i = 1, im + qv_dt(i,k) = 0.0 + ql_dt(i,k) = 0.0 + qr_dt(i,k) = 0.0 + qi_dt(i,k) = 0.0 + qs_dt(i,k) = 0.0 + qg_dt(i,k) = 0.0 + qa_dt(i,k) = 0.0 + pt_dt(i,k) = 0.0 + u_dt(i,k) = 0.0 + v_dt(i,k) = 0.0 + qnl(i,k) = aerfld(i,kk,11) ! sulfate + pfils(i,1,k) = 0.0 + pflls(i,1,k) = 0.0 + prefluxw(i,k) =0.0 + prefluxi(i,k) =0.0 + prefluxr(i,k) =0.0 + prefluxs(i,k) =0.0 + prefluxg(i,k) =0.0 + + ! flip vertical (k) coordinate top =1 + qv1(i,k) = gq0(i,kk) + ql1(i,k) = gq0_ntcw(i,kk) + qr1(i,k) = gq0_ntrw(i,kk) + qi1(i,k) = gq0_ntiw(i,kk) + qs1(i,k) = gq0_ntsw(i,kk) + qg1(i,k) = gq0_ntgl(i,kk) + qa1(i,k) = gq0_ntclamt(i,kk) + pt(i,k) = gt0(i,kk) + w(i,k) = -vvl(i,kk) * (con_one+con_fvirt * gq0(i,kk)) & + * gt0(i,kk) / prsl(i,kk) * (con_rd*onebg) + uin(i,k) = gu0(i,kk) + vin(i,k) = gv0(i,kk) + delp(i,k) = del(i,kk) + dz(i,k) = (phii(i,kk)-phii(i,kk+1))*onebg + p123(i,k) = prsl(i,kk) + qni(i,k) = 10. + q_con(i,k) = 0.0 + cappa(i,k) = 0.0 + enddo + enddo + + ! reset precipitation amounts to zero + water0 = 0 + rain0 = 0 + ice0 = 0 + snow0 = 0 + graupel0 = 0 + + ! Call MP driver + last_step = .false. + do_inline_mp = .false. + hs = oro(:) * con_g + gsize = sqrt(garea(:)) + + call gfdl_cloud_microphys_v3_mod_driver( qv1, ql1, qr1, qi1, qs1, qg1, qa1, qnl, qni, pt, w,& + uin, vin, dz, delp, gsize, dtp, hs, water0, rain0, & + ice0, snow0, graupel0, hydrostatic, iis, iie, kks, kke, q_con, cappa, & + fast_mp_consv, adj_vmr, te, dte, prefluxw, prefluxr, prefluxi, prefluxs, & + prefluxg, last_step, do_inline_mp ) + tem = dtp*con_p001/con_secinday + + ! fix negative values + do i = 1, im + !rain0(i) = max(con_d00, rain0(i)) + !snow0(i) = max(con_d00, snow0(i)) + !ice0(i) = max(con_d00, ice0(i)) + !graupel0(i) = max(con_d00, graupel0(i)) + if(water0(i)*tem < rainmin) then + water0(i) = 0.0 + endif + if(rain0(i)*tem < rainmin) then + rain0(i) = 0.0 + endif + if(ice0(i)*tem < rainmin) then + ice0(i) = 0.0 + endif + if(snow0(i)*tem < rainmin) then + snow0(i) = 0.0 + endif + if(graupel0(i)*tem < rainmin) then + graupel0(i) = 0.0 + endif + enddo + + ! calculate fraction of frozen precipitation using unscaled + ! values of rain0, ice0, snow0, graupel0 (for bit-for-bit) + do i=1,im + prcp0(i) = (rain0(i)+snow0(i)+ice0(i)+graupel0(i)) * tem + if ( prcp0(i) > rainmin ) then + sr(i) = (snow0(i) + ice0(i) + graupel0(i)) & + / (rain0(i) + snow0(i) + ice0(i) + graupel0(i)) + else + sr(i) = 0.0 + endif + enddo + + ! convert rain0, ice0, snow0, graupel0 from mm per day to m per physics timestep + water0 = water0*tem + rain0 = rain0*tem + ice0 = ice0*tem + snow0 = snow0*tem + graupel0 = graupel0*tem + + ! flip vertical coordinate back + do k=1,levs + kk = levs-k+1 + do i=1,im + gq0(i,k) = qv1(i,kk) + gq0_ntcw(i,k) = ql1(i,kk) + gq0_ntrw(i,k) = qr1(i,kk) + gq0_ntiw(i,k) = qi1(i,kk) + gq0_ntsw(i,k) = qs1(i,kk) + gq0_ntgl(i,k) = qg1(i,kk) + gq0_ntclamt(i,k) = qa1(i,kk) + gt0(i,k) = pt(i,kk) + gu0(i,k) = uin(i,kk) + gv0(i,k) = vin(i,kk) + refl_10cm(i,k) = refl(i,kk) + enddo + enddo + + ! output ice and liquid water 3d precipitation fluxes if requested + if (cplchm) then + do k=1,levs + kk = levs-k+1 + do i=1,im + pfi_lsan(i,k) = prefluxi (i,kk) + prefluxs (i,kk) + prefluxg (i,kk) + pfl_lsan(i,k) = prefluxr (i,kk) + enddo + enddo + endif + + if(effr_in) then + call cld_eff_rad (1, im, 1, levs, slmsk(1:im), & + prsl(1:im,1:levs), del(1:im,1:levs), & + gt0(1:im,1:levs), gq0(1:im,1:levs), & + gq0_ntcw(1:im,1:levs), gq0_ntiw(1:im,1:levs), & + gq0_ntrw(1:im,1:levs), gq0_ntsw(1:im,1:levs), & + gq0_ntgl(1:im,1:levs), gq0_ntclamt(1:im,1:levs), & + rew(1:im,1:levs), rei(1:im,1:levs), rer(1:im,1:levs),& + res(1:im,1:levs), reg(1:im,1:levs),snowd(1:im)) + endif + + if(lradar) then + call rad_ref (1, im, 1, 1, qv1(1:im,1:levs), qr1(1:im,1:levs), & + qs1(1:im,1:levs),qg1(1:im,1:levs),pt(1:im,1:levs), & + delp(1:im,1:levs), dz(1:im,1:levs), refl(1:im,1:levs), levs, hydrostatic, & + do_inline_mp, 1) + + do k=1,levs + kk = levs-k+1 + do i=1,im + refl_10cm(i,k) = max(-35.,refl(i,kk)) + enddo + enddo + endif + + end subroutine gfdl_cloud_microphys_v3_run + +end module gfdl_cloud_microphys_v3 diff --git a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.meta b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.meta new file mode 100644 index 000000000..3b022bf25 --- /dev/null +++ b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3.meta @@ -0,0 +1,541 @@ +[ccpp-table-properties] + name = gfdl_cloud_microphys_v3 + type = scheme + dependencies = ../../../hooks/machine.F + dependencies = ../../../hooks/physcons.F90 + dependencies = gfdl_cloud_microphys_v3_mod.F90 + +######################################################################## +[ccpp-arg-table] + name = gfdl_cloud_microphys_v3_init + type = scheme +[me] + standard_name = mpi_rank + long_name = MPI rank of current process + units = index + dimensions = () + type = integer + intent = in +[master] + standard_name = mpi_root + long_name = MPI rank of master process + units = index + dimensions = () + type = integer + intent = in +[nlunit] + standard_name = iounit_of_namelist + long_name = fortran unit number for opening nameliust file + units = none + dimensions = () + type = integer + intent = in +[input_nml_file] + standard_name = filename_of_internal_namelist + long_name = character string to store full namelist contents + units = none + dimensions = (number_of_lines_in_internal_namelist) + type = character + kind = len=* + intent = in +[logunit] + standard_name = iounit_of_log + long_name = fortran unit number for writing logfile + units = none + dimensions = () + type = integer + intent = in +[fn_nml] + standard_name = filename_of_namelist + long_name = namelist filename + units = none + dimensions = () + type = character + kind = len=* + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_gfdl] + standard_name = identifier_for_gfdl_microphysics_scheme + long_name = choice of GFDL microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[do_shoc] + standard_name = flag_for_shoc + long_name = flag to indicate use of SHOC + units = flag + dimensions = () + type = logical + intent = in +[hydrostatic] + standard_name = flag_for_hydrostatic_solver + long_name = flag indicating hydrostatic solver + units = flag + dimensions = () + type = logical + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = gfdl_cloud_microphys_v3_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = gfdl_cloud_microphys_v3_run + type = scheme +[fast_mp_consv] + standard_name = flag_for_fast_microphysics_energy_conservation + long_name = flag for fast microphysics energy conservation + units = flag + dimensions = () + type = logical + intent = in +[levs] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[im] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[rainmin] + standard_name = lwe_thickness_of_minimum_rain_amount + long_name = minimum rain amount + units = m + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_fvirt] + standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one + long_name = rv/rd - 1 (rv = ideal gas constant for water vapor) + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[garea] + standard_name = cell_area + long_name = area of grid cell + units = m2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[slmsk] + standard_name = area_type + long_name = landmask: sea/land/ice=0/1/2 + units = flag + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[snowd] + standard_name = lwe_surface_snow + long_name = water equivalent snow depth + units = mm + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in +[gq0] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0_ntcw] + standard_name = cloud_liquid_water_mixing_ratio_of_new_state + long_name = cloud condensed water mixing ratio updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0_ntrw] + standard_name = rain_mixing_ratio_of_new_state + long_name = moist mixing ratio of rain updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0_ntiw] + standard_name = cloud_ice_mixing_ratio_of_new_state + long_name = moist mixing ratio of cloud ice updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0_ntsw] + standard_name = snow_mixing_ratio_of_new_state + long_name = moist mixing ratio of snow updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0_ntgl] + standard_name = graupel_mixing_ratio_of_new_state + long_name = moist ratio of mass of graupel to mass of dry air plus vapor (without condensates) updated by physics + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gq0_ntclamt] + standard_name = cloud_area_fraction_in_atmosphere_layer_of_new_state + long_name = cloud fraction updated by physics + units = frac + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[aerfld] + standard_name = mass_mixing_ratio_of_aerosol_from_gocart_or_merra2 + long_name = mass mixing ratio of aerosol from gocart or merra2 + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_tracers_MG) + type = real + kind = kind_phys + intent = in +[gt0] + standard_name = air_temperature_of_new_state + long_name = air temperature updated by physics + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gu0] + standard_name = x_wind_of_new_state + long_name = zonal wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[gv0] + standard_name = y_wind_of_new_state + long_name = meridional wind updated by physics + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[vvl] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[del] + standard_name = air_pressure_difference_between_midlayers + long_name = air pressure difference between mid-layers + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[rain0] + standard_name = lwe_thickness_of_explicit_rain_amount + long_name = explicit rain on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = True +[ice0] + standard_name = lwe_thickness_of_ice_amount + long_name = ice fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = True +[snow0] + standard_name = lwe_thickness_of_snow_amount + long_name = snow fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = True +[graupel0] + standard_name = lwe_thickness_of_graupel_amount + long_name = graupel fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out + optional = True +[prcp0] + standard_name = lwe_thickness_of_explicit_precipitation_amount + long_name = explicit precipitation (rain, ice, snow, graupel) on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[sr] + standard_name = ratio_of_snowfall_to_rainfall + long_name = snow ratio: ratio of snow to total precipitation + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[oro] + standard_name = height_above_mean_sea_level + long_name = height_above_mean_sea_level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[hydrostatic] + standard_name = flag_for_hydrostatic_solver + long_name = flag indicating hydrostatic solver + units = flag + dimensions = () + type = logical + intent = in +[lradar] + standard_name = flag_for_radar_reflectivity + long_name = flag for radar reflectivity + units = flag + dimensions = () + type = logical + intent = in +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[reset] + standard_name = flag_reset_maximum_hourly_fields + long_name = flag for resetting maximum hourly fields + units = flag + dimensions = () + type = logical + intent = in +[effr_in] + standard_name = flag_for_cloud_effective_radii + long_name = flag for cloud effective radii calculations in GFDL microphysics + units = flag + dimensions = () + type = logical + intent = in +[rew] + standard_name = effective_radius_of_stratiform_cloud_liquid_water_particle + long_name = eff. radius of cloud liquid water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[rei] + standard_name = effective_radius_of_stratiform_cloud_ice_particle + long_name = eff. radius of cloud ice water particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[rer] + standard_name = effective_radius_of_stratiform_cloud_rain_particle + long_name = effective radius of cloud rain particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[res] + standard_name = effective_radius_of_stratiform_cloud_snow_particle + long_name = effective radius of cloud snow particle in micrometers + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[reg] + standard_name = effective_radius_of_stratiform_cloud_graupel_particle + long_name = eff. radius of cloud graupel particle in micrometer + units = um + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[pfi_lsan] + standard_name = ice_flux_due_to_large_scale_precipitation + long_name = instantaneous 3D flux of ice from nonconvective precipitation + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[pfl_lsan] + standard_name = liquid_flux_due_to_large_scale_precipitation + long_name = instantaneous 3D flux of liquid water from nonconvective precipitation + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[con_one] + standard_name = constant_one + long_name = mathematical constant of one + units = 1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_p001] + standard_name = constant_one_hundredth + long_name = mathematical constant for one hundredth + units = 1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_secinday] + standard_name = seconds_in_a_day + long_name = number of seconds in a day + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3_mod.F90 b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3_mod.F90 new file mode 100644 index 000000000..b15f2efd9 --- /dev/null +++ b/physics/MP/GFDL/v3_2022/gfdl_cloud_microphys_v3_mod.F90 @@ -0,0 +1,7334 @@ +!>\file gfdl_cloud_microphys_v3_mod.F90 +!! This file contains the entity of GFDL MP scheme Version 3. + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the FV3 dynamical core. +!* +!* The FV3 dynamical core is free software: you can redistribute it +!* and/or modify it under the terms of the +!* GNU Lesser General Public License as published by the +!* Free Software Foundation, either version 3 of the License, or +!* (at your option) any later version. +!* +!* The FV3 dynamical core is distributed in the hope that it will be +!* useful, but WITHOUT ANY WARRANTY; without even the implied warranty +!* of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +!* See the GNU General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with the FV3 dynamical core. +!* If not, see . +!*********************************************************************** + +! ======================================================================= +! GFDL Cloud Microphysics Package (GFDL MP) Version 3 +! The algorithms are originally derived from Lin et al. (1983). +! Most of the key elements have been simplified / improved. +! This code at this stage bears little to no similarity to the original Lin MP in ZETAC. +! Developers: Linjiong Zhou and the GFDL FV3 Team +! References: +! Version 0: Chen and Lin (2011 doi: 10.1029/2011GL047629, 2013 doi: 10.1175/JCLI-D-12-00061.1) +! Version 1: Zhou et al. (2019 doi: 10.1175/BAMS-D-17-0246.1) +! Version 2: Harris et al. (2020 doi: 10.1029/2020MS002223), Zhou et al. (2022 doi: 10.25923/pz3c-8b96) +! Version 3: Zhou et al. (2022 doi: 10.1029/2021MS002971) +! ======================================================================= + +module gfdl_cloud_microphys_v3_mod + use machine, only: kind_phys, r8 => kind_dbl_prec + use module_gfdlmp_param, only: read_gfdlmp_nml, & + t_min, t_sub, tau_r2g, tau_smlt, tau_gmlt, dw_land, dw_ocean, vw_fac, vi_fac, & + vr_fac, vs_fac, vg_fac, ql_mlt, do_qa, fix_negative, vw_max, vi_max, vs_max, & + vg_max, vr_max, qs_mlt, qs0_crt, ql0_max, qi0_max, qi0_crt, ifflag, rh_inc, rh_ins,& + rh_inr, const_vw, const_vi, const_vs, const_vg, const_vr, rthresh, ccn_l, ccn_o, & + igflag, c_paut, tau_imlt, tau_v2l, tau_l2v, tau_i2s, tau_l2r, qi_lim, ql_gen, & + do_hail, inflag, c_psacw, c_psaci, c_pracs, c_psacr, c_pgacr, c_pgacs, c_pgacw, & + c_pgaci, z_slope_liq, z_slope_ice, prog_ccn, c_pracw, c_praci, rad_snow, & + rad_graupel, rad_rain, cld_min, sedflag, sed_fac, do_sedi_uv, do_sedi_w, & + do_sedi_heat, icloud_f, irain_f, xr_a, xr_b, xr_c, ntimes, tau_revp, tice_mlt, & + do_cond_timescale, mp_time, consv_checker, te_err, tw_err, use_rhc_cevap, & + use_rhc_revap, tau_wbf, do_warm_rain_mp, rh_thres, f_dq_p, f_dq_m, do_cld_adj, & + rhc_cevap, rhc_revap, beta, liq_ice_combine, rewflag, reiflag, rerflag, resflag, & + regflag, rewmin, rewmax, reimin, reimax, rermin, rermax, resmin, resmax, regmin, & + regmax, fs2g_fac, fi2s_fac, fi2g_fac, do_sedi_melt, radr_flag, rads_flag, & + radg_flag, do_wbf, do_psd_water_fall, do_psd_ice_fall, n0w_sig, n0i_sig, n0r_sig, & + n0s_sig, n0g_sig, n0h_sig, n0w_exp, n0i_exp, n0r_exp, n0s_exp, n0g_exp, n0h_exp, & + muw, mui, mur, mus, mug, muh, alinw, alini, alinr, alins, aling, alinh, blinw, & + blini, blinr, blins, bling, blinh, do_new_acc_water, do_new_acc_ice, is_fac, & + ss_fac, gs_fac, rh_fac_evap, rh_fac_cond, snow_grauple_combine, do_psd_water_num, & + do_psd_ice_num, vdiffflag, rewfac, reifac, cp_heating, nconds, do_evap_timescale, & + delay_cond_evap, do_subgrid_proc, fast_fr_mlt, fast_dep_sub, qi_gen, tice + use physcons, only: grav => con_g, & + rgrav => con_1ovg, & + pi => con_pi, & + boltzmann => con_boltz, & + avogadro => con_sbc, & + rdgas => con_rd, & + rvgas => con_rv, & + zvir => con_fvirt, & + runiver => con_runiver, & + cp_air => con_cp, & + c_ice => con_csol, & + !c_liq => con_cliq, & + !e00 => con_psat, & + hlv => con_hvap, & + hlf => con_hfus, & + rho0 => rhoair_IFS, & + rhos => rhosnow, & + one_r8 => con_one, & + con_amd, con_amw, visd, & + visk, vdifu, tcond, cdg, & + cdh, rhow => rhocw, & + rhoi => rhoci, & + rhor => rhocr, & + rhog => rhocg, & + rhoh => rhoch, qcmin, qfmin + private + + ! ----------------------------------------------------------------------- + ! interface functions + ! ----------------------------------------------------------------------- + + interface wqs + procedure wes_t + procedure wqs_trho + procedure wqs_ptqv + end interface wqs + + interface mqs + procedure mes_t + procedure mqs_trho + procedure mqs_ptqv + end interface mqs + + interface iqs + procedure ies_t + procedure iqs_trho + procedure iqs_ptqv + end interface iqs + + interface mhc + procedure mhc3 + procedure mhc4 + procedure mhc6 + end interface mhc + + interface wet_bulb + procedure wet_bulb_dry + procedure wet_bulb_moist + end interface wet_bulb + + ! ----------------------------------------------------------------------- + ! public subroutines and functions + ! ----------------------------------------------------------------------- + + public :: gfdl_cloud_microphys_v3_mod_init + public :: gfdl_cloud_microphys_v3_mod_driver + public :: gfdl_cloud_microphys_v3_mod_end + public :: cld_sat_adj, cld_eff_rad, rad_ref + public :: qs_init, wqs, mqs, mqs3d + public :: wet_bulb + public :: mtetw + + ! ----------------------------------------------------------------------- + ! initialization conditions + ! ----------------------------------------------------------------------- + + logical :: tables_are_initialized = .false. ! initialize satuation tables + + ! ----------------------------------------------------------------------- + ! Physical constants that differ from physcons + ! ----------------------------------------------------------------------- + real(kind_phys), parameter :: c_liq = 4.218e3 + real(kind = r8), parameter :: e00 = 611.21 ! saturation vapor pressure at 0 deg C (Pa), ref: IFS + + ! ----------------------------------------------------------------------- + ! derived physics constants + ! ----------------------------------------------------------------------- + real(kind_phys), parameter :: mmd = con_amd*1e-3 ! (g/mol) -> (kg/mol) + real(kind_phys), parameter :: mmv = con_amw*1e-3 ! (g/mol) -> (kg/mol) + real(kind_phys), parameter :: cv_air = cp_air - rdgas + real(kind_phys), parameter :: cp_vap = 4.0 * rvgas + real(kind_phys), parameter :: cv_vap = 3.0 * rvgas + real(kind_phys), parameter :: dc_vap = cp_vap - c_liq + real(kind_phys), parameter :: dc_ice = c_liq - c_ice + real(kind_phys), parameter :: d2_ice = cp_vap - c_ice + + ! ----------------------------------------------------------------------- + ! predefined parameters + ! ----------------------------------------------------------------------- + + integer, parameter :: length = 2621 ! length of the saturation table + real(kind_phys), parameter :: dz_min = 1.0e-2 ! used for correcting flipped height (m) + real(kind_phys), parameter :: dt_fr = 8.0 ! t_wfr - dt_fr: minimum temperature water can exist (Moore and Molinero 2011) + integer :: cfflag = 1 ! cloud fraction scheme + ! 1: GFDL cloud scheme + ! 2: Xu and Randall (1996) + ! 3: Park et al. (2016) + ! 4: Gultepe and Isaac (2007) + + ! ----------------------------------------------------------------------- + ! local shared variables + ! ----------------------------------------------------------------------- + ! Set during init. + real(kind = r8) :: lv0 + real(kind = r8) :: li0 + real(kind = r8) :: li2 + + real(kind_phys) :: acco (3, 10), acc (20) + real(kind_phys) :: cracs, csacr, cgacr, cgacs, csacw, craci, csaci, cgacw, cgaci, cracw + real(kind_phys) :: cssub (5), cgsub (5), crevp (5), cgfr (2), csmlt (4), cgmlt (4) + + real(kind_phys) :: t_wfr, fac_rc, c_air, c_vap, d0_vap + + real (kind = r8) :: lv00, li00, li20, cpaut + real (kind = r8) :: d1_vap, d1_ice, c1_vap, c1_liq, c1_ice + real (kind = r8) :: normw, normr, normi, norms, normg, normh + real (kind = r8) :: expow, expor, expoi, expos, expog, expoh + real (kind = r8) :: pcaw, pcar, pcai, pcas, pcag, pcah + real (kind = r8) :: pcbw, pcbr, pcbi, pcbs, pcbg, pcbh + real (kind = r8) :: edaw, edar, edai, edas, edag, edah + real (kind = r8) :: edbw, edbr, edbi, edbs, edbg, edbh + real (kind = r8) :: oeaw, oear, oeai, oeas, oeag, oeah + real (kind = r8) :: oebw, oebr, oebi, oebs, oebg, oebh + real (kind = r8) :: rraw, rrar, rrai, rras, rrag, rrah + real (kind = r8) :: rrbw, rrbr, rrbi, rrbs, rrbg, rrbh + real (kind = r8) :: tvaw, tvar, tvai, tvas, tvag, tvah + real (kind = r8) :: tvbw, tvbr, tvbi, tvbs, tvbg, tvbh + + real(kind_phys), allocatable :: table0 (:), table1 (:), table2 (:), table3 (:), table4 (:) + real(kind_phys), allocatable :: des0 (:), des1 (:), des2 (:), des3 (:), des4 (:) + +contains + +! ======================================================================= +! GFDL cloud microphysics initialization +! ======================================================================= + +subroutine gfdl_cloud_microphys_v3_mod_init (me, master, nlunit, input_nml_file, logunit, & + fn_nml, hydrostatic, errmsg, errflg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: me + integer, intent (in) :: master + integer, intent (in) :: nlunit + integer, intent (in) :: logunit + + character (len = 64), intent (in) :: fn_nml + character (len = *), intent (in) :: input_nml_file (:) + logical, intent (in) :: hydrostatic + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: ios + logical :: exists + + ! Initialize CCPP error-handling + errflg = 0 + errmsg = '' + + ! ----------------------------------------------------------------------- + ! Read namelist + ! ----------------------------------------------------------------------- + call read_gfdlmp_nml(errmsg = errmsg, errflg = errflg, unit = nlunit, & + input_nml_file = input_nml_file, fn_nml = fn_nml, version=3, & + iostat = ios) + + ! Initialize scheme parameters + lv0 = hlv - dc_vap * tice ! 3148711.3338762247, evaporation latent heat coeff. at 0 deg K (J/kg) + li0 = hlf - dc_ice * tice ! 242413.92000000004, fussion latent heat coeff. at 0 deg K (J/kg) + li2 = lv0 + li0 ! 2906297.413876225, sublimation latent heat coeff. at 0 deg K (J/kg) + + ! ----------------------------------------------------------------------- + ! write version number and namelist to log file + ! ----------------------------------------------------------------------- + if (me == master) then + write (logunit, *) " ================================================================== " + write (logunit, *) "gfdl_cloud_microphysics_nml_v3" + endif + + ! ----------------------------------------------------------------------- + ! initialize microphysics variables + ! ----------------------------------------------------------------------- + + if (.not. tables_are_initialized) call qs_init + + call setup_mp + + ! ----------------------------------------------------------------------- + ! define various heat capacities and latent heat coefficients at 0 deg K + ! ----------------------------------------------------------------------- + + call setup_mhc_lhc (hydrostatic) + +end subroutine gfdl_cloud_microphys_v3_mod_init + +! ======================================================================= +! GFDL cloud microphysics driver +! ======================================================================= + +subroutine gfdl_cloud_microphys_v3_mod_driver (qv, ql, qr, qi, qs, qg, qa, qnl, qni, pt, wa, & + ua, va, delz, delp, gsize, dtm, hs, water, rain, ice, snow, graupel, & + hydrostatic, is, ie, ks, ke, q_con, cappa, consv_te, adj_vmr, te, dte, & + prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, last_step, do_inline_mp) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp + + real(kind_phys), intent (in) :: dtm + + real(kind_phys), intent (in), dimension (is:ie) :: hs, gsize + + real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: qnl, qni + + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa, te + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real(kind_phys), intent (inout), dimension (is:, ks:) :: q_con, cappa + + real(kind_phys), intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel + + real(kind_phys), intent (out), dimension (is:ie, ks:ke) :: adj_vmr + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! major cloud microphysics driver + ! ----------------------------------------------------------------------- + + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, .false., .true.) + +end subroutine gfdl_cloud_microphys_v3_mod_driver + +! ======================================================================= +! GFDL cloud microphysics end +! ======================================================================= + +subroutine gfdl_cloud_microphys_v3_mod_end + + implicit none + + ! ----------------------------------------------------------------------- + ! free up memory + ! ----------------------------------------------------------------------- + + deallocate (table0) + deallocate (table1) + deallocate (table2) + deallocate (table3) + deallocate (table4) + deallocate (des0) + deallocate (des1) + deallocate (des2) + deallocate (des3) + deallocate (des4) + + tables_are_initialized = .false. + +end subroutine gfdl_cloud_microphys_v3_mod_end + +! ======================================================================= +! setup cloud microphysics parameters +! ======================================================================= + +subroutine setup_mp + + implicit none + + integer :: i, k + + real(kind_phys) :: gcon, hcon, scm3, pisq, act (20), ace (20), occ (3), aone + + ! ----------------------------------------------------------------------- + ! complete freezing temperature + ! ----------------------------------------------------------------------- + + if (do_warm_rain_mp) then + t_wfr = t_min + else + t_wfr = tice - 40.0 + endif + + ! ----------------------------------------------------------------------- + ! cloud water autoconversion, Hong et al. (2004) + ! ----------------------------------------------------------------------- + + fac_rc = (4. / 3.) * pi * rhow * rthresh ** 3 + + aone = 2. / 9. * (3. / 4.) ** (4. / 3.) / pi ** (1. / 3.) + cpaut = c_paut * aone * grav / visd + + ! ----------------------------------------------------------------------- + ! terminal velocities parameters, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + gcon = (4. * grav * rhog / (3. * cdg * rho0)) ** 0.5 + hcon = (4. * grav * rhoh / (3. * cdh * rho0)) ** 0.5 + + ! ----------------------------------------------------------------------- + ! part of the slope parameters + ! ----------------------------------------------------------------------- + + normw = pi * rhow * n0w_sig * gamma (muw + 3) + normi = pi * rhoi * n0i_sig * gamma (mui + 3) + normr = pi * rhor * n0r_sig * gamma (mur + 3) + norms = pi * rhos * n0s_sig * gamma (mus + 3) + normg = pi * rhog * n0g_sig * gamma (mug + 3) + normh = pi * rhoh * n0h_sig * gamma (muh + 3) + + expow = exp (n0w_exp / (muw + 3) * log (10.)) + expoi = exp (n0i_exp / (mui + 3) * log (10.)) + expor = exp (n0r_exp / (mur + 3) * log (10.)) + expos = exp (n0s_exp / (mus + 3) * log (10.)) + expog = exp (n0g_exp / (mug + 3) * log (10.)) + expoh = exp (n0h_exp / (muh + 3) * log (10.)) + + ! ----------------------------------------------------------------------- + ! parameters for particle concentration (pc), effective diameter (ed), + ! optical extinction (oe), radar reflectivity factor (rr), and + ! mass-weighted terminal velocity (tv) + ! ----------------------------------------------------------------------- + + pcaw = exp (3 / (muw + 3) * log (n0w_sig)) * gamma (muw) * exp (3 * n0w_exp / (muw + 3) * log (10.)) + pcai = exp (3 / (mui + 3) * log (n0i_sig)) * gamma (mui) * exp (3 * n0i_exp / (mui + 3) * log (10.)) + pcar = exp (3 / (mur + 3) * log (n0r_sig)) * gamma (mur) * exp (3 * n0r_exp / (mur + 3) * log (10.)) + pcas = exp (3 / (mus + 3) * log (n0s_sig)) * gamma (mus) * exp (3 * n0s_exp / (mus + 3) * log (10.)) + pcag = exp (3 / (mug + 3) * log (n0g_sig)) * gamma (mug) * exp (3 * n0g_exp / (mug + 3) * log (10.)) + pcah = exp (3 / (muh + 3) * log (n0h_sig)) * gamma (muh) * exp (3 * n0h_exp / (muh + 3) * log (10.)) + + pcbw = exp (muw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + pcbi = exp (mui / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + pcbr = exp (mur / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + pcbs = exp (mus / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + pcbg = exp (mug / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + pcbh = exp (muh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + edaw = exp (- 1. / (muw + 3) * log (n0w_sig)) * (muw + 2) * exp (- n0w_exp / (muw + 3) * log (10.)) + edai = exp (- 1. / (mui + 3) * log (n0i_sig)) * (mui + 2) * exp (- n0i_exp / (mui + 3) * log (10.)) + edar = exp (- 1. / (mur + 3) * log (n0r_sig)) * (mur + 2) * exp (- n0r_exp / (mur + 3) * log (10.)) + edas = exp (- 1. / (mus + 3) * log (n0s_sig)) * (mus + 2) * exp (- n0s_exp / (mus + 3) * log (10.)) + edag = exp (- 1. / (mug + 3) * log (n0g_sig)) * (mug + 2) * exp (- n0g_exp / (mug + 3) * log (10.)) + edah = exp (- 1. / (muh + 3) * log (n0h_sig)) * (muh + 2) * exp (- n0h_exp / (muh + 3) * log (10.)) + + edbw = exp (1. / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + edbi = exp (1. / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + edbr = exp (1. / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + edbs = exp (1. / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + edbg = exp (1. / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + edbh = exp (1. / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + oeaw = exp (1. / (muw + 3) * log (n0w_sig)) * pi * gamma (muw + 2) * & + exp (n0w_exp / (muw + 3) * log (10.)) + oeai = exp (1. / (mui + 3) * log (n0i_sig)) * pi * gamma (mui + 2) * & + exp (n0i_exp / (mui + 3) * log (10.)) + oear = exp (1. / (mur + 3) * log (n0r_sig)) * pi * gamma (mur + 2) * & + exp (n0r_exp / (mur + 3) * log (10.)) + oeas = exp (1. / (mus + 3) * log (n0s_sig)) * pi * gamma (mus + 2) * & + exp (n0s_exp / (mus + 3) * log (10.)) + oeag = exp (1. / (mug + 3) * log (n0g_sig)) * pi * gamma (mug + 2) * & + exp (n0g_exp / (mug + 3) * log (10.)) + oeah = exp (1. / (muh + 3) * log (n0h_sig)) * pi * gamma (muh + 2) * & + exp (n0h_exp / (muh + 3) * log (10.)) + + oebw = 2 * exp ((muw + 2) / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + oebi = 2 * exp ((mui + 2) / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + oebr = 2 * exp ((mur + 2) / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + oebs = 2 * exp ((mus + 2) / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + oebg = 2 * exp ((mug + 2) / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + oebh = 2 * exp ((muh + 2) / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + rraw = exp (- 3 / (muw + 3) * log (n0w_sig)) * gamma (muw + 6) * & + exp (- 3 * n0w_exp / (muw + 3) * log (10.)) + rrai = exp (- 3 / (mui + 3) * log (n0i_sig)) * gamma (mui + 6) * & + exp (- 3 * n0i_exp / (mui + 3) * log (10.)) + rrar = exp (- 3 / (mur + 3) * log (n0r_sig)) * gamma (mur + 6) * & + exp (- 3 * n0r_exp / (mur + 3) * log (10.)) + rras = exp (- 3 / (mus + 3) * log (n0s_sig)) * gamma (mus + 6) * & + exp (- 3 * n0s_exp / (mus + 3) * log (10.)) + rrag = exp (- 3 / (mug + 3) * log (n0g_sig)) * gamma (mug + 6) * & + exp (- 3 * n0g_exp / (mug + 3) * log (10.)) + rrah = exp (- 3 / (muh + 3) * log (n0h_sig)) * gamma (muh + 6) * & + exp (- 3 * n0h_exp / (muh + 3) * log (10.)) + + rrbw = exp ((muw + 6) / (muw + 3) * log (pi * rhow * gamma (muw + 3))) + rrbi = exp ((mui + 6) / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) + rrbr = exp ((mur + 6) / (mur + 3) * log (pi * rhor * gamma (mur + 3))) + rrbs = exp ((mus + 6) / (mus + 3) * log (pi * rhos * gamma (mus + 3))) + rrbg = exp ((mug + 6) / (mug + 3) * log (pi * rhog * gamma (mug + 3))) + rrbh = exp ((muh + 6) / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) + + tvaw = exp (- blinw / (muw + 3) * log (n0w_sig)) * alinw * gamma (muw + blinw + 3) * & + exp (- blinw * n0w_exp / (muw + 3) * log (10.)) + tvai = exp (- blini / (mui + 3) * log (n0i_sig)) * alini * gamma (mui + blini + 3) * & + exp (- blini * n0i_exp / (mui + 3) * log (10.)) + tvar = exp (- blinr / (mur + 3) * log (n0r_sig)) * alinr * gamma (mur + blinr + 3) * & + exp (- blinr * n0r_exp / (mur + 3) * log (10.)) + tvas = exp (- blins / (mus + 3) * log (n0s_sig)) * alins * gamma (mus + blins + 3) * & + exp (- blins * n0s_exp / (mus + 3) * log (10.)) + tvag = exp (- bling / (mug + 3) * log (n0g_sig)) * aling * gamma (mug + bling + 3) * & + exp (- bling * n0g_exp / (mug + 3) * log (10.)) * gcon + tvah = exp (- blinh / (muh + 3) * log (n0h_sig)) * alinh * gamma (muh + blinh + 3) * & + exp (- blinh * n0h_exp / (muh + 3) * log (10.)) * hcon + + tvbw = exp (blinw / (muw + 3) * log (pi * rhow * gamma (muw + 3))) * gamma (muw + 3) + tvbi = exp (blini / (mui + 3) * log (pi * rhoi * gamma (mui + 3))) * gamma (mui + 3) + tvbr = exp (blinr / (mur + 3) * log (pi * rhor * gamma (mur + 3))) * gamma (mur + 3) + tvbs = exp (blins / (mus + 3) * log (pi * rhos * gamma (mus + 3))) * gamma (mus + 3) + tvbg = exp (bling / (mug + 3) * log (pi * rhog * gamma (mug + 3))) * gamma (mug + 3) + tvbh = exp (blinh / (muh + 3) * log (pi * rhoh * gamma (muh + 3))) * gamma (muh + 3) + + ! ----------------------------------------------------------------------- + ! Schmidt number, Sc ** (1 / 3) in Lin et al. (1983) + ! ----------------------------------------------------------------------- + + scm3 = exp (1. / 3. * log (visk / vdifu)) + + pisq = pi * pi + + ! ----------------------------------------------------------------------- + ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cracw = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / & + (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * & + exp ((1 - blinr) * log (expor)) + craci = pi * n0r_sig * alinr * gamma (2 + mur + blinr) / & + (4. * exp ((2 + mur + blinr) / (mur + 3) * log (normr))) * & + exp ((1 - blinr) * log (expor)) + csacw = pi * n0s_sig * alins * gamma (2 + mus + blins) / & + (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * & + exp ((1 - blins) * log (expos)) + csaci = pi * n0s_sig * alins * gamma (2 + mus + blins) / & + (4. * exp ((2 + mus + blins) / (mus + 3) * log (norms))) * & + exp ((1 - blins) * log (expos)) + if (do_hail) then + cgacw = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / & + (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * & + exp ((1 - blinh) * log (expoh)) + cgaci = pi * n0h_sig * alinh * gamma (2 + muh + blinh) * hcon / & + (4. * exp ((2 + muh + blinh) / (muh + 3) * log (normh))) * & + exp ((1 - blinh) * log (expoh)) + else + cgacw = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / & + (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * & + exp ((1 - bling) * log (expog)) + cgaci = pi * n0g_sig * aling * gamma (2 + mug + bling) * gcon / & + (4. * exp ((2 + mug + bling) / (mug + 3) * log (normg))) * & + exp ((1 - bling) * log (expog)) + endif + + if (do_new_acc_water) then + + cracw = pisq * n0r_sig * n0w_sig * rhow / 24. + csacw = pisq * n0s_sig * n0w_sig * rhow / 24. + if (do_hail) then + cgacw = pisq * n0h_sig * n0w_sig * rhow / 24. + else + cgacw = pisq * n0g_sig * n0w_sig * rhow / 24. + endif + + endif + + if (do_new_acc_ice) then + + craci = pisq * n0r_sig * n0i_sig * rhoi / 24. + csaci = pisq * n0s_sig * n0i_sig * rhoi / 24. + if (do_hail) then + cgaci = pisq * n0h_sig * n0i_sig * rhoi / 24. + else + cgaci = pisq * n0g_sig * n0i_sig * rhoi / 24. + endif + + endif + + cracw = cracw * c_pracw + craci = craci * c_praci + csacw = csacw * c_psacw + csaci = csaci * c_psaci + cgacw = cgacw * c_pgacw + cgaci = cgaci * c_pgaci + + ! ----------------------------------------------------------------------- + ! accretion between cloud water, cloud ice, rain, snow, and graupel or hail, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cracs = pisq * n0r_sig * n0s_sig * rhos / 24. + csacr = pisq * n0s_sig * n0r_sig * rhor / 24. + if (do_hail) then + cgacr = pisq * n0h_sig * n0r_sig * rhor / 24. + cgacs = pisq * n0h_sig * n0s_sig * rhos / 24. + else + cgacr = pisq * n0g_sig * n0r_sig * rhor / 24. + cgacs = pisq * n0g_sig * n0s_sig * rhos / 24. + endif + + cracs = cracs * c_pracs + csacr = csacr * c_psacr + cgacr = cgacr * c_pgacr + cgacs = cgacs * c_pgacs + + ! act / ace / acc: + ! 1 - 2: racs (s - r) + ! 3 - 4: sacr (r - s) + ! 5 - 6: gacr (r - g) + ! 7 - 8: gacs (s - g) + ! 9 - 10: racw (w - r) + ! 11 - 12: raci (i - r) + ! 13 - 14: sacw (w - s) + ! 15 - 16: saci (i - s) + ! 17 - 18: sacw (w - g) + ! 19 - 20: saci (i - g) + + act (1) = norms + act (2) = normr + act (3) = act (2) + act (4) = act (1) + act (5) = act (2) + if (do_hail) then + act (6) = normh + else + act (6) = normg + endif + act (7) = act (1) + act (8) = act (6) + act (9) = normw + act (10) = act (2) + act (11) = normi + act (12) = act (2) + act (13) = act (9) + act (14) = act (1) + act (15) = act (11) + act (16) = act (1) + act (17) = act (9) + act (18) = act (6) + act (19) = act (11) + act (20) = act (6) + + ace (1) = expos + ace (2) = expor + ace (3) = ace (2) + ace (4) = ace (1) + ace (5) = ace (2) + if (do_hail) then + ace (6) = expoh + else + ace (6) = expog + endif + ace (7) = ace (1) + ace (8) = ace (6) + ace (9) = expow + ace (10) = ace (2) + ace (11) = expoi + ace (12) = ace (2) + ace (13) = ace (9) + ace (14) = ace (1) + ace (15) = ace (11) + ace (16) = ace (1) + ace (17) = ace (9) + ace (18) = ace (6) + ace (19) = ace (11) + ace (20) = ace (6) + + acc (1) = mus + acc (2) = mur + acc (3) = acc (2) + acc (4) = acc (1) + acc (5) = acc (2) + if (do_hail) then + acc (6) = muh + else + acc (6) = mug + endif + acc (7) = acc (1) + acc (8) = acc (6) + acc (9) = muw + acc (10) = acc (2) + acc (11) = mui + acc (12) = acc (2) + acc (13) = acc (9) + acc (14) = acc (1) + acc (15) = acc (11) + acc (16) = acc (1) + acc (17) = acc (9) + acc (18) = acc (6) + acc (19) = acc (11) + acc (20) = acc (6) + + occ (1) = 1. + occ (2) = 2. + occ (3) = 1. + + do i = 1, 3 + do k = 1, 10 + acco (i, k) = occ (i) * gamma (6 + acc (2 * k - 1) - i) * gamma (acc (2 * k) + i - 1) / & + (exp ((6 + acc (2 * k - 1) - i) / (acc (2 * k - 1) + 3) * log (act (2 * k - 1))) * & + exp ((acc (2 * k) + i - 1) / (acc (2 * k) + 3) * log (act (2 * k)))) * & + exp ((i - 3) * log (ace (2 * k - 1))) * exp ((4 - i) * log (ace (2 * k))) + enddo + enddo + + ! ----------------------------------------------------------------------- + ! rain evaporation, snow sublimation, and graupel or hail sublimation, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + crevp (1) = 2. * pi * vdifu * tcond * rvgas * n0r_sig * gamma (1 + mur) / & + exp ((1 + mur) / (mur + 3) * log (normr)) * exp (2.0 * log (expor)) + crevp (2) = 0.78 + crevp (3) = 0.31 * scm3 * sqrt (alinr / visk) * gamma ((3 + 2 * mur + blinr) / 2) / & + exp ((3 + 2 * mur + blinr) / (mur + 3) / 2 * log (normr)) * & + exp ((1 + mur) / (mur + 3) * log (normr)) / gamma (1 + mur) * & + exp ((- 1 - blinr) / 2. * log (expor)) + crevp (4) = tcond * rvgas + crevp (5) = vdifu + + cssub (1) = 2. * pi * vdifu * tcond * rvgas * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + cssub (2) = 0.78 + cssub (3) = 0.31 * scm3 * sqrt (alins / visk) * gamma ((3 + 2 * mus + blins) / 2) / & + exp ((3 + 2 * mus + blins) / (mus + 3) / 2 * log (norms)) * & + exp ((1 + mus) / (mus + 3) * log (norms)) / gamma (1 + mus) * & + exp ((- 1 - blins) / 2. * log (expos)) + cssub (4) = tcond * rvgas + cssub (5) = vdifu + + if (do_hail) then + cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + cgsub (2) = 0.78 + cgsub (3) = 0.31 * scm3 * sqrt (alinh * hcon / visk) * gamma ((3 + 2 * muh + blinh) / 2) / & + exp (1. / (muh + 3) * (3 + 2 * muh + blinh) / 2 * log (normh)) * & + exp (1. / (muh + 3) * (1 + muh) * log (normh)) / gamma (1 + muh) * & + exp ((- 1 - blinh) / 2. * log (expoh)) + else + cgsub (1) = 2. * pi * vdifu * tcond * rvgas * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + cgsub (2) = 0.78 + cgsub (3) = 0.31 * scm3 * sqrt (aling * gcon / visk) * gamma ((3 + 2 * mug + bling) / 2) / & + exp ((3 + 2 * mug + bling) / (mug + 3) / 2 * log (normg)) * & + exp ((1 + mug) / (mug + 3) * log (normg)) / gamma (1 + mug) * & + exp ((- 1 - bling) / 2. * log (expog)) + endif + cgsub (4) = tcond * rvgas + cgsub (5) = vdifu + + ! ----------------------------------------------------------------------- + ! snow melting, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + csmlt (1) = 2. * pi * tcond * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + csmlt (2) = 2. * pi * vdifu * n0s_sig * gamma (1 + mus) / & + exp ((1 + mus) / (mus + 3) * log (norms)) * exp (2.0 * log (expos)) + csmlt (3) = cssub (2) + csmlt (4) = cssub (3) + + ! ----------------------------------------------------------------------- + ! graupel or hail melting, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + if (do_hail) then + cgmlt (1) = 2. * pi * tcond * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + cgmlt (2) = 2. * pi * vdifu * n0h_sig * gamma (1 + muh) / & + exp ((1 + muh) / (muh + 3) * log (normh)) * exp (2.0 * log (expoh)) + else + cgmlt (1) = 2. * pi * tcond * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + cgmlt (2) = 2. * pi * vdifu * n0g_sig * gamma (1 + mug) / & + exp ((1 + mug) / (mug + 3) * log (normg)) * exp (2.0 * log (expog)) + endif + cgmlt (3) = cgsub (2) + cgmlt (4) = cgsub (3) + + ! ----------------------------------------------------------------------- + ! rain freezing, Lin et al. (1983) + ! ----------------------------------------------------------------------- + + cgfr (1) = 1.e2 / 36 * pisq * n0r_sig * rhor * gamma (6 + mur) / & + exp ((6 + mur) / (mur + 3) * log (normr)) * exp (- 3.0 * log (expor)) + cgfr (2) = 0.66 + +end subroutine setup_mp + +! ======================================================================= +! define various heat capacities and latent heat coefficients at 0 deg K +! ======================================================================= + +subroutine setup_mhc_lhc (hydrostatic) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: hydrostatic + + if (hydrostatic) then + c_air = cp_air + c_vap = cp_vap + do_sedi_w = .false. + else + c_air = cv_air + c_vap = cv_vap + endif + d0_vap = c_vap - c_liq + + ! scaled constants (to reduce float point errors for 32-bit) + + d1_vap = d0_vap / c_air + d1_ice = dc_ice / c_air + + lv00 = (hlv - d0_vap * tice) / c_air + li00 = (hlf - dc_ice * tice) / c_air + li20 = lv00 + li00 + + c1_vap = c_vap / c_air + c1_liq = c_liq / c_air + c1_ice = c_ice / c_air + +end subroutine setup_mhc_lhc + +! ======================================================================= +! major cloud microphysics driver +! ======================================================================= + +subroutine mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, & + qa, qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, last_step, do_inline_mp, do_mp_fast, do_mp_full) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_inline_mp + logical, intent (in) :: do_mp_fast, do_mp_full + + real(kind_phys), intent (in) :: dtm + + real(kind_phys), intent (in), dimension (is:ie) :: gsize, hs + + real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: qnl, qni + + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, ua, va, wa + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real(kind_phys), intent (inout), dimension (is:, ks:) :: q_con, cappa + + real(kind_phys), intent (inout), dimension (is:ie) :: water, rain, ice, snow, graupel + + real(kind_phys), intent (out), dimension (is:ie, ks:ke) :: te, adj_vmr + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k + + real(kind_phys) :: rh_adj, rh_rain, ccn0, cin0, cond, q1, q2 + real(kind_phys) :: convt, dts, q_cond, t_lnd, t_ocn, h_var, tmp, nl, ni + + real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, dp, dz, dp0 + real(kind_phys), dimension (ks:ke) :: qvz, qlz, qrz, qiz, qsz, qgz, qaz + real(kind_phys), dimension (ks:ke) :: den, pz, denfac, ccn, cin + real(kind_phys), dimension (ks:ke) :: u, v, w + + real(kind_phys), dimension (is:ie, ks:ke) :: pcw, edw, oew, rrw, tvw + real(kind_phys), dimension (is:ie, ks:ke) :: pci, edi, oei, rri, tvi + real(kind_phys), dimension (is:ie, ks:ke) :: pcr, edr, oer, rrr, tvr + real(kind_phys), dimension (is:ie, ks:ke) :: pcs, eds, oes, rrs, tvs + real(kind_phys), dimension (is:ie, ks:ke) :: pcg, edg, oeg, rrg, tvg + + real(kind_phys), dimension (is:ie) :: condensation, deposition + real(kind_phys), dimension (is:ie) :: evaporation, sublimation + + real (kind = r8) :: con_r8, c8, cp8 + + real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_d, te_end_d, tw_beg_d, tw_end_d + real (kind = r8), dimension (is:ie, ks:ke) :: te_beg_m, te_end_m, tw_beg_m, tw_end_m + + real (kind = r8), dimension (is:ie) :: te_b_beg_d, te_b_end_d, tw_b_beg_d, tw_b_end_d, te_loss + real (kind = r8), dimension (is:ie) :: te_b_beg_m, te_b_end_m, tw_b_beg_m, tw_b_end_m + + real (kind = r8), dimension (ks:ke) :: tz, tzuv, tzw + + ! ----------------------------------------------------------------------- + ! time steps + ! ----------------------------------------------------------------------- + + ntimes = max (ntimes, int (dtm / min (dtm, mp_time))) + dts = dtm / real (ntimes, kind=kind_phys) + + ! ----------------------------------------------------------------------- + ! initialization of total energy difference and condensation diag + ! ----------------------------------------------------------------------- + + dte = 0.0 + cond = 0.0 + adj_vmr = 1.0 + + condensation = 0.0 + deposition = 0.0 + evaporation = 0.0 + sublimation = 0.0 + + ! ----------------------------------------------------------------------- + ! unit convert to mm/day + ! ----------------------------------------------------------------------- + + convt = 86400. * rgrav / dtm + + do i = is, ie + + ! ----------------------------------------------------------------------- + ! conversion of temperature + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + do k = ks, ke + q_cond = ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k) + tz (k) = pt (i, k) / ((1. + zvir * qv (i, k)) * (1. - q_cond)) + enddo + else + do k = ks, ke + tz (k) = pt (i, k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! calculate base total energy + ! ----------------------------------------------------------------------- + + if (consv_te) then + if (hydrostatic) then + do k = ks, ke + te (i, k) = - c_air * tz (k) * delp (i, k) + enddo + else + do k = ks, ke + te (i, k) = - mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), & + qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav + enddo + endif + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), & + qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), & + delp (i, :), dte (i), 0.0, water (i), rain (i), ice (i), & + snow (i), graupel (i), 0.0, 0.0, dtm, te_beg_m (i, :), & + tw_beg_m (i, :), te_b_beg_m (i), tw_b_beg_m (i), .true., hydrostatic) + endif + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! convert specific ratios to mass mixing ratios + ! ----------------------------------------------------------------------- + + qvz (k) = qv (i, k) + qlz (k) = ql (i, k) + qrz (k) = qr (i, k) + qiz (k) = qi (i, k) + qsz (k) = qs (i, k) + qgz (k) = qg (i, k) + qaz (k) = qa (i, k) + + if (do_inline_mp) then + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + else + con_r8 = one_r8 - qvz (k) + endif + + dp0 (k) = delp (i, k) + dp (k) = delp (i, k) * con_r8 + con_r8 = one_r8 / con_r8 + qvz (k) = qvz (k) * con_r8 + qlz (k) = qlz (k) * con_r8 + qrz (k) = qrz (k) * con_r8 + qiz (k) = qiz (k) * con_r8 + qsz (k) = qsz (k) * con_r8 + qgz (k) = qgz (k) * con_r8 + + ! ----------------------------------------------------------------------- + ! dry air density and layer-mean pressure thickness + ! ----------------------------------------------------------------------- + + dz (k) = delz (i, k) + den (k) = - dp (k) / (grav * dz (k)) + pz (k) = den (k) * rdgas * tz (k) + + ! ----------------------------------------------------------------------- + ! for sedi_momentum transport + ! ----------------------------------------------------------------------- + + u (k) = ua (i, k) + v (k) = va (i, k) + if (.not. hydrostatic) then + w (k) = wa (i, k) + endif + + enddo + + do k = ks, ke + denfac (k) = sqrt (den (ke) / den (k)) + enddo + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & + dp, dte (i), 0.0, water (i), rain (i), ice (i), snow (i), & + graupel (i), 0.0, 0.0, dtm, te_beg_d (i, :), tw_beg_d (i, :), & + te_b_beg_d (i), tw_b_beg_d (i), .false., hydrostatic) + endif + + ! ----------------------------------------------------------------------- + ! cloud condensation nuclei (CCN), cloud ice nuclei (CIN) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + do k = ks, ke + ! boucher and lohmann (1995) + nl = min (1., abs (hs (i)) / (10. * grav)) * & + (10. ** 2.24 * (qnl (i, k) * den (k) * 1.e9) ** 0.257) + & + (1. - min (1., abs (hs (i)) / (10. * grav))) * & + (10. ** 2.06 * (qnl (i, k) * den (k) * 1.e9) ** 0.48) + ni = qni (i, k) + ccn (k) = max (10.0, nl) * 1.e6 + cin (k) = max (10.0, ni) * 1.e6 + ccn (k) = ccn (k) / den (k) + cin (k) = cin (k) / den (k) + enddo + else + ccn0 = (ccn_l * min (1., abs (hs (i)) / (10. * grav)) + & + ccn_o * (1. - min (1., abs (hs (i)) / (10. * grav)))) * 1.e6 + cin0 = 0.0 + do k = ks, ke + ccn (k) = ccn0 / den (k) + cin (k) = cin0 / den (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! subgrid deviation in horizontal direction + ! default area dependent form: use dx ~ 100 km as the base + ! ----------------------------------------------------------------------- + + t_lnd = dw_land * sqrt (gsize (i) / 1.e5) + t_ocn = dw_ocean * sqrt (gsize (i) / 1.e5) + tmp = min (1., abs (hs (i)) / (10. * grav)) + h_var = t_lnd * tmp + t_ocn * (1. - tmp) + h_var = min (0.20, max (0.01, h_var)) + + ! ----------------------------------------------------------------------- + ! relative humidity thresholds + ! ----------------------------------------------------------------------- + + rh_adj = 1. - h_var - rh_inc + rh_rain = max (0.35, rh_adj - rh_inr) + + ! ----------------------------------------------------------------------- + ! fix negative water species from outside + ! ----------------------------------------------------------------------- + + if (fix_negative) & + call neg_adj (ks, ke, tz, dp, qvz, qlz, qrz, qiz, qsz, qgz, cond) + + condensation (i) = condensation (i) + cond * convt + + ! ----------------------------------------------------------------------- + ! fast microphysics loop + ! ----------------------------------------------------------------------- + + if (do_mp_fast) then + + call mp_fast (ks, ke, tz, qvz, qlz, qrz, qiz, qsz, qgz, dtm, dp, den, & + ccn, cin, condensation (i), deposition (i), evaporation (i), & + sublimation (i), denfac, convt, last_step) + + endif + + ! ----------------------------------------------------------------------- + ! full microphysics loop + ! ----------------------------------------------------------------------- + + if (do_mp_full) then + + call mp_full (ks, ke, ntimes, tz, qvz, qlz, qrz, qiz, qsz, qgz, dp, dz, & + u, v, w, den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte (i), & + water (i), rain (i), ice (i), snow (i), graupel (i), prefluxw (i, :), & + prefluxr (i, :), prefluxi (i, :), prefluxs (i, :), prefluxg (i, :), & + condensation (i), deposition (i), evaporation (i), sublimation (i), & + convt, last_step) + + endif + + ! ----------------------------------------------------------------------- + ! cloud fraction diagnostic + ! ----------------------------------------------------------------------- + + if (do_qa .and. last_step) then + call cloud_fraction (ks, ke, pz, den, qvz, qlz, qrz, qiz, qsz, qgz, qaz, & + tz, h_var, gsize (i)) + endif + + ! ======================================================================= + ! calculation of particle concentration (pc), effective diameter (ed), + ! optical extinction (oe), radar reflectivity factor (rr), and + ! mass-weighted terminal velocity (tv) + ! ======================================================================= + + pcw (i, :) = 0.0 + edw (i, :) = 0.0 + oew (i, :) = 0.0 + rrw (i, :) = 0.0 + tvw (i, :) = 0.0 + pci (i, :) = 0.0 + edi (i, :) = 0.0 + oei (i, :) = 0.0 + rri (i, :) = 0.0 + tvi (i, :) = 0.0 + pcr (i, :) = 0.0 + edr (i, :) = 0.0 + oer (i, :) = 0.0 + rrr (i, :) = 0.0 + tvr (i, :) = 0.0 + pcs (i, :) = 0.0 + eds (i, :) = 0.0 + oes (i, :) = 0.0 + rrs (i, :) = 0.0 + tvs (i, :) = 0.0 + pcg (i, :) = 0.0 + edg (i, :) = 0.0 + oeg (i, :) = 0.0 + rrg (i, :) = 0.0 + tvg (i, :) = 0.0 + + do k = ks, ke + if (qlz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qlz (k), den (k), blinw, muw, pcaw, pcbw, pcw (i, k), & + edaw, edbw, edw (i, k), oeaw, oebw, oew (i, k), rraw, rrbw, rrw (i, k), & + tvaw, tvbw, tvw (i, k)) + endif + if (qiz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qiz (k), den (k), blini, mui, pcai, pcbi, pci (i, k), & + edai, edbi, edi (i, k), oeai, oebi, oei (i, k), rrai, rrbi, rri (i, k), & + tvai, tvbi, tvi (i, k)) + endif + if (qrz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qrz (k), den (k), blinr, mur, pcar, pcbr, pcr (i, k), & + edar, edbr, edr (i, k), oear, oebr, oer (i, k), rrar, rrbr, rrr (i, k), & + tvar, tvbr, tvr (i, k)) + endif + if (qsz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qsz (k), den (k), blins, mus, pcas, pcbs, pcs (i, k), & + edas, edbs, eds (i, k), oeas, oebs, oes (i, k), rras, rrbs, rrs (i, k), & + tvas, tvbs, tvs (i, k)) + endif + if (do_hail) then + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), blinh, muh, pcah, pcbh, pcg (i, k), & + edah, edbh, edg (i, k), oeah, oebh, oeg (i, k), rrah, rrbh, rrg (i, k), & + tvah, tvbh, tvg (i, k)) + endif + else + if (qgz (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qgz (k), den (k), bling, mug, pcag, pcbg, pcg (i, k), & + edag, edbg, edg (i, k), oeag, oebg, oeg (i, k), rrag, rrbg, rrg (i, k), & + tvag, tvbg, tvg (i, k)) + endif + endif + enddo + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! update temperature before delp and q update + ! ----------------------------------------------------------------------- + + if (do_sedi_uv) then + do k = ks, ke + c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air + tzuv (k) = 0.5 * (ua (i, k) ** 2 + va (i, k) ** 2 - (u (k) ** 2 + v (k) ** 2)) / c8 + tz (k) = tz (k) + tzuv (k) + enddo + endif + + if (do_sedi_w) then + do k = ks, ke + c8 = mhc (qvz (k), qlz (k), qrz (k), qiz (k), qsz (k), qgz (k)) * c_air + tzw (k) = 0.5 * (wa (i, k) ** 2 - w (k) ** 2) / c8 + tz (k) = tz (k) + tzw (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qvz, qlz, qrz, qiz, qsz, qgz, tz, u, v, w, & + dp, dte (i), 0.0, water (i), rain (i), ice (i), snow (i), & + graupel (i), 0.0, 0.0, dtm, te_end_d (i, :), tw_end_d (i, :), & + te_b_end_d (i), tw_b_end_d (i), .false., hydrostatic, te_loss (i)) + endif + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! convert mass mixing ratios back to specific ratios + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + con_r8 = one_r8 + qvz (k) + q_cond + else + con_r8 = one_r8 + qvz (k) + endif + + delp (i, k) = dp (k) * con_r8 + con_r8 = one_r8 / con_r8 + qvz (k) = qvz (k) * con_r8 + qlz (k) = qlz (k) * con_r8 + qrz (k) = qrz (k) * con_r8 + qiz (k) = qiz (k) * con_r8 + qsz (k) = qsz (k) * con_r8 + qgz (k) = qgz (k) * con_r8 + + q1 = qv (i, k) + ql (i, k) + qr (i, k) + qi (i, k) + qs (i, k) + qg (i, k) + q2 = qvz (k) + qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + adj_vmr (i, k) = ((one_r8 - q1) / (one_r8 - q2)) / (one_r8 + q2 - q1) + + qv (i, k) = qvz (k) + ql (i, k) = qlz (k) + qr (i, k) = qrz (k) + qi (i, k) = qiz (k) + qs (i, k) = qsz (k) + qg (i, k) = qgz (k) + qa (i, k) = qaz (k) + + ! ----------------------------------------------------------------------- + ! calculate some more variables needed outside + ! ----------------------------------------------------------------------- + + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + +#ifdef USE_COND + q_con (i, k) = q_cond +#endif +#ifdef MOIST_CAPPA + tmp = rdgas * (1. + zvir * qvz (k)) + cappa (i, k) = tmp / (tmp + c8) +#endif + + enddo + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! update temperature after delp and q update + ! ----------------------------------------------------------------------- + + if (do_sedi_uv) then + do k = ks, ke + tz (k) = tz (k) - tzuv (k) + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + tzuv (k) = (0.5 * (ua (i, k) ** 2 + va (i, k) ** 2) * dp0 (k) - & + 0.5 * (u (k) ** 2 + v (k) ** 2) * delp (i, k)) / c8 / delp (i, k) + tz (k) = tz (k) + tzuv (k) + enddo + do k = ks, ke + ua (i, k) = u (k) + va (i, k) = v (k) + enddo + endif + + if (do_sedi_w) then + do k = ks, ke + tz (k) = tz (k) - tzw (k) + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + tzw (k) = (0.5 * (wa (i, k) ** 2) * dp0 (k) - & + 0.5 * (w (k) ** 2) * delp (i, k)) / c8 / delp (i, k) + tz (k) = tz (k) + tzw (k) + enddo + do k = ks, ke + wa (i, k) = w (k) + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + call mtetw (ks, ke, qv (i, :), ql (i, :), qr (i, :), qi (i, :), & + qs (i, :), qg (i, :), tz, ua (i, :), va (i, :), wa (i, :), & + delp (i, :), dte (i), 0.0, water (i), rain (i), ice (i), & + snow (i), graupel (i), 0.0, 0.0, dtm, te_end_m (i, :), & + tw_end_m (i, :), te_b_end_m (i), tw_b_end_m (i), .true., hydrostatic) + endif + + ! ----------------------------------------------------------------------- + ! calculate total energy loss or gain + ! ----------------------------------------------------------------------- + + if (consv_te) then + if (hydrostatic) then + do k = ks, ke + te (i, k) = te (i, k) + c_air * tz (k) * delp (i, k) + enddo + else + do k = ks, ke + te (i, k) = te (i, k) + mte (qv (i, k), ql (i, k), qr (i, k), qi (i, k), & + qs (i, k), qg (i, k), tz (k), delp (i, k), .true.) * grav + enddo + endif + endif + + ! ----------------------------------------------------------------------- + ! conversion of temperature + ! ----------------------------------------------------------------------- + + if (do_inline_mp) then + do k = ks, ke + q_cond = qlz (k) + qrz (k) + qiz (k) + qsz (k) + qgz (k) + if (cp_heating) then + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + cp8 = con_r8 * cp_air + qvz (k) * cp_vap + q_liq (k) * c_liq + q_sol (k) * c_ice + delz (i, k) = delz (i, k) / pt (i, k) + pt (i, k) = pt (i, k) + (tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) - pt (i, k)) * c8 / cp8 + delz (i, k) = delz (i, k) * pt (i, k) + else + pt (i, k) = tz (k) * ((1. + zvir * qvz (k)) * (1. - q_cond)) + endif + enddo + else + do k = ks, ke + q_liq (k) = qlz (k) + qrz (k) + q_sol (k) = qiz (k) + qsz (k) + qgz (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qvz (k) + q_cond) + c8 = mhc (con_r8, qvz (k), q_liq (k), q_sol (k)) * c_air + pt (i, k) = pt (i, k) + (tz (k) - pt (i, k)) * c8 / cp_air + enddo + endif + + ! ----------------------------------------------------------------------- + ! total energy checker + ! ----------------------------------------------------------------------- + + if (consv_checker) then + if (abs (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & + (sum (te_beg_d (i, :)) + te_b_beg_d (i)) .gt. te_err) then + print*, "GFDL-MP-DRY TE: ", & + !(sum (te_beg_d (i, :)) + te_b_beg_d (i)), & + !(sum (te_end_d (i, :)) + te_b_end_d (i)), & + (sum (te_end_d (i, :)) + te_b_end_d (i) - sum (te_beg_d (i, :)) - te_b_beg_d (i)) / & + (sum (te_beg_d (i, :)) + te_b_beg_d (i)) + endif + if (abs (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / & + (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) .gt. tw_err) then + print*, "GFDL-MP-DRY TW: ", & + !(sum (tw_beg_d (i, :)) + tw_b_beg_d (i)), & + !(sum (tw_end_d (i, :)) + tw_b_end_d (i)), & + (sum (tw_end_d (i, :)) + tw_b_end_d (i) - sum (tw_beg_d (i, :)) - tw_b_beg_d (i)) / & + (sum (tw_beg_d (i, :)) + tw_b_beg_d (i)) + endif + !print*, "GFDL MP TE DRY LOSS (%) : ", te_loss (i) / (sum (te_beg_d (i, :)) + te_b_beg_d (i)) * 100.0 + if (abs (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / & + (sum (te_beg_m (i, :)) + te_b_beg_m (i)) .gt. te_err) then + print*, "GFDL-MP-WET TE: ", & + !(sum (te_beg_m (i, :)) + te_b_beg_m (i)), & + !(sum (te_end_m (i, :)) + te_b_end_m (i)), & + (sum (te_end_m (i, :)) + te_b_end_m (i) - sum (te_beg_m (i, :)) - te_b_beg_m (i)) / & + (sum (te_beg_m (i, :)) + te_b_beg_m (i)) + endif + if (abs (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / & + (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) .gt. tw_err) then + print*, "GFDL-MP-WET TW: ", & + !(sum (tw_beg_m (i, :)) + tw_b_beg_m (i)), & + !(sum (tw_end_m (i, :)) + tw_b_end_m (i)), & + (sum (tw_end_m (i, :)) + tw_b_end_m (i) - sum (tw_beg_m (i, :)) - tw_b_beg_m (i)) / & + (sum (tw_beg_m (i, :)) + tw_b_beg_m (i)) + endif + !print*, "GFDL MP TE WET LOSS (%) : ", te_loss_0 (i) / (sum (te_beg_m (i, :)) + te_b_beg_m (i)) * 100.0 + endif + + enddo ! i loop + +end subroutine mpdrv + +! ======================================================================= +! fix negative water species +! ======================================================================= + +subroutine neg_adj (ks, ke, tz, dp, qv, ql, qr, qi, qs, qg, cond) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in), dimension (ks:ke) :: dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real(kind_phys), intent (out) :: cond + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: dq, sink + + real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + cond = 0 + + ! ----------------------------------------------------------------------- + ! calculate moist heat capacity and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! fix negative solid-phase hydrometeors + ! ----------------------------------------------------------------------- + + ! if cloud ice < 0, borrow from snow + if (qi (k) .lt. 0.) then + sink = min (- qi (k), max (0., qs (k))) + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., sink, - sink, 0.) + endif + + ! if snow < 0, borrow from graupel + if (qs (k) .lt. 0.) then + sink = min (- qs (k), max (0., qg (k))) + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., sink, - sink) + endif + + ! if graupel < 0, borrow from rain + if (qg (k) .lt. 0.) then + sink = min (- qg (k), max (0., qr (k))) + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + endif + + ! ----------------------------------------------------------------------- + ! fix negative liquid-phase hydrometeors + ! ----------------------------------------------------------------------- + + ! if rain < 0, borrow from cloud water + if (qr (k) .lt. 0.) then + sink = min (- qr (k), max (0., ql (k))) + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + endif + + ! if cloud water < 0, borrow from water vapor + if (ql (k) .lt. 0.) then + sink = min (- ql (k), max (0., qv (k))) + cond = cond + sink * dp (k) + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + endif + + enddo + + ! ----------------------------------------------------------------------- + ! fix negative water vapor + ! ----------------------------------------------------------------------- + + ! if water vapor < 0, borrow water vapor from below + do k = ks, ke - 1 + if (qv (k) .lt. 0.) then + qv (k + 1) = qv (k + 1) + qv (k) * dp (k) / dp (k + 1) + qv (k) = 0. + endif + enddo + + ! if water vapor < 0, borrow water vapor from above + if (qv (ke) .lt. 0. .and. qv (ke - 1) .gt. 0.) then + dq = min (- qv (ke) * dp (ke), qv (ke - 1) * dp (ke - 1)) + qv (ke - 1) = qv (ke - 1) - dq / dp (ke - 1) + qv (ke) = qv (ke) + dq / dp (ke) + endif + +end subroutine neg_adj + +! ======================================================================= +! full microphysics loop +! ======================================================================= + +subroutine mp_full (ks, ke, ntimes, tz, qv, ql, qr, qi, qs, qg, dp, dz, u, v, w, & + den, denfac, ccn, cin, dts, rh_adj, rh_rain, h_var, dte, water, rain, ice, & + snow, graupel, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg, & + condensation, deposition, evaporation, sublimation, convt, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke, ntimes + + real(kind_phys), intent (in) :: dts, rh_adj, rh_rain, h_var, convt + + real(kind_phys), intent (in), dimension (ks:ke) :: dp, dz, den, denfac + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w, ccn, cin + real(kind_phys), intent (inout), dimension (ks:ke) :: prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real(kind_phys), intent (inout) :: water, rain, ice, snow, graupel + real(kind_phys), intent (inout) :: condensation, deposition + real(kind_phys), intent (inout) :: evaporation, sublimation + + real (kind = r8), intent (inout) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: n + + real(kind_phys) :: w1, r1, i1, s1, g1, cond, dep, reevap, sub + + real(kind_phys), dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg + + do n = 1, ntimes + + ! ----------------------------------------------------------------------- + ! sedimentation of cloud ice, snow, graupel or hail, and rain + ! ----------------------------------------------------------------------- + + call sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, & + dz, dp, vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & + u, v, w, den, denfac, dte) + + water = water + w1 * convt + rain = rain + r1 * convt + ice = ice + i1 * convt + snow = snow + s1 * convt + graupel = graupel + g1 * convt + + prefluxw = prefluxw + pfw * convt + prefluxr = prefluxr + pfr * convt + prefluxi = prefluxi + pfi * convt + prefluxs = prefluxs + pfs * convt + prefluxg = prefluxg + pfg * convt + + ! ----------------------------------------------------------------------- + ! warm rain cloud microphysics + ! ----------------------------------------------------------------------- + + call warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & + den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap) + + evaporation = evaporation + reevap * convt + + ! ----------------------------------------------------------------------- + ! ice cloud microphysics + ! ----------------------------------------------------------------------- + + call ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & + denfac, vtw, vtr, vti, vts, vtg, dts, h_var) + + if (do_subgrid_proc) then + + ! ----------------------------------------------------------------------- + ! temperature sentive high vertical resolution processes + ! ----------------------------------------------------------------------- + + call subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, & + qr, qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) + + condensation = condensation + cond * convt + deposition = deposition + dep * convt + evaporation = evaporation + reevap * convt + sublimation = sublimation + sub * convt + + endif + + enddo + +end subroutine mp_full + +! ======================================================================= +! fast microphysics loop +! ======================================================================= + +subroutine mp_fast (ks, ke, tz, qv, ql, qr, qi, qs, qg, dtm, dp, den, & + ccn, cin, condensation, deposition, evaporation, sublimation, & + denfac, convt, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dtm, convt + + real(kind_phys), intent (in), dimension (ks:ke) :: dp, den, denfac + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real(kind_phys), intent (inout) :: condensation, deposition + real(kind_phys), intent (inout) :: evaporation, sublimation + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: cond_evap + + integer :: n + + real(kind_phys) :: cond, dep, reevap, sub + + real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + cond = 0 + dep = 0 + reevap = 0 + sub = 0 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + if (.not. do_warm_rain_mp .and. fast_fr_mlt) then + + ! ----------------------------------------------------------------------- + ! cloud ice melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call pimlt (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! enforce complete freezing below t_wfr + ! ----------------------------------------------------------------------- + + call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water condensation and evaporation + ! ----------------------------------------------------------------------- + + if (delay_cond_evap) then + cond_evap = last_step + else + cond_evap = .true. + endif + + if (cond_evap) then + do n = 1, nconds + call pcond_pevap (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cond, reevap) + enddo + endif + + condensation = condensation + cond * convt + evaporation = evaporation + reevap * convt + + if (.not. do_warm_rain_mp .and. fast_fr_mlt) then + + ! ----------------------------------------------------------------------- + ! cloud water freezing to form cloud ice and snow + ! ----------------------------------------------------------------------- + + call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! Wegener Bergeron Findeisen process + ! ----------------------------------------------------------------------- + + call pwbf (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! Bigg freezing mechanism + ! ----------------------------------------------------------------------- + + call pbigg (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! rain freezing to form graupel + ! ----------------------------------------------------------------------- + + call pgfr_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! snow melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call psmlt_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water to rain autoconversion + ! ----------------------------------------------------------------------- + + call praut_simp (ks, ke, dtm, tz, qv, ql, qr, qi, qs, qg) + + if (.not. do_warm_rain_mp .and. fast_dep_sub) then + + ! ----------------------------------------------------------------------- + ! cloud ice deposition and sublimation + ! ----------------------------------------------------------------------- + + call pidep_pisub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, dep, sub) + + deposition = deposition + dep * convt + sublimation = sublimation + sub * convt + + ! ----------------------------------------------------------------------- + ! cloud ice to snow autoconversion + ! ----------------------------------------------------------------------- + + call psaut_simp (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, den) + + ! ----------------------------------------------------------------------- + ! snow deposition and sublimation + ! ----------------------------------------------------------------------- + + call psdep_pssub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + ! ----------------------------------------------------------------------- + ! graupel deposition and sublimation + ! ----------------------------------------------------------------------- + + call pgdep_pgsub (ks, ke, dtm, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + endif + +end subroutine mp_fast + +! ======================================================================= +! sedimentation of cloud ice, snow, graupel or hail, and rain +! ======================================================================= + +subroutine sedimentation (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtw, vtr, vti, vts, vtg, w1, r1, i1, s1, g1, pfw, pfr, pfi, pfs, pfg, & + u, v, w, den, denfac, dte) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: dp, dz, den, denfac + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w + + real(kind_phys), intent (out) :: w1, r1, i1, s1, g1 + + real(kind_phys), intent (out), dimension (ks:ke) :: vtw, vtr, vti, vts, vtg, pfw, pfr, pfi, pfs, pfg + + real (kind = r8), intent (inout) :: dte + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: te8, cvm + + w1 = 0. + r1 = 0. + i1 = 0. + s1 = 0. + g1 = 0. + + vtw = 0. + vtr = 0. + vti = 0. + vts = 0. + vtg = 0. + + pfw = 0. + pfr = 0. + pfi = 0. + pfs = 0. + pfg = 0. + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling cloud ice into rain + ! ----------------------------------------------------------------------- + + if (do_psd_ice_fall) then + call term_rsg (ks, ke, qi, den, denfac, vi_fac, blini, mui, tvai, tvbi, vi_max, const_vi, vti) + else + call term_ice (ks, ke, tz, qi, den, vi_fac, vi_max, const_vi, vti) + endif + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vti, r1, tau_imlt, icpk, "qi") + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vti, i1, pfi, u, v, w, dte, "qi") + + pfi (ks) = max (0.0, pfi (ks)) + do k = ke, ks + 1, -1 + pfi (k) = max (0.0, pfi (k) - pfi (k - 1)) + enddo + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling snow into rain + ! ----------------------------------------------------------------------- + + call term_rsg (ks, ke, qs, den, denfac, vs_fac, blins, mus, tvas, tvbs, vs_max, const_vs, vts) + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vts, r1, tau_smlt, icpk, "qs") + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vts, s1, pfs, u, v, w, dte, "qs") + + pfs (ks) = max (0.0, pfs (ks)) + do k = ke, ks + 1, -1 + pfs (k) = max (0.0, pfs (k) - pfs (k - 1)) + enddo + + ! ----------------------------------------------------------------------- + ! terminal fall and melting of falling graupel into rain + ! ----------------------------------------------------------------------- + + if (do_hail) then + call term_rsg (ks, ke, qg, den, denfac, vg_fac, blinh, muh, tvah, tvbh, vg_max, const_vg, vtg) + else + call term_rsg (ks, ke, qg, den, denfac, vg_fac, bling, mug, tvag, tvbg, vg_max, const_vg, vtg) + endif + + if (do_sedi_melt) then + call sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtg, r1, tau_gmlt, icpk, "qg") + endif + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtg, g1, pfg, u, v, w, dte, "qg") + + pfg (ks) = max (0.0, pfg (ks)) + do k = ke, ks + 1, -1 + pfg (k) = max (0.0, pfg (k) - pfg (k - 1)) + enddo + + ! ----------------------------------------------------------------------- + ! terminal fall of cloud water + ! ----------------------------------------------------------------------- + + if (do_psd_water_fall) then + + call term_rsg (ks, ke, ql, den, denfac, vw_fac, blinw, muw, tvaw, tvbw, vw_max, const_vw, vtw) + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtw, w1, pfw, u, v, w, dte, "ql") + + pfw (ks) = max (0.0, pfw (ks)) + do k = ke, ks + 1, -1 + pfw (k) = max (0.0, pfw (k) - pfw (k - 1)) + enddo + + endif + + ! ----------------------------------------------------------------------- + ! terminal fall of rain + ! ----------------------------------------------------------------------- + + call term_rsg (ks, ke, qr, den, denfac, vr_fac, blinr, mur, tvar, tvbr, vr_max, const_vr, vtr) + + call terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vtr, r1, pfr, u, v, w, dte, "qr") + + pfr (ks) = max (0.0, pfr (ks)) + do k = ke, ks + 1, -1 + pfr (k) = max (0.0, pfr (k) - pfr (k - 1)) + enddo + +end subroutine sedimentation + +! ======================================================================= +! terminal velocity for cloud ice +! ======================================================================= + +subroutine term_ice (ks, ke, tz, q, den, v_fac, v_max, const_v, vt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: const_v + + real(kind_phys), intent (in) :: v_fac, v_max + + real(kind_phys), intent (in), dimension (ks:ke) :: q, den + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real(kind_phys), intent (out), dimension (ks:ke) :: vt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: qden + + real(kind_phys), parameter :: aa = - 4.14122e-5 + real(kind_phys), parameter :: bb = - 0.00538922 + real(kind_phys), parameter :: cc = - 0.0516344 + real(kind_phys), parameter :: dd = 0.00216078 + real(kind_phys), parameter :: ee = 1.9714 + + real(kind_phys), dimension (ks:ke) :: tc + + if (const_v) then + vt (:) = v_fac + else + do k = ks, ke + qden = q (k) * den (k) + if (q (k) .lt. qfmin) then + vt (k) = 0.0 + else + tc (k) = tz (k) - tice + if (ifflag .eq. 1) then + vt (k) = (3. + log10 (qden)) * (tc (k) * (aa * tc (k) + bb) + cc) + & + dd * tc (k) + ee + vt (k) = 0.01 * v_fac * exp (vt (k) * log (10.)) + endif + if (ifflag .eq. 2) & + vt (k) = v_fac * 3.29 * exp (0.16 * log (qden)) + vt (k) = min (v_max, max (0.0, vt (k))) + endif + enddo + endif + +end subroutine term_ice + +! ======================================================================= +! terminal velocity for rain, snow, and graupel, Lin et al. (1983) +! ======================================================================= + +subroutine term_rsg (ks, ke, q, den, denfac, v_fac, blin, mu, tva, tvb, v_max, const_v, vt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: const_v + + real(kind_phys), intent (in) :: v_fac, blin, v_max, mu + + real (kind = r8), intent (in) :: tva, tvb + + real(kind_phys), intent (in), dimension (ks:ke) :: q, den, denfac + + real(kind_phys), intent (out), dimension (ks:ke) :: vt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + if (const_v) then + vt (:) = v_fac + else + do k = ks, ke + if (q (k) .lt. qfmin) then + vt (k) = 0.0 + else + call cal_pc_ed_oe_rr_tv (q (k), den (k), blin, mu, & + tva = tva, tvb = tvb, tv = vt (k)) + vt (k) = v_fac * vt (k) * denfac (k) + vt (k) = min (v_max, max (0.0, vt (k))) + endif + enddo + endif + +end subroutine term_rsg + +! ======================================================================= +! melting during sedimentation +! ======================================================================= + +subroutine sedi_melt (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vt, r1, tau_mlt, icpk, qflag) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts, tau_mlt + + real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp, dz, icpk + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real(kind_phys), intent (inout) :: r1 + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + character (len = 2), intent (in) :: qflag + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k, m + + real(kind_phys) :: dtime, sink, zs + + real(kind_phys), dimension (ks:ke) :: q + + real(kind_phys), dimension (ks:ke + 1) :: ze, zt + + real (kind = r8), dimension (ks:ke) :: cvm + + call zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + select case (qflag) + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + ! ----------------------------------------------------------------------- + ! melting to rain + ! ----------------------------------------------------------------------- + + do k = ke - 1, ks, - 1 + if (vt (k) .lt. 1.e-10) cycle + if (q (k) .gt. qcmin) then + do m = k + 1, ke + if (zt (k + 1) .ge. ze (m)) exit + if (zt (k) .lt. ze (m + 1) .and. tz (m) .gt. tice) then + cvm (k) = mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k)) + cvm (m) = mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m)) + dtime = min (dts, (ze (m) - ze (m + 1)) / vt (k)) + dtime = min (1.0, dtime / tau_mlt) + sink = min (q (k) * dp (k) / dp (m), dtime * (tz (m) - tice) / icpk (m)) + q (k) = q (k) - sink * dp (m) / dp (k) + if (zt (k) .lt. zs) then + r1 = r1 + sink * dp (m) + else + qr (m) = qr (m) + sink + endif + select case (qflag) + case ("qi") + qi (k) = q (k) + case ("qs") + qs (k) = q (k) + case ("qg") + qg (k) = q (k) + case default + print *, "gfdl_mp: qflag error!" + end select + tz (k) = (tz (k) * cvm (k) - li00 * sink * dp (m) / dp (k)) / & + mhc (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k)) + tz (m) = (tz (m) * cvm (m)) / & + mhc (qv (m), ql (m), qr (m), qi (m), qs (m), qg (m)) + endif + if (q (k) .lt. qcmin) exit + enddo + endif + enddo + +end subroutine sedi_melt + +! ======================================================================= +! melting during sedimentation +! ======================================================================= + +subroutine terminal_fall (dts, ks, ke, tz, qv, ql, qr, qi, qs, qg, dz, dp, & + vt, x1, m1, u, v, w, dte, qflag) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp, dz + + character (len = 2), intent (in) :: qflag + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, u, v, w + + real(kind_phys), intent (inout) :: x1 + + real (kind = r8), intent (inout) :: dte + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real(kind_phys), intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + logical :: no_fall + + real(kind_phys) :: zs + + real(kind_phys), dimension (ks:ke) :: dm, q + + real(kind_phys), dimension (ks:ke + 1) :: ze, zt + + real (kind = r8), dimension (ks:ke) :: te1, te2 + + m1 = 0.0 + + call zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + select case (qflag) + case ("ql") + q = ql + case ("qr") + q = qr + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + call check_column (ks, ke, q, no_fall) + + if (no_fall) return + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_w) then + do k = ks, ke + dm (k) = dp (k) * (1. + qv (k) + ql (k) + qr (k) + qi (k) + qs (k) + qg (k)) + enddo + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation + ! ----------------------------------------------------------------------- + + do k = ks, ke + te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + + ! ----------------------------------------------------------------------- + ! sedimentation + ! ----------------------------------------------------------------------- + + select case (qflag) + case ("ql") + q = ql + case ("qr") + q = qr + case ("qi") + q = qi + case ("qs") + q = qs + case ("qg") + q = qg + case default + print *, "gfdl_mp: qflag error!" + end select + + if (sedflag .eq. 1) & + call implicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1) + if (sedflag .eq. 2) & + call explicit_fall (dts, ks, ke, ze, vt, dp, q, x1, m1) + if (sedflag .eq. 3) & + call lagrangian_fall (ks, ke, zs, ze, zt, dp, q, x1, m1) + if (sedflag .eq. 4) & + call implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & + x1, m1, sed_fac) + + select case (qflag) + case ("ql") + ql = q + case ("qr") + qr = q + case ("qi") + qi = q + case ("qs") + qs = q + case ("qg") + qg = q + case default + print *, "gfdl_mp: qflag error!" + end select + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation + ! ----------------------------------------------------------------------- + + do k = ks, ke + te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + dte = dte + sum (te1) - sum (te2) + + ! ----------------------------------------------------------------------- + ! momentum transportation during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_uv) then + call sedi_uv (ks, ke, m1, dp, u, v) + endif + + if (do_sedi_w) then + call sedi_w (ks, ke, m1, w, vt, dm) + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation heating + ! ----------------------------------------------------------------------- + + do k = ks, ke + te1 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + + ! ----------------------------------------------------------------------- + ! heat exchanges during sedimentation + ! ----------------------------------------------------------------------- + + if (do_sedi_heat) then + call sedi_heat (ks, ke, dp, m1, dz, tz, qv, ql, qr, qi, qs, qg, c_ice) + endif + + ! ----------------------------------------------------------------------- + ! energy change during sedimentation heating + ! ----------------------------------------------------------------------- + + do k = ks, ke + te2 (k) = mte (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), tz (k), dp (k), .false.) + enddo + dte = dte + sum (te1) - sum (te2) + +end subroutine terminal_fall + +! ======================================================================= +! calculate ze zt for sedimentation +! ======================================================================= + +subroutine zezt (ks, ke, dts, zs, dz, vt, ze, zt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: dz, vt + + real(kind_phys), intent (out) :: zs + + real(kind_phys), intent (out), dimension (ks:ke + 1) :: ze, zt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: dt5 + + dt5 = 0.5 * dts + zs = 0.0 + ze (ke + 1) = zs + do k = ke, ks, - 1 + ze (k) = ze (k + 1) - dz (k) + enddo + zt (ks) = ze (ks) + do k = ks + 1, ke + zt (k) = ze (k) - dt5 * (vt (k - 1) + vt (k)) + enddo + zt (ke + 1) = zs - dts * vt (ke) + do k = ks, ke + if (zt (k + 1) .ge. zt (k)) zt (k + 1) = zt (k) - dz_min + enddo + +end subroutine zezt + +! ======================================================================= +! check if water species is large enough to fall +! ======================================================================= + +subroutine check_column (ks, ke, q, no_fall) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: q (ks:ke) + + logical, intent (out) :: no_fall + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + no_fall = .true. + + do k = ks, ke + if (q (k) .gt. qfmin) then + no_fall = .false. + exit + endif + enddo + +end subroutine check_column + +! ======================================================================= +! warm rain cloud microphysics +! ======================================================================= + +subroutine warm_rain (dts, ks, ke, dp, dz, tz, qv, ql, qr, qi, qs, qg, & + den, denfac, vtw, vtr, ccn, rh_rain, h_var, reevap) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts, rh_rain, h_var + + real(kind_phys), intent (in), dimension (ks:ke) :: dp, dz, den, denfac, vtw, vtr + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real(kind_phys), intent (out) :: reevap + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + reevap = 0 + + ! ----------------------------------------------------------------------- + ! rain evaporation to form water vapor + ! ----------------------------------------------------------------------- + + call prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap) + + ! ----------------------------------------------------------------------- + ! rain accretion with cloud water + ! ----------------------------------------------------------------------- + + call pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr) + + ! ----------------------------------------------------------------------- + ! cloud water to rain autoconversion + ! ----------------------------------------------------------------------- + + call praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) + +end subroutine warm_rain + +! ======================================================================= +! rain evaporation to form water vapor, Lin et al. (1983) +! ======================================================================= + +subroutine prevp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, rh_rain, h_var, dp, reevap) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts, rh_rain, h_var + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, dp + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg + + real(kind_phys), intent (out) :: reevap + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: dqv, qsat, dqdt, tmp, t2, qden, q_plus, q_minus, sink + real(kind_phys) :: qpz, dq, dqh, tin, fac_revp, rh_tem + + real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + reevap = 0 + + ! ----------------------------------------------------------------------- + ! time-scale factor + ! ----------------------------------------------------------------------- + + fac_revp = 1. + if (tau_revp .gt. 1.e-6) then + fac_revp = 1. - exp (- dts / tau_revp) + endif + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + tin = (tz (k) * cvm (k) - lv00 * ql (k)) / mhc (qv (k) + ql (k), qr (k), q_sol (k)) + + ! ----------------------------------------------------------------------- + ! calculate supersaturation and subgrid variability of water + ! ----------------------------------------------------------------------- + + qpz = qv (k) + ql (k) + qsat = wqs (tin, den (k), dqdt) + dqv = qsat - qv (k) + + dqh = max (ql (k), h_var * max (qpz, qcmin)) + dqh = min (dqh, 0.2 * qpz) + q_minus = qpz - dqh + q_plus = qpz + dqh + + ! ----------------------------------------------------------------------- + ! rain evaporation + ! ----------------------------------------------------------------------- + + rh_tem = qpz / qsat + + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qcmin .and. dqv .gt. 0.0 .and. qsat .gt. q_minus) then + + if (qsat .gt. q_plus) then + dq = qsat - qpz + else + dq = 0.25 * (qsat - q_minus) ** 2 / dqh + endif + qden = qr (k) * den (k) + t2 = tin * tin + sink = psub (t2, dq, qden, qsat, crevp, den (k), denfac (k), blinr, mur, lcpk (k), cvm (k)) + sink = min (qr (k), dts * fac_revp * sink, dqv / (1. + lcpk (k) * dqdt)) + if (use_rhc_revap .and. rh_tem .ge. rhc_revap) then + sink = 0.0 + endif + + ! ----------------------------------------------------------------------- + ! alternative minimum evaporation in dry environmental air + ! ----------------------------------------------------------------------- + ! tmp = min (qr (k), dim (rh_rain * qsat, qv (k)) / (1. + lcpk (k) * dqdt)) + ! sink = max (sink, tmp) + + reevap = reevap + sink * dp (k) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., - sink, 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo ! k loop + +end subroutine prevp + +! ======================================================================= +! rain accretion with cloud water, Lin et al. (1983) +! ======================================================================= + +subroutine pracw (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, denfac, vtw, vtr) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, qr, ql, qi, qs, qg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: qden, sink + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. qr (k) .gt. qcmin .and. ql (k) .gt. qcmin) then + + qden = qr (k) * den (k) + if (do_new_acc_water) then + sink = dts * acr3d (vtr (k), vtw (k), ql (k), qr (k), cracw, acco (:, 5), & + acc (9), acc (10), den (k)) + else + sink = dts * acr2d (qden, cracw, denfac (k), blinr, mur) + sink = sink / (1. + sink) * ql (k) + endif + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + enddo + +end subroutine pracw + +! ======================================================================= +! cloud water to rain autoconversion, Hong et al. (2004) +! ======================================================================= + +subroutine praut (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg, den, ccn, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts, h_var + + real(kind_phys), intent (in), dimension (ks:ke) :: den + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys), parameter :: so3 = 7.0 / 3.0 + real(kind_phys), parameter :: so1 = - 1.0 / 3.0 + + integer :: k + + real(kind_phys) :: sink, dq, qc + + real(kind_phys), dimension (ks:ke) :: dl, c_praut + + if (irain_f .eq. 0) then + + call linear_prof (ke - ks + 1, ql (ks), dl (ks), z_slope_liq, h_var) + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + qc = fac_rc * ccn (k) + dl (k) = min (max (qcmin, dl (k)), 0.5 * ql (k)) + dq = 0.5 * (ql (k) + dl (k) - qc) + + if (dq .gt. 0.) then + + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) + sink = min (1., dq / dl (k)) * dts * c_praut (k) * den (k) * & + exp (so3 * log (ql (k))) + sink = min (ql (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + endif + + enddo + + endif + + if (irain_f .eq. 1) then + + do k = ks, ke + + if (tz (k) .gt. t_wfr .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + qc = fac_rc * ccn (k) + dq = ql (k) - qc + + if (dq .gt. 0.) then + + c_praut (k) = cpaut * exp (so1 * log (ccn (k) * rhow)) + sink = min (dq, dts * c_praut (k) * den (k) * exp (so3 * log (ql (k)))) + sink = min (ql (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + endif + + enddo + + endif + +end subroutine praut + +! ======================================================================= +! ice cloud microphysics +! ======================================================================= + +subroutine ice_cloud (ks, ke, tz, qv, ql, qr, qi, qs, qg, den, & + denfac, vtw, vtr, vti, vts, vtg, dts, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts, h_var + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vti, vts, vtg + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys), dimension (ks:ke) :: di, q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! cloud ice melting to form cloud water and rain + ! ----------------------------------------------------------------------- + + call pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! cloud water freezing to form cloud ice and snow + ! ----------------------------------------------------------------------- + + call pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! vertical subgrid variability + ! ----------------------------------------------------------------------- + + call linear_prof (ke - ks + 1, qi, di, z_slope_ice, h_var) + + ! ----------------------------------------------------------------------- + ! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain + ! ----------------------------------------------------------------------- + + call psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! graupel melting (includes graupel accretion with cloud water and rain) to form rain + ! ----------------------------------------------------------------------- + + call pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! snow accretion with cloud ice + ! ----------------------------------------------------------------------- + + call psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts) + + ! ----------------------------------------------------------------------- + ! cloud ice to snow autoconversion + ! ----------------------------------------------------------------------- + + call psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) + + ! ----------------------------------------------------------------------- + ! graupel accretion with cloud ice + ! ----------------------------------------------------------------------- + + call pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg) + + ! ----------------------------------------------------------------------- + ! snow accretion with rain and rain freezing to form graupel + ! ----------------------------------------------------------------------- + + call psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtr, vts, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! graupel accretion with snow + ! ----------------------------------------------------------------------- + + call pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) + + ! ----------------------------------------------------------------------- + ! snow to graupel autoconversion + ! ----------------------------------------------------------------------- + + call pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) + + ! ----------------------------------------------------------------------- + ! graupel accretion with cloud water and rain + ! ----------------------------------------------------------------------- + + call pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtr, vtg, lcpk, icpk, tcpk, tcp3) + + endif ! do_warm_rain_mp + +end subroutine ice_cloud + +! ======================================================================= +! cloud ice melting to form cloud water and rain, Lin et al. (1983) +! ======================================================================= + +subroutine pimlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, tmp, sink, fac_imlt + + fac_imlt = 1. - exp (- dts / tau_imlt) + + do k = ks, ke + + tc = tz (k) - tice_mlt + + if (tc .gt. 0 .and. qi (k) .gt. qcmin) then + + sink = fac_imlt * tc / icpk (k) + sink = min (qi (k), sink) + tmp = min (sink, dim (ql_mlt, ql (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., tmp, sink - tmp, - sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pimlt + +! ======================================================================= +! cloud water freezing to form cloud ice and snow, Lin et al. (1983) +! ======================================================================= + +subroutine pifr (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in), dimension (ks:ke) :: den + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, tmp, sink, qim + + do k = ks, ke + + tc = t_wfr - tz (k) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin) then + + sink = ql (k) * tc / dt_fr + sink = min (ql (k), sink, tc / icpk (k)) + qim = qi0_crt / den (k) + tmp = min (sink, dim (qim, qi (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pifr + +! ======================================================================= +! snow melting (includes snow accretion with cloud water and rain) to form cloud water and rain +! Lin et al. (1983) +! ======================================================================= + +subroutine psmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtw, vtr, vts, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, factor, tmp, sink, qden, dqdt, tin, dq, qsi + real(kind_phys) :: psacw, psacr, pracs + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qs (k) .gt. qcmin) then + + psacw = 0. + qden = qs (k) * den (k) + if (ql (k) .gt. qcmin) then + if (do_new_acc_water) then + psacw = acr3d (vts (k), vtw (k), ql (k), qs (k), csacw, acco (:, 7), & + acc (13), acc (14), den (k)) + else + factor = acr2d (qden, csacw, denfac (k), blins, mus) + psacw = factor / (1. + dts * factor) * ql (k) + endif + endif + + psacr = 0. + pracs = 0. + if (qr (k) .gt. qcmin) then + psacr = min (acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), & + acc (3), acc (4), den (k)), qr (k) / dts) + pracs = acr3d (vtr (k), vts (k), qs (k), qr (k), cracs, acco (:, 1), & + acc (1), acc (2), den (k)) + endif + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qsi - qv (k) + sink = max (0., pmlt (tc, dq, qden, psacw, psacr, csmlt, den (k), denfac (k), blins, mus, & + lcpk (k), icpk (k), cvm (k))) + + sink = min (qs (k), (sink + pracs) * dts, tc / icpk (k)) + tmp = min (sink, dim (qs_mlt, ql (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psmlt + +! ======================================================================= +! graupel melting (includes graupel accretion with cloud water and rain) to form rain +! Lin et al. (1983) +! ======================================================================= + +subroutine pgmlt (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtw, vtr, vtg, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtw, vtr, vtg + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, factor, sink, qden, dqdt, tin, dq, qsi + real(kind_phys) :: pgacw, pgacr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qg (k) .gt. qcmin) then + + pgacw = 0. + qden = qg (k) * den (k) + if (ql (k) .gt. qcmin) then + if (do_new_acc_water) then + pgacw = acr3d (vtg (k), vtw (k), ql (k), qg (k), cgacw, acco (:, 9), & + acc (17), acc (18), den (k)) + else + if (do_hail) then + factor = acr2d (qden, cgacw, denfac (k), blinh, muh) + else + factor = acr2d (qden, cgacw, denfac (k), bling, mug) + endif + pgacw = factor / (1. + dts * factor) * ql (k) + endif + endif + + pgacr = 0. + if (qr (k) .gt. qcmin) then + pgacr = min (acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), & + acc (5), acc (6), den (k)), qr (k) / dts) + endif + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qsi - qv (k) + if (do_hail) then + sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), & + blinh, muh, lcpk (k), icpk (k), cvm (k))) + else + sink = max (0., pmlt (tc, dq, qden, pgacw, pgacr, cgmlt, den (k), denfac (k), & + bling, mug, lcpk (k), icpk (k), cvm (k))) + endif + + sink = min (qg (k), sink * dts, tc / icpk (k)) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., sink, 0., 0., - sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgmlt + +! ======================================================================= +! snow accretion with cloud ice, Lin et al. (1983) +! ======================================================================= + +subroutine psaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vts) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vti, vts + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, factor, sink, qden + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then + + sink = 0. + qden = qs (k) * den (k) + if (qs (k) .gt. qcmin) then + if (do_new_acc_ice) then + sink = dts * acr3d (vts (k), vti (k), qi (k), qs (k), csaci, acco (:, 8), & + acc (15), acc (16), den (k)) + else + factor = dts * acr2d (qden, csaci, denfac (k), blins, mus) + sink = factor / (1. + factor) * qi (k) + endif + endif + + sink = min (fi2s_fac * qi (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaci + +! ======================================================================= +! cloud ice to snow autoconversion, Lin et al. (1983) +! ======================================================================= + +subroutine psaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, di) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, di + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, sink, fac_i2s, q_plus, qim, dq, tmp + + fac_i2s = 1. - exp (- dts / tau_i2s) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then + + sink = 0. + tmp = fac_i2s * exp (0.025 * tc) + di (k) = max (di (k), qcmin) + q_plus = qi (k) + di (k) + qim = qi0_crt / den (k) + if (q_plus .gt. (qim + qcmin)) then + if (qim .gt. (qi (k) - di (k))) then + dq = (0.25 * (q_plus - qim) ** 2) / di (k) + else + dq = qi (k) - qim + endif + sink = tmp * dq + endif + + sink = min (fi2s_fac * qi (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaut + +! ======================================================================= +! graupel accretion with cloud ice, Lin et al. (1983) +! ======================================================================= + +subroutine pgaci (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, denfac, vti, vtg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vti, vtg + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, factor, sink, qden + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qi (k) .gt. qcmin) then + + sink = 0. + qden = qg (k) * den (k) + if (qg (k) .gt. qcmin) then + if (do_new_acc_ice) then + sink = dts * acr3d (vtg (k), vti (k), qi (k), qg (k), cgaci, acco (:, 10), & + acc (19), acc (20), den (k)) + else + if (do_hail) then + factor = dts * acr2d (qden, cgaci, denfac (k), blinh, muh) + else + factor = dts * acr2d (qden, cgaci, denfac (k), bling, mug) + endif + sink = factor / (1. + factor) * qi (k) + endif + endif + + sink = min (fi2g_fac * qi (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, 0., sink) + + endif + + enddo + +end subroutine pgaci + +! ======================================================================= +! snow accretion with rain and rain freezing to form graupel, Lin et al. (1983) +! ======================================================================= + +subroutine psacr_pgfr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtr, vts, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtr, vts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, factor, sink + real(kind_phys) :: psacr, pgfr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qr (k) .gt. qcmin) then + + psacr = 0. + if (qs (k) .gt. qcmin) then + psacr = dts * acr3d (vts (k), vtr (k), qr (k), qs (k), csacr, acco (:, 2), & + acc (3), acc (4), den (k)) + endif + + pgfr = dts * cgfr (1) / den (k) * (exp (- cgfr (2) * tc) - 1.) * & + exp ((6 + mur) / (mur + 3) * log (6 * qr (k) * den (k))) + + sink = psacr + pgfr + factor = min (sink, qr (k), - tc / icpk (k)) / max (sink, qcmin) + psacr = factor * psacr + pgfr = factor * pgfr + + sink = min (qr (k), psacr + pgfr) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., psacr, pgfr, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psacr_pgfr + +! ======================================================================= +! graupel accretion with snow, Lin et al. (1983) +! ======================================================================= + +subroutine pgacs (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den, vts, vtg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, vts, vtg + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: sink + + do k = ks, ke + + if (tz (k) .lt. tice .and. qs (k) .gt. qcmin .and. qg (k) .gt. qcmin) then + + sink = dts * acr3d (vtg (k), vts (k), qs (k), qg (k), cgacs, acco (:, 4), & + acc (7), acc (8), den (k)) + sink = min (fs2g_fac * qs (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., - sink, sink) + + endif + + enddo + +end subroutine pgacs + +! ======================================================================= +! snow to graupel autoconversion, Lin et al. (1983) +! ======================================================================= + +subroutine pgaut (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, factor, sink, qsm + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qs (k) .gt. qcmin) then + + sink = 0 + qsm = qs0_crt / den (k) + if (qs (k) .gt. qsm) then + factor = dts * 1.e-3 * exp (0.09 * (tz (k) - tice)) + sink = factor / (1. + factor) * (qs (k) - qsm) + endif + + sink = min (fs2g_fac * qs (k), sink) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., 0., - sink, sink) + + endif + + enddo + +end subroutine pgaut + +! ======================================================================= +! graupel accretion with cloud water and rain, Lin et al. (1983) +! ======================================================================= + +subroutine pgacw_pgacr (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, denfac, & + vtr, vtg, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, vtr, vtg + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, factor, sink, qden + real(kind_phys) :: pgacw, pgacr + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qg (k) .gt. qcmin) then + + pgacw = 0. + if (ql (k) .gt. qcmin) then + qden = qg (k) * den (k) + if (do_hail) then + factor = dts * acr2d (qden, cgacw, denfac (k), blinh, muh) + else + factor = dts * acr2d (qden, cgacw, denfac (k), bling, mug) + endif + pgacw = factor / (1. + factor) * ql (k) + endif + + pgacr = 0. + if (qr (k) .gt. qcmin) then + pgacr = min (dts * acr3d (vtg (k), vtr (k), qr (k), qg (k), cgacr, acco (:, 3), & + acc (5), acc (6), den (k)), qr (k)) + endif + + sink = pgacr + pgacw + factor = min (sink, dim (tice, tz (k)) / icpk (k)) / max (sink, qcmin) + pgacr = factor * pgacr + pgacw = factor * pgacw + + sink = pgacr + pgacw + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - pgacw, - pgacr, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgacw_pgacr + +! ======================================================================= +! temperature sentive high vertical resolution processes +! ======================================================================= + +subroutine subgrid_z_proc (ks, ke, den, denfac, dts, rh_adj, tz, qv, ql, qr, & + qi, qs, qg, dp, ccn, cin, cond, dep, reevap, sub, last_step) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: last_step + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts, rh_adj + + real(kind_phys), intent (in), dimension (ks:ke) :: den, denfac, dp + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn, cin + + real(kind_phys), intent (out) :: cond, dep, reevap, sub + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: cond_evap + + integer :: n + + real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + cond = 0 + dep = 0 + reevap = 0 + sub = 0 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! instant processes (include deposition, evaporation, and sublimation) + ! ----------------------------------------------------------------------- + + if (.not. do_warm_rain_mp) then + + call pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap) + + endif + + ! ----------------------------------------------------------------------- + ! cloud water condensation and evaporation + ! ----------------------------------------------------------------------- + + if (delay_cond_evap) then + cond_evap = last_step + else + cond_evap = .true. + endif + + if (cond_evap) then + do n = 1, nconds + call pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cond, reevap) + enddo + endif + + if (.not. do_warm_rain_mp) then + + ! ----------------------------------------------------------------------- + ! enforce complete freezing below t_wfr + ! ----------------------------------------------------------------------- + + call pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! Wegener Bergeron Findeisen process + ! ----------------------------------------------------------------------- + + call pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! Bigg freezing mechanism + ! ----------------------------------------------------------------------- + + call pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3) + + ! ----------------------------------------------------------------------- + ! cloud ice deposition and sublimation + ! ----------------------------------------------------------------------- + + call pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, dep, sub) + + ! ----------------------------------------------------------------------- + ! snow deposition and sublimation + ! ----------------------------------------------------------------------- + + call psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + ! ----------------------------------------------------------------------- + ! graupel deposition and sublimation + ! ----------------------------------------------------------------------- + + call pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + endif + +end subroutine subgrid_z_proc + +! ======================================================================= +! instant processes (include deposition, evaporation, and sublimation) +! ======================================================================= + +subroutine pinst (ks, ke, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, rh_adj, dep, sub, reevap) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: rh_adj + + real(kind_phys), intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real(kind_phys), intent (out) :: dep, reevap, sub + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: sink, tin, qpz, rh, dqdt, tmp, qsi + + do k = ks, ke + + ! ----------------------------------------------------------------------- + ! instant deposit all water vapor to cloud ice when temperature is super low + ! ----------------------------------------------------------------------- + + if (tz (k) .lt. t_min) then + + sink = dim (qv (k), qcmin) + dep = dep + sink * dp (k) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + ! ----------------------------------------------------------------------- + ! instant evaporation / sublimation of all clouds when rh < rh_adj + ! ----------------------------------------------------------------------- + + qpz = qv (k) + ql (k) + qi (k) + tin = (te8 (k) - lv00 * qpz + li00 * (qs (k) + qg (k))) / & + mhc (qpz, qr (k), qs (k) + qg (k)) + + if (tin .gt. t_sub + 6.) then + + qsi = iqs (tin, den (k), dqdt) + rh = qpz / qsi + if (rh .lt. rh_adj) then + + sink = ql (k) + tmp = qi (k) + + reevap = reevap + sink * dp (k) + sub = sub + tmp * dp (k) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink + tmp, - sink, 0., - tmp, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + endif + + enddo + +end subroutine pinst + +! ======================================================================= +! cloud water condensation and evaporation, Hong and Lim (2006) +! ======================================================================= + +subroutine pcond_pevap (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cond, reevap) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real(kind_phys), intent (out) :: cond, reevap + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: sink, tin, qpz, dqdt, qsw, rh_tem, dq, factor, fac_l2v, fac_v2l + + fac_l2v = 1. - exp (- dts / tau_l2v) + fac_v2l = 1. - exp (- dts / tau_v2l) + + do k = ks, ke + + tin = tz (k) + qsw = wqs (tin, den (k), dqdt) + qpz = qv (k) + ql (k) + qi (k) + rh_tem = qpz / qsw + dq = qsw - qv (k) + if (dq .gt. 0.) then + if (do_evap_timescale) then + factor = min (1., fac_l2v * (rh_fac_evap * dq / qsw)) + else + factor = 1. + endif + sink = min (ql (k), factor * dq / (1. + tcp3 (k) * dqdt)) + if (use_rhc_cevap .and. rh_tem .ge. rhc_cevap) then + sink = 0. + endif + reevap = reevap + sink * dp (k) + else + if (do_cond_timescale) then + factor = min (1., fac_v2l * (rh_fac_cond * (- dq) / qsw)) + else + factor = 1. + endif + sink = - min (qv (k), factor * (- dq) / (1. + tcp3 (k) * dqdt)) + cond = cond - sink * dp (k) + endif + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, - sink, 0., 0., 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + enddo + +end subroutine pcond_pevap + +! ======================================================================= +! enforce complete freezing below t_wfr, Lin et al. (1983) +! ======================================================================= + +subroutine pcomp (ks, ke, qv, ql, qr, qi, qs, qg, tz, cvm, te8, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, sink + + do k = ks, ke + + tc = t_wfr - tz (k) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin) then + + sink = ql (k) * tc / dt_fr + sink = min (ql (k), sink, tc / icpk (k)) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pcomp + +! ======================================================================= +! Wegener Bergeron Findeisen process, Storelvmo and Tan (2015) +! ======================================================================= + +subroutine pwbf (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, tin, sink, dqdt, qsw, qsi, qim, tmp, fac_wbf + + if (.not. do_wbf) return + + fac_wbf = 1. - exp (- dts / tau_wbf) + + do k = ks, ke + + tc = tice - tz (k) + + tin = tz (k) + qsw = wqs (tin, den (k), dqdt) + qsi = iqs (tin, den (k), dqdt) + + if (tc .gt. 0. .and. ql (k) .gt. qcmin .and. qi (k) .gt. qcmin .and. & + qv (k) .gt. qsi .and. qv (k) .lt. qsw) then + + sink = min (fac_wbf * ql (k), tc / icpk (k)) + qim = qi0_crt / den (k) + tmp = min (sink, dim (qim, qi (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., tmp, sink - tmp, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pwbf + +! ======================================================================= +! Bigg freezing mechanism, Bigg (1953) +! ======================================================================= + +subroutine pbigg (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, den, ccn, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ccn + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: sink, tc + + do k = ks, ke + + tc = tice - tz (k) + + if (tc .gt. 0 .and. ql (k) .gt. qcmin) then + + if (do_psd_water_num) then + call cal_pc_ed_oe_rr_tv (ql (k), den (k), blinw, muw, & + pca = pcaw, pcb = pcbw, pc = ccn (k)) + ccn (k) = ccn (k) / den (k) + endif + + sink = 100. / (rhow * ccn (k)) * dts * (exp (0.66 * tc) - 1.) * ql (k) ** 2 + sink = min (ql (k), sink, tc / icpk (k)) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pbigg + +! ======================================================================= +! cloud ice deposition and sublimation, Hong et al. (2004) +! ======================================================================= + +subroutine pidep_pisub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + lcpk, icpk, tcpk, tcp3, cin, dep, sub) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, dp + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, cin + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real(kind_phys), intent (out) :: dep, sub + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: sink, tin, dqdt, qsi, dq, pidep, tmp, tc, qi_crt!,qi_gen + + do k = ks, ke + + if (tz (k) .lt. tice) then + + pidep = 0. + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + dq = qv (k) - qsi + tmp = dq / (1. + tcpk (k) * dqdt) + + if (qi (k) .gt. qcmin) then + if (.not. prog_ccn) then + if (inflag .eq. 1) & + cin (k) = 5.38e7 * exp (0.75 * log (qi (k) * den (k))) + if (inflag .eq. 2) & + cin (k) = exp (- 2.80 + 0.262 * (tice - tz (k))) * 1000.0 + if (inflag .eq. 3) & + cin (k) = exp (- 0.639 + 12.96 * (qv (k) / qsi - 1.0)) * 1000.0 + if (inflag .eq. 4) & + cin (k) = 5.e-3 * exp (0.304 * (tice - tz (k))) * 1000.0 + if (inflag .eq. 5) & + cin (k) = 1.e-5 * exp (0.5 * (tice - tz (k))) * 1000.0 + endif + if (do_psd_ice_num) then + call cal_pc_ed_oe_rr_tv (qi (k), den (k), blini, mui, & + pca = pcai, pcb = pcbi, pc = cin (k)) + cin (k) = cin (k) / den (k) + endif + pidep = dts * dq * 4.0 * 11.9 * exp (0.5 * log (qi (k) * den (k) * cin (k))) / & + (qsi * den (k) * (tcpk (k) * cvm (k)) ** 2 / (tcond * rvgas * tz (k) ** 2) + & + 1. / vdifu) + endif + + if (dq .gt. 0.) then + tc = tice - tz (k) + !qi_gen = 4.92e-11 * exp (1.33 * log (1.e3 * exp (0.1 * tc))) + if (igflag .eq. 1) & + qi_crt = qi_gen / den (k) + if (igflag .eq. 2) & + qi_crt = qi_gen * min (qi_lim, 0.1 * tc) / den (k) + if (igflag .eq. 3) & + qi_crt = 1.82e-6 * min (qi_lim, 0.1 * tc) / den (k) + if (igflag .eq. 4) & + qi_crt = max (qi_gen, 1.82e-6) * min (qi_lim, 0.1 * tc) / den (k) + sink = min (tmp, max (qi_crt - qi (k), pidep), tc / tcpk (k)) + dep = dep + sink * dp (k) + else + pidep = pidep * min (1., dim (tz (k), t_sub) * is_fac) + sink = max (pidep, tmp, - qi (k)) + sub = sub - sink * dp (k) + endif + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + - sink, 0., 0., sink, 0., 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pidep_pisub + +! ======================================================================= +! snow deposition and sublimation, Lin et al. (1983) +! ======================================================================= + +subroutine psdep_pssub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, dp, denfac + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real(kind_phys), intent (out) :: dep, sub + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: sink, tin, dqdt, qsi, qden, t2, dq, pssub + + do k = ks, ke + + if (qs (k) .gt. qcmin) then + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + qden = qs (k) * den (k) + t2 = tz (k) * tz (k) + dq = qsi - qv (k) + pssub = psub (t2, dq, qden, qsi, cssub, den (k), denfac (k), blins, mus, tcpk (k), cvm (k)) + pssub = dts * pssub + dq = dq / (1. + tcpk (k) * dqdt) + if (pssub .gt. 0.) then + sink = min (pssub * min (1., dim (tz (k), t_sub) * ss_fac), qs (k)) + sub = sub + sink * dp (k) + else + sink = 0. + if (tz (k) .le. tice) then + sink = max (pssub, dq, (tz (k) - tice) / tcpk (k)) + endif + dep = dep - sink * dp (k) + endif + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., 0., 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psdep_pssub + +! ======================================================================= +! graupel deposition and sublimation, Lin et al. (1983) +! ======================================================================= + +subroutine pgdep_pgsub (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, dp, cvm, te8, den, & + denfac, lcpk, icpk, tcpk, tcp3, dep, sub) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den, dp, denfac + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + real(kind_phys), intent (out) :: dep, sub + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: sink, tin, dqdt, qsi, qden, t2, dq, pgsub + + do k = ks, ke + + if (qg (k) .gt. qcmin) then + + tin = tz (k) + qsi = iqs (tin, den (k), dqdt) + qden = qg (k) * den (k) + t2 = tz (k) * tz (k) + dq = qsi - qv (k) + if (do_hail) then + pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), & + blinh, muh, tcpk (k), cvm (k)) + else + pgsub = psub (t2, dq, qden, qsi, cgsub, den (k), denfac (k), & + bling, mug, tcpk (k), cvm (k)) + endif + pgsub = dts * pgsub + dq = dq / (1. + tcpk (k) * dqdt) + if (pgsub .gt. 0.) then + sink = min (pgsub * min (1., dim (tz (k), t_sub) * gs_fac), qg (k)) + sub = sub + sink * dp (k) + else + sink = 0. + if (tz (k) .le. tice) then + sink = max (pgsub, dq, (tz (k) - tice) / tcpk (k)) + endif + dep = dep - sink * dp (k) + endif + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + sink, 0., 0., 0., 0., - sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgdep_pgsub + +! ======================================================================= +! cloud fraction diagnostic +! ======================================================================= + +subroutine cloud_fraction (ks, ke, pz, den, qv, ql, qr, qi, qs, qg, qa, tz, h_var, gsize) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: h_var, gsize + + real(kind_phys), intent (in), dimension (ks:ke) :: pz, den + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, qa + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: q_plus, q_minus + real(kind_phys) :: rh, rqi, tin, qsw, qsi, qpz, qstar, sigma, gam + real(kind_phys) :: dqdt, dq, liq, ice + real(kind_phys) :: qa10, qa100 + + real(kind_phys), dimension (ks:ke) :: q_liq, q_sol, q_cond, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! calculate heat capacities and latent heat coefficients + ! ----------------------------------------------------------------------- + + call cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, cvm, te8, tz, & + lcpk, icpk, tcpk, tcp3) + + do k = ks, ke + + ! combine water species + + ice = q_sol (k) + q_sol (k) = qi (k) + if (rad_snow) then + q_sol (k) = qi (k) + qs (k) + if (rad_graupel) then + q_sol (k) = qi (k) + qs (k) + qg (k) + endif + endif + + liq = q_liq (k) + q_liq (k) = ql (k) + if (rad_rain) then + q_liq (k) = ql (k) + qr (k) + endif + + q_cond (k) = q_liq (k) + q_sol (k) + qpz = qv (k) + q_cond (k) + + ! use the "liquid - frozen water temperature" (tin) to compute saturated specific humidity + + ice = ice - q_sol (k) + liq = liq - q_liq (k) + tin = (te8 (k) - lv00 * qpz + li00 * ice) / mhc (qpz, liq, ice) + + ! calculate saturated specific humidity + + if (tin .le. t_wfr) then + qstar = iqs (tin, den (k), dqdt) + elseif (tin .ge. tice) then + qstar = wqs (tin, den (k), dqdt) + else + qsi = iqs (tin, den (k), dqdt) + qsw = wqs (tin, den (k), dqdt) + if (q_cond (k) .gt. qcmin) then + rqi = q_sol (k) / q_cond (k) + else + rqi = (tice - tin) / (tice - t_wfr) + endif + qstar = rqi * qsi + (1. - rqi) * qsw + endif + + ! cloud schemes + + rh = qpz / qstar + + if (cfflag .eq. 1) then + if (rh .gt. rh_thres .and. qpz .gt. qcmin) then + + dq = h_var * qpz + if (do_cld_adj) then + q_plus = qpz + dq * f_dq_p * min (1.0, max (0.0, (pz (k) - 200.e2) / & + (1000.e2 - 200.e2))) + else + q_plus = qpz + dq * f_dq_p + endif + q_minus = qpz - dq * f_dq_m + + if (icloud_f .eq. 2) then + if (qstar .lt. qpz) then + qa (k) = 1. + else + qa (k) = 0. + endif + elseif (icloud_f .eq. 3) then + if (qstar .lt. qpz) then + qa (k) = 1. + else + if (qstar .lt. q_plus) then + qa (k) = (q_plus - qstar) / (dq * f_dq_p) + else + qa (k) = 0. + endif + if (q_cond (k) .gt. qcmin) then + qa (k) = max (cld_min, qa (k)) + endif + qa (k) = min (1., qa (k)) + endif + else + if (qstar .lt. q_minus) then + qa (k) = 1. + else + if (qstar .lt. q_plus) then + if (icloud_f .eq. 0) then + qa (k) = (q_plus - qstar) / (dq * f_dq_p + dq * f_dq_m) + else + qa (k) = (q_plus - qstar) / ((dq * f_dq_p + dq * f_dq_m) * & + (1. - q_cond (k))) + endif + else + qa (k) = 0. + endif + if (q_cond (k) .gt. qcmin) then + qa (k) = max (cld_min, qa (k)) + endif + qa (k) = min (1., qa (k)) + endif + endif + else + qa (k) = 0. + endif + endif + + if (cfflag .eq. 2) then + if (rh .ge. 1.0) then + qa (k) = 1.0 + elseif (rh .gt. rh_thres .and. q_cond (k) .gt. qcmin) then + qa (k) = exp (xr_a * log (rh)) * (1.0 - exp (- xr_b * max (0.0, q_cond (k)) / & + max (1.e-5, exp (xr_c * log (max (1.e-10, 1.0 - rh) * qstar))))) + qa (k) = max (0.0, min (1., qa (k))) + else + qa (k) = 0.0 + endif + endif + + if (cfflag .eq. 3) then + if (q_cond (k) .gt. qcmin) then + qa (k) = 1. / 50. * (5.77 * (100. - gsize / 1000.) * & + exp (1.07 * log (max (qcmin * 1000., q_cond (k) * 1000.))) + & + 4.82 * (gsize / 1000. - 50.) * & + exp (0.94 * log (max (qcmin * 1000., q_cond (k) * 1000.)))) + qa (k) = qa (k) * (0.92 / 0.96 * q_liq (k) / q_cond (k) + & + 1.0 / 0.96 * q_sol (k) / q_cond (k)) + qa (k) = max (0.0, min (1., qa (k))) + else + qa (k) = 0.0 + endif + endif + + if (cfflag .eq. 4) then + sigma = 0.28 + exp (0.49 * log (max (qcmin * 1000., q_cond (k) * 1000.))) + gam = max (0.0, q_cond (k) * 1000.) / sigma + if (gam .lt. 0.18) then + qa10 = 0. + elseif (gam .gt. 2.0) then + qa10 = 1.0 + else + qa10 = - 0.1754 + 0.9811 * gam - 0.2223 * gam ** 2 + 0.0104 * gam ** 3 + qa10 = max (0.0, min (1., qa10)) + endif + if (gam .lt. 0.12) then + qa100 = 0. + elseif (gam .gt. 1.85) then + qa100 = 1.0 + else + qa100 = - 0.0913 + 0.7213 * gam + 0.1060 * gam ** 2 - 0.0946 * gam ** 3 + qa100 = max (0.0, min (1., qa100)) + endif + qa (k) = qa10 + (log10 (gsize / 1000.) - 1) * (qa100 - qa10) + qa (k) = max (0.0, min (1., qa (k))) + endif + + enddo + +end subroutine cloud_fraction + +! ======================================================================= +! piecewise parabolic lagrangian scheme +! this subroutine is the same as map1_q2 in fv_mapz_mod. +! ======================================================================= + +subroutine lagrangian_fall (ks, ke, zs, ze, zt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: zs + + real(kind_phys), intent (in), dimension (ks:ke + 1) :: ze, zt + + real(kind_phys), intent (in), dimension (ks:ke) :: dp + + real(kind_phys), intent (inout), dimension (ks:ke) :: q + + real(kind_phys), intent (inout) :: precip + + real(kind_phys), intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k, k0, n, m + + real(kind_phys) :: a4 (4, ks:ke), pl, pr, delz, esl + + real(kind_phys), parameter :: r3 = 1. / 3., r23 = 2. / 3. + + real(kind_phys), dimension (ks:ke) :: qm, dz + + ! ----------------------------------------------------------------------- + ! density: + ! ----------------------------------------------------------------------- + + do k = ks, ke + dz (k) = zt (k) - zt (k + 1) + q (k) = q (k) * dp (k) + a4 (1, k) = q (k) / dz (k) + qm (k) = 0. + enddo + + ! ----------------------------------------------------------------------- + ! construct vertical profile with zt as coordinate + ! ----------------------------------------------------------------------- + + call cs_profile (a4 (1, ks), dz (ks), ke - ks + 1) + + k0 = ks + do k = ks, ke + do n = k0, ke + if (ze (k) .le. zt (n) .and. ze (k) .ge. zt (n + 1)) then + pl = (zt (n) - ze (k)) / dz (n) + if (zt (n + 1) .le. ze (k + 1)) then + ! entire new grid is within the original grid + pr = (zt (n) - ze (k + 1)) / dz (n) + qm (k) = a4 (2, n) + 0.5 * (a4 (4, n) + a4 (3, n) - a4 (2, n)) * (pr + pl) - & + a4 (4, n) * r3 * (pr * (pr + pl) + pl ** 2) + qm (k) = qm (k) * (ze (k) - ze (k + 1)) + k0 = n + goto 555 + else + qm (k) = (ze (k) - zt (n + 1)) * (a4 (2, n) + 0.5 * (a4 (4, n) + & + a4 (3, n) - a4 (2, n)) * (1. + pl) - a4 (4, n) * (r3 * (1. + pl * (1. + pl)))) + if (n .lt. ke) then + do m = n + 1, ke + ! locate the bottom edge: ze (k + 1) + if (ze (k + 1) .lt. zt (m + 1)) then + qm (k) = qm (k) + q (m) + else + delz = zt (m) - ze (k + 1) + esl = delz / dz (m) + qm (k) = qm (k) + delz * (a4 (2, m) + 0.5 * esl * & + (a4 (3, m) - a4 (2, m) + a4 (4, m) * (1. - r23 * esl))) + k0 = m + goto 555 + endif + enddo + endif + goto 555 + endif + endif + enddo + 555 continue + enddo + + m1 (ks) = q (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = precip + m1 (ke) + + ! ----------------------------------------------------------------------- + ! convert back to * dry * mixing ratio: + ! dp must be dry air_mass (because moist air mass will be changed due to terminal fall) . + ! ----------------------------------------------------------------------- + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine lagrangian_fall + +! ======================================================================= +! vertical profile reconstruction +! this subroutine is the same as cs_profile in fv_mapz_mod where iv = 0 and kord = 9 +! ======================================================================= + +subroutine cs_profile (a4, del, km) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + real(kind_phys), intent (in) :: del (km) + + real(kind_phys), intent (inout) :: a4 (4, km) + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + logical :: extm (km) + + real(kind_phys) :: gam (km), q (km + 1), d4, bet, a_bot, grat, pmp, lac + real(kind_phys) :: pmp_1, lac_1, pmp_2, lac_2, da1, da2, a6da + + grat = del (2) / del (1) ! grid ratio + bet = grat * (grat + 0.5) + q (1) = (2. * grat * (grat + 1.) * a4 (1, 1) + a4 (1, 2)) / bet + gam (1) = (1. + grat * (grat + 1.5)) / bet + + do k = 2, km + d4 = del (k - 1) / del (k) + bet = 2. + 2. * d4 - gam (k - 1) + q (k) = (3. * (a4 (1, k - 1) + d4 * a4 (1, k)) - q (k - 1)) / bet + gam (k) = d4 / bet + enddo + + a_bot = 1. + d4 * (d4 + 1.5) + q (km + 1) = (2. * d4 * (d4 + 1.) * a4 (1, km) + a4 (1, km - 1) - a_bot * q (km)) & + / (d4 * (d4 + 0.5) - a_bot * gam (km)) + + do k = km, 1, - 1 + q (k) = q (k) - gam (k) * q (k + 1) + enddo + + ! ----------------------------------------------------------------------- + ! apply constraints + ! ----------------------------------------------------------------------- + + do k = 2, km + gam (k) = a4 (1, k) - a4 (1, k - 1) + enddo + + ! ----------------------------------------------------------------------- + ! top: + ! ----------------------------------------------------------------------- + + q (1) = max (q (1), 0.) + q (2) = min (q (2), max (a4 (1, 1), a4 (1, 2))) + q (2) = max (q (2), min (a4 (1, 1), a4 (1, 2)), 0.) + + ! ----------------------------------------------------------------------- + ! interior: + ! ----------------------------------------------------------------------- + + do k = 3, km - 1 + if (gam (k - 1) * gam (k + 1) .gt. 0.) then + ! apply large - scale constraints to all fields if not local max / min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + if (gam (k - 1) .gt. 0.) then + ! there exists a local max + q (k) = max (q (k), min (a4 (1, k - 1), a4 (1, k))) + else + ! there exists a local min + q (k) = min (q (k), max (a4 (1, k - 1), a4 (1, k))) + ! positive-definite + q (k) = max (q (k), 0.0) + endif + endif + enddo + + ! ----------------------------------------------------------------------- + ! bottom: + ! ----------------------------------------------------------------------- + + q (km) = min (q (km), max (a4 (1, km - 1), a4 (1, km))) + q (km) = max (q (km), min (a4 (1, km - 1), a4 (1, km)), 0.) + q (km + 1) = max (q (km + 1), 0.) + + do k = 1, km + a4 (2, k) = q (k) + a4 (3, k) = q (k + 1) + enddo + + do k = 1, km + if (k .eq. 1 .or. k .eq. km) then + extm (k) = (a4 (2, k) - a4 (1, k)) * (a4 (3, k) - a4 (1, k)) .gt. 0. + else + extm (k) = gam (k) * gam (k + 1) .lt. 0. + endif + enddo + + ! ----------------------------------------------------------------------- + ! apply constraints + ! f (s) = al + s * [ (ar - al) + a6 * (1 - s) ] (0 <= s <= 1) + ! always use monotonic mapping + ! ----------------------------------------------------------------------- + + ! ----------------------------------------------------------------------- + ! top: + ! ----------------------------------------------------------------------- + + a4 (2, 1) = max (0., a4 (2, 1)) + + ! ----------------------------------------------------------------------- + ! Huynh's 2nd constraint for interior: + ! ----------------------------------------------------------------------- + + do k = 3, km - 2 + if (extm (k)) then + ! positive definite constraint only if true local extrema + if (a4 (1, k) .lt. qcmin .or. extm (k - 1) .or. extm (k + 1)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + endif + else + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + if (abs (a4 (4, k)) .gt. abs (a4 (2, k) - a4 (3, k))) then + ! check within the smooth region if subgrid profile is non - monotonic + pmp_1 = a4 (1, k) - 2.0 * gam (k + 1) + lac_1 = pmp_1 + 1.5 * gam (k + 2) + a4 (2, k) = min (max (a4 (2, k), min (a4 (1, k), pmp_1, lac_1)), & + max (a4 (1, k), pmp_1, lac_1)) + pmp_2 = a4 (1, k) + 2.0 * gam (k) + lac_2 = pmp_2 - 1.5 * gam (k - 1) + a4 (3, k) = min (max (a4 (3, k), min (a4 (1, k), pmp_2, lac_2)), & + max (a4 (1, k), pmp_2, lac_2)) + endif + endif + enddo + + do k = 1, km - 1 + a4 (4, k) = 6. * a4 (1, k) - 3. * (a4 (2, k) + a4 (3, k)) + enddo + + k = km - 1 + if (extm (k)) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + da1 = a4 (3, k) - a4 (2, k) + da2 = da1 ** 2 + a6da = a4 (4, k) * da1 + if (a6da .lt. - da2) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + elseif (a6da .gt. da2) then + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + + call cs_limiters (km - 1, a4) + + ! ----------------------------------------------------------------------- + ! bottom: + ! ----------------------------------------------------------------------- + + a4 (2, km) = a4 (1, km) + a4 (3, km) = a4 (1, km) + a4 (4, km) = 0. + +end subroutine cs_profile + +! ======================================================================= +! cubic spline (cs) limiters or boundary conditions +! a positive-definite constraint (iv = 0) is applied to tracers in every layer, +! adjusting the top-most and bottom-most interface values to enforce positive. +! this subroutine is the same as cs_limiters in fv_mapz_mod where iv = 0. +! ======================================================================= + +subroutine cs_limiters (km, a4) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + real(kind_phys), intent (inout) :: a4 (4, km) ! ppm array + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys), parameter :: r12 = 1. / 12. + + do k = 1, km + if (a4 (1, k) .le. 0.) then + a4 (2, k) = a4 (1, k) + a4 (3, k) = a4 (1, k) + a4 (4, k) = 0. + else + if (abs (a4 (3, k) - a4 (2, k)) .lt. - a4 (4, k)) then + if ((a4 (1, k) + 0.25 * (a4 (3, k) - a4 (2, k)) ** 2 / a4 (4, k) + & + a4 (4, k) * r12) .lt. 0.) then + ! local minimum is negative + if (a4 (1, k) .lt. a4 (3, k) .and. a4 (1, k) .lt. a4 (2, k)) then + a4 (3, k) = a4 (1, k) + a4 (2, k) = a4 (1, k) + a4 (4, k) = 0. + elseif (a4 (3, k) .gt. a4 (2, k)) then + a4 (4, k) = 3. * (a4 (2, k) - a4 (1, k)) + a4 (3, k) = a4 (2, k) - a4 (4, k) + else + a4 (4, k) = 3. * (a4 (3, k) - a4 (1, k)) + a4 (2, k) = a4 (3, k) - a4 (4, k) + endif + endif + endif + endif + enddo + +end subroutine cs_limiters + +! ======================================================================= +! time-implicit monotonic scheme +! ======================================================================= + +subroutine implicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke + 1) :: ze + + real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp + + real(kind_phys), intent (inout), dimension (ks:ke) :: q + + real(kind_phys), intent (inout) :: precip + + real(kind_phys), intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys), dimension (ks:ke) :: dz, qm, dd + + do k = ks, ke + dz (k) = ze (k) - ze (k + 1) + dd (k) = dts * vt (k) + q (k) = q (k) * dp (k) + enddo + + qm (ks) = q (ks) / (dz (ks) + dd (ks)) + do k = ks + 1, ke + qm (k) = (q (k) + qm (k - 1) * dd (k - 1)) / (dz (k) + dd (k)) + enddo + + do k = ks, ke + qm (k) = qm (k) * dz (k) + enddo + + m1 (ks) = q (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q (k) - qm (k) + enddo + precip = precip + m1 (ke) + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine implicit_fall + +! ======================================================================= +! time-explicit monotonic scheme +! ======================================================================= + +subroutine explicit_fall (dts, ks, ke, ze, vt, dp, q, precip, m1) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke + 1) :: ze + + real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp + + real(kind_phys), intent (inout), dimension (ks:ke) :: q + + real(kind_phys), intent (inout) :: precip + + real(kind_phys), intent (out), dimension (ks:ke) :: m1 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: n, k, nstep + + real(kind_phys), dimension (ks:ke) :: dz, qm, q0, dd + + do k = ks, ke + dz (k) = ze (k) - ze (k + 1) + dd (k) = dts * vt (k) + q0 (k) = q (k) * dp (k) + enddo + + nstep = 1 + int (maxval (dd / dz)) + do k = ks, ke + dd (k) = dd (k) / nstep + q (k) = q0 (k) + enddo + + do n = 1, nstep + qm (ks) = q (ks) - q (ks) * dd (ks) / dz (ks) + do k = ks + 1, ke + qm (k) = q (k) - q (k) * dd (k) / dz (k) + q (k - 1) * dd (k - 1) / dz (k - 1) + enddo + q = qm + enddo + + m1 (ks) = q0 (ks) - qm (ks) + do k = ks + 1, ke + m1 (k) = m1 (k - 1) + q0 (k) - qm (k) + enddo + precip = precip + m1 (ke) + + do k = ks, ke + q (k) = qm (k) / dp (k) + enddo + +end subroutine explicit_fall + +! ======================================================================= +! combine time-implicit monotonic scheme with the piecewise parabolic lagrangian scheme +! ======================================================================= + +subroutine implicit_lagrangian_fall (dts, ks, ke, zs, ze, zt, vt, dp, q, & + precip, flux, sed_fac) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: zs, dts, sed_fac + + real(kind_phys), intent (in), dimension (ks:ke + 1) :: ze, zt + + real(kind_phys), intent (in), dimension (ks:ke) :: vt, dp + + real(kind_phys), intent (inout), dimension (ks:ke) :: q + + real(kind_phys), intent (inout) :: precip + + real(kind_phys), intent (out), dimension (ks:ke) :: flux + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys) :: pre0, pre1 + + real(kind_phys), dimension (ks:ke) :: q0, q1, m0, m1 + + q0 = q + pre0 = precip + + call implicit_fall (dts, ks, ke, ze, vt, dp, q0, pre0, m0) + + q1 = q + pre1 = precip + + call lagrangian_fall (ks, ke, zs, ze, zt, dp, q1, pre1, m1) + + q = q0 * sed_fac + q1 * (1.0 - sed_fac) + flux = m0 * sed_fac + m1 * (1.0 - sed_fac) + precip = pre0 * sed_fac + pre1 * (1.0 - sed_fac) + +end subroutine implicit_lagrangian_fall + +! ======================================================================= +! vertical subgrid variability used for cloud ice and cloud water autoconversion +! edges: qe == qbar + / - dm +! ======================================================================= + +subroutine linear_prof (km, q, dm, z_var, h_var) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: km + + logical, intent (in) :: z_var + + real(kind_phys), intent (in) :: q (km), h_var + + real(kind_phys), intent (out) :: dm (km) + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: dq (km) + + if (z_var) then + do k = 2, km + dq (k) = 0.5 * (q (k) - q (k - 1)) + enddo + dm (1) = 0. + ! ----------------------------------------------------------------------- + ! use twice the strength of the positive definiteness limiter (Lin et al. 1994) + ! ----------------------------------------------------------------------- + do k = 2, km - 1 + dm (k) = 0.5 * min (abs (dq (k) + dq (k + 1)), 0.5 * q (k)) + if (dq (k) * dq (k + 1) .le. 0.) then + if (dq (k) .gt. 0.) then + dm (k) = min (dm (k), dq (k), - dq (k + 1)) + else + dm (k) = 0. + endif + endif + enddo + dm (km) = 0. + ! ----------------------------------------------------------------------- + ! impose a presumed background horizontal variability that is proportional to the value itself + ! ----------------------------------------------------------------------- + do k = 1, km + dm (k) = max (dm (k), 0.0, h_var * q (k)) + enddo + else + do k = 1, km + dm (k) = max (0.0, h_var * q (k)) + enddo + endif + +end subroutine linear_prof + +! ======================================================================= +! accretion function, Lin et al. (1983) +! ======================================================================= + +function acr2d (qden, c, denfac, blin, mu) + + implicit none + + real(kind_phys) :: acr2d + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: qden, c, denfac, blin, mu + + acr2d = denfac * c * exp ((2 + mu + blin) / (mu + 3) * log (6 * qden)) + +end function acr2d + +! ======================================================================= +! accretion function, Lin et al. (1983) +! ======================================================================= + +function acr3d (v1, v2, q1, q2, c, acco, acc1, acc2, den) + + implicit none + + real(kind_phys) :: acr3d + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: v1, v2, c, den, q1, q2, acco (3), acc1, acc2 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + + real(kind_phys) :: t1, t2, tmp, vdiff + + t1 = exp (1. / (acc1 + 3) * log (6 * q1 * den)) + t2 = exp (1. / (acc2 + 3) * log (6 * q2 * den)) + + if (vdiffflag .eq. 1) vdiff = abs (v1 - v2) + if (vdiffflag .eq. 2) vdiff = sqrt ((1.20 * v1 - 0.95 * v2) ** 2. + 0.08 * v1 * v2) + if (vdiffflag .eq. 3) vdiff = sqrt ((1.00 * v1 - 1.00 * v2) ** 2. + 0.04 * v1 * v2) + + acr3d = c * vdiff / den + + tmp = 0 + do i = 1, 3 + tmp = tmp + acco (i) * exp ((6 + acc1 - i) * log (t1)) * exp ((acc2 + i - 1) * log (t2)) + enddo + + acr3d = acr3d * tmp + +end function acr3d + +! ======================================================================= +! ventilation coefficient, Lin et al. (1983) +! ======================================================================= + +function vent_coeff (qden, c1, c2, denfac, blin, mu) + + implicit none + + real(kind_phys) :: vent_coeff + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: qden, c1, c2, denfac, blin, mu + + vent_coeff = c1 + c2 * exp ((3 + 2 * mu + blin) / (mu + 3) / 2 * log (6 * qden)) * & + sqrt (denfac) / exp ((1 + mu) / (mu + 3) * log (6 * qden)) + +end function vent_coeff + +! ======================================================================= +! sublimation or evaporation function, Lin et al. (1983) +! ======================================================================= + +function psub (t2, dq, qden, qsat, c, den, denfac, blin, mu, cpk, cvm) + + implicit none + + real(kind_phys) :: psub + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: t2, dq, qden, qsat, c (5), den, denfac, blin, cpk, mu + + real (kind = r8), intent (in) :: cvm + + psub = c (1) * t2 * dq * exp ((1 + mu) / (mu + 3) * log (6 * qden)) * & + vent_coeff (qden, c (2), c (3), denfac, blin, mu) / & + (c (4) * t2 + c (5) * (cpk * cvm) ** 2 * qsat * den) + +end function psub + +! ======================================================================= +! melting function, Lin et al. (1983) +! ======================================================================= + +function pmlt (tc, dq, qden, pxacw, pxacr, c, den, denfac, blin, mu, lcpk, icpk, cvm) + + implicit none + + real(kind_phys) :: pmlt + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tc, dq, qden, pxacw, pxacr, c (4), den, denfac, blin, lcpk, icpk, mu + + real (kind = r8), intent (in) :: cvm + + pmlt = (c (1) / (icpk * cvm) * tc / den - c (2) * lcpk / icpk * dq) * & + exp ((1 + mu) / (mu + 3) * log (6 * qden)) * & + vent_coeff (qden, c (3), c (4), denfac, blin, mu) + & + c_liq / (icpk * cvm) * tc * (pxacw + pxacr) + +end function pmlt + +! ======================================================================= +! sedimentation of horizontal momentum +! ======================================================================= + +subroutine sedi_uv (ks, ke, m1, dp, u, v) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in), dimension (ks:ke) :: m1, dp + + real(kind_phys), intent (inout), dimension (ks:ke) :: u, v + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + do k = ks + 1, ke + u (k) = (dp (k) * u (k) + m1 (k - 1) * u (k - 1)) / (dp (k) + m1 (k - 1)) + v (k) = (dp (k) * v (k) + m1 (k - 1) * v (k - 1)) / (dp (k) + m1 (k - 1)) + enddo + +end subroutine sedi_uv + +! ======================================================================= +! sedimentation of vertical momentum +! ======================================================================= + +subroutine sedi_w (ks, ke, m1, w, vt, dm) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in), dimension (ks:ke) :: m1, vt, dm + + real(kind_phys), intent (inout), dimension (ks:ke) :: w + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + w (ks) = w (ks) + m1 (ks) * vt (ks) / dm (ks) + do k = ks + 1, ke + w (k) = (dm (k) * w (k) + m1 (k - 1) * (w (k - 1) - vt (k - 1)) + m1 (k) * vt (k)) / & + (dm (k) + m1 (k - 1)) + enddo + +end subroutine sedi_w + +! ======================================================================= +! sedimentation of heat +! ======================================================================= + +subroutine sedi_heat (ks, ke, dm, m1, dz, tz, qv, ql, qr, qi, qs, qg, cw) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: cw + + real(kind_phys), intent (in), dimension (ks:ke) :: dm, m1, dz, qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys), dimension (ks:ke) :: dgz, cv0 + + do k = ks + 1, ke + dgz (k) = - 0.5 * grav * (dz (k - 1) + dz (k)) + cv0 (k) = dm (k) * (cv_air + qv (k) * cv_vap + (qr (k) + ql (k)) * c_liq + & + (qi (k) + qs (k) + qg (k)) * c_ice) + cw * (m1 (k) - m1 (k - 1)) + enddo + + do k = ks + 1, ke + tz (k) = (cv0 (k) * tz (k) + m1 (k - 1) * (cw * tz (k - 1) + dgz (k))) / & + (cv0 (k) + cw * m1 (k - 1)) + enddo + +end subroutine sedi_heat + +! ======================================================================= +! fast saturation adjustments +! ======================================================================= + +subroutine cld_sat_adj (dtm, is, ie, ks, ke, hydrostatic, consv_te, & + adj_vmr, te, dte, qv, ql, qr, qi, qs, qg, qa, qnl, qni, hs, delz, & + pt, delp, q_con, cappa, gsize, last_step, do_sat_adj) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + logical, intent (in) :: hydrostatic, last_step, consv_te, do_sat_adj + + real(kind_phys), intent (in) :: dtm + + real(kind_phys), intent (in), dimension (is:ie) :: hs, gsize + + real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: qnl, qni + + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: delp, delz, pt, te + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: qv, ql, qr, qi, qs, qg, qa + + real(kind_phys), intent (inout), dimension (is:, ks:) :: q_con, cappa + + real(kind_phys), intent (out), dimension (is:ie, ks:ke) :: adj_vmr + + real (kind = r8), intent (out), dimension (is:ie) :: dte + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys), dimension (is:ie, ks:ke) :: ua, va, wa, prefluxw, prefluxr, prefluxi, prefluxs, prefluxg + + real(kind_phys), dimension (is:ie) :: water, rain, ice, snow, graupel + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + ua = 0.0 + va = 0.0 + wa = 0.0 + + water = 0.0 + rain = 0.0 + ice = 0.0 + snow = 0.0 + graupel = 0.0 + + prefluxw = 0.0 + prefluxr = 0.0 + prefluxi = 0.0 + prefluxs = 0.0 + prefluxg = 0.0 + + ! ----------------------------------------------------------------------- + ! major cloud microphysics driver + ! ----------------------------------------------------------------------- + + call mpdrv (hydrostatic, ua, va, wa, delp, pt, qv, ql, qr, qi, qs, qg, qa, & + qnl, qni, delz, is, ie, ks, ke, dtm, water, rain, ice, snow, graupel, & + gsize, hs, q_con, cappa, consv_te, adj_vmr, te, dte, prefluxw, prefluxr, & + prefluxi, prefluxs, prefluxg, last_step, .false., do_sat_adj, .false.) + +end subroutine cld_sat_adj + +! ======================================================================= +! rain freezing to form graupel, simple version +! ======================================================================= + +subroutine pgfr_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, sink, fac_r2g + + fac_r2g = 1. - exp (- dts / tau_r2g) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .lt. 0. .and. qr (k) .gt. qcmin) then + + sink = (- tc * 0.025) ** 2 * qr (k) + sink = min (qr (k), sink, - fac_r2g * tc / icpk (k)) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., - sink, 0., 0., sink, te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine pgfr_simp + +! ======================================================================= +! snow melting to form cloud water and rain, simple version +! ======================================================================= + +subroutine psmlt_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, cvm, te8, & + lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real (kind = r8), intent (in), dimension (ks:ke) :: te8 + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + real(kind_phys), intent (inout), dimension (ks:ke) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (inout), dimension (ks:ke) :: cvm, tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, tmp, sink, fac_smlt + + fac_smlt = 1. - exp (- dts / tau_smlt) + + do k = ks, ke + + tc = tz (k) - tice + + if (tc .ge. 0. .and. qs (k) .gt. qcmin) then + + sink = (tc * 0.1) ** 2 * qs (k) + sink = min (qs (k), sink, fac_smlt * tc / icpk (k)) + tmp = min (sink, dim (qs_mlt, ql (k))) + + call update_qt (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., tmp, sink - tmp, 0., - sink, 0., te8 (k), cvm (k), tz (k), & + lcpk (k), icpk (k), tcpk (k), tcp3 (k)) + + endif + + enddo + +end subroutine psmlt_simp + +! ======================================================================= +! cloud water to rain autoconversion, simple version +! ======================================================================= + +subroutine praut_simp (ks, ke, dts, tz, qv, ql, qr, qi, qs, qg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, sink, fac_l2r + + fac_l2r = 1. - exp (- dts / tau_l2r) + + do k = ks, ke + + tc = tz (k) - t_wfr + + if (tc .gt. 0 .and. ql (k) .gt. ql0_max) then + + sink = fac_l2r * (ql (k) - ql0_max) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., - sink, sink, 0., 0., 0.) + + endif + + enddo + +end subroutine praut_simp + +! ======================================================================= +! cloud ice to snow autoconversion, simple version +! ======================================================================= + +subroutine psaut_simp (ks, ke, dts, qv, ql, qr, qi, qs, qg, tz, den) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in) :: dts + + real(kind_phys), intent (in), dimension (ks:ke) :: den + + real(kind_phys), intent (inout), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (inout), dimension (ks:ke) :: tz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: tc, sink, fac_i2s, qim + + fac_i2s = 1. - exp (- dts / tau_i2s) + + do k = ks, ke + + tc = tz (k) - tice + + qim = qi0_max / den (k) + + if (tc .lt. 0. .and. qi (k) .gt. qim) then + + sink = fac_i2s * (qi (k) - qim) + + call update_qq (qv (k), ql (k), qr (k), qi (k), qs (k), qg (k), & + 0., 0., 0., - sink, sink, 0.) + + endif + + enddo + +end subroutine psaut_simp + +! ======================================================================= +! cloud radii diagnosis built for gfdl cloud microphysics +! ======================================================================= + +subroutine cld_eff_rad (is, ie, ks, ke, lsm, p, delp, t, qv, qw, qi, qr, qs, qg, qa, & + rew, rei, rer, res, reg, snowd, cnvw, cnvi) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: is, ie, ks, ke + + real(kind_phys), intent (in), dimension (is:ie) :: lsm, snowd + + real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: delp, t, p + real(kind_phys), intent (in), dimension (is:ie, ks:ke) :: qv, qw, qi, qr, qs, qg, qa + + real(kind_phys), intent (in), dimension (is:ie, ks:ke), optional :: cnvw, cnvi + + real(kind_phys), intent (inout), dimension (is:ie, ks:ke) :: rew, rei, rer, res, reg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k, ind + + real(kind_phys), dimension (is:ie, ks:ke) :: qcw, qci, qcr, qcs, qcg + real(kind_phys), dimension (is:ie, ks:ke) :: qmw, qmr, qmi, qms, qmg + + real(kind_phys) :: dpg, rho, ccnw, mask, cor, tc, bw + real(kind_phys) :: lambdaw, lambdar, lambdai, lambdas, lambdag, rei_fac + + real(kind_phys) :: retab (138) = (/ & + 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, 0.05000, & + 0.05500, 0.06000, 0.07000, 0.08000, 0.09000, 0.10000, & + 0.20000, 0.30000, 0.40000, 0.50000, 0.60000, 0.70000, & + 0.80000, 0.90000, 1.00000, 1.10000, 1.20000, 1.30000, & + 1.40000, 1.50000, 1.60000, 1.80000, 2.00000, 2.20000, & + 2.40000, 2.60000, 2.80000, 3.00000, 3.20000, 3.50000, & + 3.80000, 4.10000, 4.40000, 4.70000, 5.00000, 5.30000, & + 5.60000, 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & + 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & + 205.728, 214.055, 222.694, 231.661, 240.971, 250.639 /) + + qmw = qw + qmi = qi + qmr = qr + qms = qs + qmg = qg + + ! ----------------------------------------------------------------------- + ! merge convective cloud to total cloud + ! ----------------------------------------------------------------------- + + if (present (cnvw)) then + qmw = qmw + cnvw + endif + if (present (cnvi)) then + qmi = qmi + cnvi + endif + + ! ----------------------------------------------------------------------- + ! combine liquid and solid phases + ! ----------------------------------------------------------------------- + + if (liq_ice_combine) then + do i = is, ie + do k = ks, ke + qmw (i, k) = qmw (i, k) + qmr (i, k) + qmr (i, k) = 0.0 + qmi (i, k) = qmi (i, k) + qms (i, k) + qmg (i, k) + qms (i, k) = 0.0 + qmg (i, k) = 0.0 + enddo + enddo + endif + + ! ----------------------------------------------------------------------- + ! combine snow and graupel + ! ----------------------------------------------------------------------- + + if (snow_grauple_combine) then + do i = is, ie + do k = ks, ke + qms (i, k) = qms (i, k) + qmg (i, k) + qmg (i, k) = 0.0 + enddo + enddo + endif + + do i = is, ie + + do k = ks, ke + + qmw (i, k) = max (qmw (i, k), qcmin) + qmi (i, k) = max (qmi (i, k), qcmin) + qmr (i, k) = max (qmr (i, k), qcmin) + qms (i, k) = max (qms (i, k), qcmin) + qmg (i, k) = max (qmg (i, k), qcmin) + + + mask = min (max (lsm (i), 0.0), 2.0) + + dpg = abs (delp (i, k)) / grav + rho = p (i, k) / (rdgas * t (i, k) * (1. + zvir * qv (i, k))) + + tc = t (i, k) - tice + + if (rewflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! cloud water (Martin et al. 1994) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + ! boucher and lohmann (1995) + ccnw = (1.0 - abs (mask - 1.0)) * & + (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + & + abs (mask - 1.0) * & + (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48) + else + ccnw = ccn_o * abs (mask - 1.0) + ccn_l * (1.0 - abs (mask - 1.0)) + endif + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / & + (4.0 * pi * rhow * ccnw))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (rewflag .eq. 2) then + + ! ----------------------------------------------------------------------- + ! cloud water (Martin et al. 1994, gfdl revision) + ! ----------------------------------------------------------------------- + + if (prog_ccn) then + ! boucher and lohmann (1995) + ccnw = (1.0 - abs (mask - 1.0)) * & + (10. ** 2.24 * (qa (i, k) * rho * 1.e9) ** 0.257) + & + abs (mask - 1.0) * & + (10. ** 2.06 * (qa (i, k) * rho * 1.e9) ** 0.48) + else + ccnw = 1.077 * ccn_o * abs (mask - 1.0) + 1.143 * ccn_l * (1.0 - abs (mask - 1.0)) + endif + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = exp (1.0 / 3.0 * log ((3.0 * qmw (i, k) * rho) / & + (4.0 * pi * rhow * ccnw))) * 1.0e4 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (rewflag .eq. 3) then + + ! ----------------------------------------------------------------------- + ! cloud water (Kiehl et al. 1994) + ! ----------------------------------------------------------------------- + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + rew (i, k) = 14.0 * abs (mask - 1.0) + & + (8.0 + (14.0 - 8.0) * min (1.0, max (0.0, - tc / 30.0))) * & + (1.0 - abs (mask - 1.0)) + rew (i, k) = rew (i, k) + (14.0 - rew (i, k)) * & + min (1.0, max (0.0, snowd (i) / 1000.0)) ! snowd is in mm + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (rewflag .eq. 4) then + + ! ----------------------------------------------------------------------- + ! cloud water derived from PSD + ! ----------------------------------------------------------------------- + + if (qmw (i, k) .gt. qcmin) then + qcw (i, k) = dpg * qmw (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmw (i, k), rho, blinw, muw, & + eda = edaw, edb = edbw, ed = rew (i, k)) + rew (i, k) = rewfac * 0.5 * rew (i, k) * 1.0e6 + rew (i, k) = max (rewmin, min (rewmax, rew (i, k))) + else + qcw (i, k) = 0.0 + rew (i, k) = rewmin + endif + + endif + + if (reiflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Heymsfield and Mcfarquhar 1996) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei_fac = log (1.0e3 * qmi (i, k) * rho) + if (tc .lt. - 50) then + rei (i, k) = beta / 9.917 * exp (0.109 * rei_fac) * 1.0e3 + elseif (tc .lt. - 40) then + rei (i, k) = beta / 9.337 * exp (0.080 * rei_fac) * 1.0e3 + elseif (tc .lt. - 30) then + rei (i, k) = beta / 9.208 * exp (0.055 * rei_fac) * 1.0e3 + else + rei (i, k) = beta / 9.387 * exp (0.031 * rei_fac) * 1.0e3 + endif + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 2) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Donner et al. 1997) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + if (tc .le. - 55) then + rei (i, k) = 15.41627 + elseif (tc .le. - 50) then + rei (i, k) = 16.60895 + elseif (tc .le. - 45) then + rei (i, k) = 32.89967 + elseif (tc .le. - 40) then + rei (i, k) = 35.29989 + elseif (tc .le. - 35) then + rei (i, k) = 55.65818 + elseif (tc .le. - 30) then + rei (i, k) = 85.19071 + elseif (tc .le. - 25) then + rei (i, k) = 72.35392 + else + rei (i, k) = 92.46298 + endif + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 3) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Fu 2007) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei (i, k) = 47.05 + tc * (0.6624 + 0.001741 * tc) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 4) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Kristjansson et al. 2000) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + ind = min (max (int (t (i, k) - 136.0), 44), 138 - 1) + cor = t (i, k) - int (t (i, k)) + rei (i, k) = retab (ind) * (1. - cor) + retab (ind + 1) * cor + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 5) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Wyser 1998) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + bw = - 2. + 1.e-3 * log10 (rho * qmi (i, k) / 50.e-3) * & + exp (1.5 * log (max (1.e-10, - tc))) + rei (i, k) = 377.4 + bw * (203.3 + bw * (37.91 + 2.3696 * bw)) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 6) then + + ! ----------------------------------------------------------------------- + ! cloud ice (Sun and Rikus 1999, Sun 2001) + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + rei_fac = log (1.0e3 * qmi (i, k) * rho) + rei (i, k) = 45.8966 * exp (0.2214 * rei_fac) + & + 0.7957 * exp (0.2535 * rei_fac) * (tc + 190.0) + rei (i, k) = (1.2351 + 0.0105 * tc) * rei (i, k) + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (reiflag .eq. 7) then + + ! ----------------------------------------------------------------------- + ! cloud ice derived from PSD + ! ----------------------------------------------------------------------- + + if (qmi (i, k) .gt. qcmin) then + qci (i, k) = dpg * qmi (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmi (i, k), rho, blini, mui, & + eda = edai, edb = edbi, ed = rei (i, k)) + rei (i, k) = reifac * 0.5 * rei (i, k) * 1.0e6 + rei (i, k) = max (reimin, min (reimax, rei (i, k))) + else + qci (i, k) = 0.0 + rei (i, k) = reimin + endif + + endif + + if (rerflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! rain derived from PSD + ! ----------------------------------------------------------------------- + + if (qmr (i, k) .gt. qcmin) then + qcr (i, k) = dpg * qmr (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qmr (i, k), rho, blinr, mur, & + eda = edar, edb = edbr, ed = rer (i, k)) + rer (i, k) = 0.5 * rer (i, k) * 1.0e6 + rer (i, k) = max (rermin, min (rermax, rer (i, k))) + else + qcr (i, k) = 0.0 + rer (i, k) = rermin + endif + + endif + + if (resflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! snow derived from PSD + ! ----------------------------------------------------------------------- + + if (qms (i, k) .gt. qcmin) then + qcs (i, k) = dpg * qms (i, k) * 1.0e3 + call cal_pc_ed_oe_rr_tv (qms (i, k), rho, blins, mus, & + eda = edas, edb = edbs, ed = res (i, k)) + res (i, k) = 0.5 * res (i, k) * 1.0e6 + res (i, k) = max (resmin, min (resmax, res (i, k))) + else + qcs (i, k) = 0.0 + res (i, k) = resmin + endif + + endif + + if (regflag .eq. 1) then + + ! ----------------------------------------------------------------------- + ! graupel derived from PSD + ! ----------------------------------------------------------------------- + + if (qmg (i, k) .gt. qcmin) then + qcg (i, k) = dpg * qmg (i, k) * 1.0e3 + if (do_hail) then + call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, blinh, muh, & + eda = edah, edb = edbh, ed = reg (i, k)) + else + call cal_pc_ed_oe_rr_tv (qmg (i, k), rho, bling, mug, & + eda = edag, edb = edbg, ed = reg (i, k)) + endif + reg (i, k) = 0.5 * reg (i, k) * 1.0e6 + reg (i, k) = max (regmin, min (regmax, reg (i, k))) + else + qcg (i, k) = 0.0 + reg (i, k) = regmin + endif + + endif + + enddo + + enddo + +end subroutine cld_eff_rad + +! ======================================================================= +! radar reflectivity +! ======================================================================= + +subroutine rad_ref (is, ie, js, je, qv, qr, qs, qg, pt, delp, & + delz, dbz, npz, hydrostatic, do_inline_mp, mp_top) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: hydrostatic, do_inline_mp + + integer, intent (in) :: is, ie, js, je + integer, intent (in) :: npz, mp_top + !integer, intent (in) :: sphum, liq_wat, ice_wat, rainwat, snowwat, graupel + + !real(kind_phys), intent (in) :: zvir + + real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: delz + + real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: pt, delp + + real(kind_phys), intent (in), dimension (is:ie, js:je, npz) :: qv, qr, qs, qg + + !real(kind_phys), intent (in), dimension (is:ie, npz + 1, js:je) :: peln + + !real(kind_phys), intent (out) :: allmax + + !real(kind_phys), intent (out), dimension (is:ie, js:je) :: maxdbz + + real(kind_phys), intent (out), dimension (is:ie, js:je, npz) :: dbz + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, j, k + + real(kind_phys), parameter :: alpha = 0.224, mp_const = 200 * exp (1.6 * log (3.6e6)) + + real (kind = r8) :: qden, z_e + real(kind_phys) :: fac_r, fac_s, fac_g + real(kind_phys) :: allmax + real(kind_phys), dimension (is:ie, js:je) :: maxdbz + + real(kind_phys), dimension (npz) :: den, denfac, qmr, qms, qmg, vtr, vts, vtg + + ! ----------------------------------------------------------------------- + ! return if the microphysics scheme doesn't include rain + ! ----------------------------------------------------------------------- + + !if (rainwat .lt. 1) return + + ! ----------------------------------------------------------------------- + ! initialization + ! ----------------------------------------------------------------------- + + dbz = - 20. + maxdbz = - 20. + allmax = - 20. + + ! ----------------------------------------------------------------------- + ! calculate radar reflectivity + ! ----------------------------------------------------------------------- + + do j = js, je + do i = is, ie + + ! ----------------------------------------------------------------------- + ! air density + ! ----------------------------------------------------------------------- + + do k = 1, npz + !if (hydrostatic) then + ! den (k) = delp (i, j, k) / ((peln (i, k + 1, j) - peln (i, k, j)) * & + ! rdgas * pt (i, j, k) * (1. + zvir * qv (i, j, k))) + !else + ! den (k) = - delp (i, j, k) / (grav * delz (i, j, k)) + !endif + + den (k) = - delp (i, j, k) / (grav * delz (i, j, k)) + qmr (k) = max (qcmin, qr (i, j, k)) + qms (k) = max (qcmin, qs (i, j, k)) + qmg (k) = max (qcmin, qg (i, j, k)) + enddo + + do k = 1, npz + denfac (k) = sqrt (den (npz) / den (k)) + enddo + + ! ----------------------------------------------------------------------- + ! fall speed + ! ----------------------------------------------------------------------- + + if (radr_flag .eq. 3) then + call term_rsg (1, npz, qmr, den, denfac, vr_fac, blinr, & + mur, tvar, tvbr, vr_max, const_vr, vtr) + vtr = vtr / rhor + endif + + if (rads_flag .eq. 3) then + call term_rsg (1, npz, qms, den, denfac, vs_fac, blins, & + mus, tvas, tvbs, vs_max, const_vs, vts) + vts = vts / rhos + endif + + if (radg_flag .eq. 3) then + if (do_hail .and. .not. do_inline_mp) then + call term_rsg (1, npz, qmg, den, denfac, vg_fac, blinh, & + muh, tvah, tvbh, vg_max, const_vg, vtg) + vtg = vtg / rhoh + else + call term_rsg (1, npz, qmg, den, denfac, vg_fac, bling, & + mug, tvag, tvbg, vg_max, const_vg, vtg) + vtg = vtg / rhog + endif + endif + + ! ----------------------------------------------------------------------- + ! radar reflectivity + ! ----------------------------------------------------------------------- + + do k = mp_top + 1, npz + z_e = 0. + + !if (rainwat .gt. 0) then + qden = den (k) * qmr (k) + if (qmr (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qmr (k), den (k), blinr, mur, & + rra = rrar, rrb = rrbr, rr = fac_r) + else + fac_r = 0.0 + endif + if (radr_flag .eq. 1 .or. radr_flag .eq. 2) then + z_e = z_e + fac_r * 1.e18 + endif + if (radr_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vtr (k))) + endif + !endif + + !if (snowwat .gt. 0) then + qden = den (k) * qms (k) + if (qms (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qms (k), den (k), blins, mus, & + rra = rras, rrb = rrbs, rr = fac_s) + else + fac_s = 0.0 + endif + if (rads_flag .eq. 1) then + if (pt (i, j, k) .lt. tice) then + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhor) ** 2 + else + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhor) ** 2 / alpha + endif + endif + if (rads_flag .eq. 2) then + if (pt (i, j, k) .lt. tice) then + z_e = z_e + fac_s * 1.e18 * alpha * (rhos / rhoi) ** 2 + else + z_e = z_e + fac_s * 1.e18 + endif + endif + if (rads_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vts (k))) + endif + !endif + + !if (graupel .gt. 0) then + qden = den (k) * qmg (k) + if (do_hail .and. .not. do_inline_mp) then + if (qmg (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qmg (k), den (k), blinh, muh, & + rra = rrah, rrb = rrbh, rr = fac_g) + else + fac_g = 0.0 + endif + if (radg_flag .eq. 1) then + if (pt (i, j, k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhor) ** 2 + else + z_e = z_e + fac_g * 1.e18 * alpha * (rhoh / rhor) ** 2 / alpha + endif + endif + if (radg_flag .eq. 2) then + z_e = z_e + fac_g * 1.e18 + endif + else + if (qmg (k) .gt. qcmin) then + call cal_pc_ed_oe_rr_tv (qmg (k), den (k), bling, mug, & + rra = rrag, rrb = rrbg, rr = fac_g) + else + fac_g = 0.0 + endif + if (radg_flag .eq. 1) then + if (pt (i, j, k) .lt. tice) then + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhor) ** 2 + else + z_e = z_e + fac_g * 1.e18 * alpha * (rhog / rhor) ** 2 / alpha + endif + endif + if (radg_flag .eq. 2) then + z_e = z_e + fac_g * 1.e18 + endif + endif + if (radg_flag .eq. 3) then + z_e = z_e + mp_const * exp (1.6 * log (qden * vtg (k))) + endif + !endif + + dbz (i, j, k) = 10. * log10 (max (0.01, z_e)) + enddo + + do k = mp_top + 1, npz + maxdbz (i, j) = max (dbz (i, j, k), maxdbz (i, j)) + enddo + + allmax = max (maxdbz (i, j), allmax) + + enddo + enddo + +end subroutine rad_ref + +! ======================================================================= +! moist heat capacity, 3 input variables +! ======================================================================= + +function mhc3 (qv, q_liq, q_sol) + + implicit none + + real (kind = r8) :: mhc3 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: qv, q_liq, q_sol + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + mhc3 = one_r8 + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice + +end function mhc3 + +! ======================================================================= +! moist heat capacity, 4 input variables +! ======================================================================= + +function mhc4 (qd, qv, q_liq, q_sol) + + implicit none + + real (kind = r8) :: mhc4 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: qv, q_liq, q_sol + + real (kind = r8), intent (in) :: qd + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + mhc4 = qd + qv * c1_vap + q_liq * c1_liq + q_sol * c1_ice + +end function mhc4 + +! ======================================================================= +! moist heat capacity, 6 input variables +! ======================================================================= + +function mhc6 (qv, ql, qr, qi, qs, qg) + + implicit none + + real (kind = r8) :: mhc6 + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: qv, ql, qr, qi, qs, qg + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys) :: q_liq, q_sol + + q_liq = ql + qr + q_sol = qi + qs + qg + mhc6 = mhc (qv, q_liq, q_sol) + +end function mhc6 + +! ======================================================================= +! moist total energy +! ======================================================================= + +function mte (qv, ql, qr, qi, qs, qg, tk, dp, moist_q) + + implicit none + + real (kind = r8) :: mte + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + logical, intent (in) :: moist_q + + real(kind_phys), intent (in) :: qv, ql, qr, qi, qs, qg, dp + + real (kind = r8), intent (in) :: tk + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys) :: q_liq, q_sol, q_cond + + real (kind = r8) :: cvm, con_r8 + + q_liq = ql + qr + q_sol = qi + qs + qg + q_cond = q_liq + q_sol + con_r8 = one_r8 - (qv + q_cond) + if (moist_q) then + cvm = mhc (con_r8, qv, q_liq, q_sol) + else + cvm = mhc (qv, q_liq, q_sol) + endif + mte = rgrav * cvm * c_air * tk * dp + +end function mte + +! ======================================================================= +! moist total energy and total water +! ======================================================================= + +subroutine mtetw (ks, ke, qv, ql, qr, qi, qs, qg, tz, ua, va, wa, delp, & + dte, vapor, water, rain, ice, snow, graupel, sen, stress, dts, & + te, tw, te_b, tw_b, moist_q, hydrostatic, te_loss) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + logical, intent (in) :: moist_q, hydrostatic + + real(kind_phys), intent (in) :: vapor, water, rain, ice, snow, graupel, dts, sen, stress + + real(kind_phys), intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg, ua, va, wa, delp + + real (kind = r8), intent (in) :: dte + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real (kind = r8), intent (out) :: te_b, tw_b + + real (kind = r8), intent (out), optional :: te_loss + + real (kind = r8), intent (out), dimension (ks:ke) :: te, tw + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + real(kind_phys) :: q_cond + + real (kind = r8) :: con_r8 + + real(kind_phys), dimension (ks:ke) :: q_liq, q_sol + + real (kind = r8), dimension (ks:ke) :: cvm + + do k = ks, ke + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + q_cond = q_liq (k) + q_sol (k) + con_r8 = one_r8 - (qv (k) + q_cond) + if (moist_q) then + cvm (k) = mhc (con_r8, qv (k), q_liq (k), q_sol (k)) + else + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + endif + te (k) = (cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k)) * c_air + if (hydrostatic) then + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2) + else + te (k) = te (k) + 0.5 * (ua (k) ** 2 + va (k) ** 2 + wa (k) ** 2) + endif + te (k) = rgrav * te (k) * delp (k) + tw (k) = rgrav * (qv (k) + q_cond) * delp (k) + enddo + te_b = (dte + (lv00 * c_air * vapor - li00 * c_air * (ice + snow + graupel)) * dts / 86400 + sen * dts + stress * dts) + tw_b = (vapor + water + rain + ice + snow + graupel) * dts / 86400 + + if (present (te_loss)) then + ! total energy change due to sedimentation and its heating + te_loss = dte + endif + +end subroutine mtetw + +! ======================================================================= +! calculate heat capacities and latent heat coefficients +! ======================================================================= + +subroutine cal_mhc_lhc (ks, ke, qv, ql, qr, qi, qs, qg, q_liq, q_sol, & + cvm, te8, tz, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: ks, ke + + real(kind_phys), intent (in), dimension (ks:ke) :: qv, ql, qr, qi, qs, qg + + real (kind = r8), intent (in), dimension (ks:ke) :: tz + + real(kind_phys), intent (out), dimension (ks:ke) :: q_liq, q_sol, lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (out), dimension (ks:ke) :: cvm, te8 + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: k + + do k = ks, ke + q_liq (k) = ql (k) + qr (k) + q_sol (k) = qi (k) + qs (k) + qg (k) + cvm (k) = mhc (qv (k), q_liq (k), q_sol (k)) + te8 (k) = cvm (k) * tz (k) + lv00 * qv (k) - li00 * q_sol (k) + lcpk (k) = (lv00 + d1_vap * tz (k)) / cvm (k) + icpk (k) = (li00 + d1_ice * tz (k)) / cvm (k) + tcpk (k) = (li20 + (d1_vap + d1_ice) * tz (k)) / cvm (k) + tcp3 (k) = lcpk (k) + icpk (k) * min (1., dim (tice, tz (k)) / (tice - t_wfr)) + enddo + +end subroutine cal_mhc_lhc + +! ======================================================================= +! update hydrometeors +! ======================================================================= + +subroutine update_qq (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: dqv, dql, dqr, dqi, dqs, dqg + + real(kind_phys), intent (inout) :: qv, ql, qr, qi, qs, qg + + qv = qv + dqv + ql = ql + dql + qr = qr + dqr + qi = qi + dqi + qs = qs + dqs + qg = qg + dqg + +end subroutine update_qq + +! ======================================================================= +! update hydrometeors and temperature +! ======================================================================= + +subroutine update_qt (qv, ql, qr, qi, qs, qg, dqv, dql, dqr, dqi, dqs, dqg, te8, & + cvm, tk, lcpk, icpk, tcpk, tcp3) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: dqv, dql, dqr, dqi, dqs, dqg + + real (kind = r8), intent (in) :: te8 + + real(kind_phys), intent (inout) :: qv, ql, qr, qi, qs, qg + + real(kind_phys), intent (out) :: lcpk, icpk, tcpk, tcp3 + + real (kind = r8), intent (out) :: cvm, tk + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + qv = qv + dqv + ql = ql + dql + qr = qr + dqr + qi = qi + dqi + qs = qs + dqs + qg = qg + dqg + + cvm = mhc (qv, ql, qr, qi, qs, qg) + tk = (te8 - lv00 * qv + li00 * (qi + qs + qg)) / cvm + + lcpk = (lv00 + d1_vap * tk) / cvm + icpk = (li00 + d1_ice * tk) / cvm + tcpk = (li20 + (d1_vap + d1_ice) * tk) / cvm + tcp3 = lcpk + icpk * min (1., dim (tice, tk) / (tice - t_wfr)) + +end subroutine update_qt + +! ======================================================================= +! calculation of particle concentration (pc), effective diameter (ed), +! optical extinction (oe), radar reflectivity factor (rr), and +! mass-weighted terminal velocity (tv) +! ======================================================================= + +subroutine cal_pc_ed_oe_rr_tv (q, den, blin, mu, pca, pcb, pc, eda, edb, ed, & + oea, oeb, oe, rra, rrb, rr, tva, tvb, tv) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: blin, mu + + real(kind_phys), intent (in) :: q, den + + real (kind = r8), intent (in), optional :: pca, pcb, eda, edb, oea, oeb, rra, rrb, tva, tvb + + real(kind_phys), intent (out), optional :: pc, ed, oe, rr, tv + + if (present (pca) .and. present (pcb) .and. present (pc)) then + pc = pca / pcb * exp (mu / (mu + 3) * log (6 * den * q)) + endif + if (present (eda) .and. present (edb) .and. present (ed)) then + ed = eda / edb * exp (1. / (mu + 3) * log (6 * den * q)) + endif + if (present (oea) .and. present (oeb) .and. present (oe)) then + oe = oea / oeb * exp ((mu + 2) / (mu + 3) * log (6 * den * q)) + endif + if (present (rra) .and. present (rrb) .and. present (rr)) then + rr = rra / rrb * exp ((mu + 6) / (mu + 3) * log (6 * den * q)) + endif + if (present (tva) .and. present (tvb) .and. present (tv)) then + tv = tva / tvb * exp (blin / (mu + 3) * log (6 * den * q)) + endif + +end subroutine cal_pc_ed_oe_rr_tv + +! ======================================================================= +! prepare saturation water vapor pressure tables +! ======================================================================= + +subroutine qs_init + + implicit none + + integer :: i + + if (.not. tables_are_initialized) then + + allocate (table0 (length)) + allocate (table1 (length)) + allocate (table2 (length)) + allocate (table3 (length)) + allocate (table4 (length)) + + allocate (des0 (length)) + allocate (des1 (length)) + allocate (des2 (length)) + allocate (des3 (length)) + allocate (des4 (length)) + + call qs_table0 (length) + call qs_table1 (length) + call qs_table2 (length) + call qs_table3 (length) + call qs_table4 (length) + + do i = 1, length - 1 + des0 (i) = max (0., table0 (i + 1) - table0 (i)) + des1 (i) = max (0., table1 (i + 1) - table1 (i)) + des2 (i) = max (0., table2 (i + 1) - table2 (i)) + des3 (i) = max (0., table3 (i + 1) - table3 (i)) + des4 (i) = max (0., table4 (i + 1) - table4 (i)) + enddo + des0 (length) = des0 (length - 1) + des1 (length) = des1 (length - 1) + des2 (length) = des2 (length - 1) + des3 (length) = des3 (length - 1) + des4 (length) = des4 (length - 1) + + tables_are_initialized = .true. + + endif + +end subroutine qs_init + +! ======================================================================= +! saturation water vapor pressure table, core function +! ======================================================================= + +subroutine qs_table_core (n, n_blend, do_smith_table, table) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n, n_blend + + logical, intent (in) :: do_smith_table + + real(kind_phys), intent (out), dimension (n) :: table + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + integer, parameter :: n_min = 1600 + + real (kind = r8) :: delt = 0.1 + real (kind = r8) :: tmin, tem, esh + real (kind = r8) :: wice, wh2o, fac0, fac1, fac2 + real (kind = r8) :: esbasw, tbasw, esbasi, a, b, c, d, e + real (kind = r8) :: esupc (n_blend) + + esbasw = 1013246.0 + tbasw = tice + 100. + esbasi = 6107.1 + tmin = tice - n_min * delt + + ! ----------------------------------------------------------------------- + ! compute es over ice between - (n_min * delt) deg C and 0 deg C + ! ----------------------------------------------------------------------- + + if (do_smith_table) then + do i = 1, n_min + tem = tmin + delt * real (i - 1, kind=kind_phys) + a = - 9.09718 * (tice / tem - 1.) + b = - 3.56654 * log10 (tice / tem) + c = 0.876793 * (1. - tem / tice) + e = log10 (esbasi) + table (i) = 0.1 * exp ((a + b + c + e) * log (10.)) + enddo + else + do i = 1, n_min + tem = tmin + delt * real (i - 1, kind=kind_phys) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * li2 + fac2 = (d2_ice * log (tem / tice) + fac1) / rvgas + table (i) = e00 * exp (fac2) + enddo + endif + + ! ----------------------------------------------------------------------- + ! compute es over water between - (n_blend * delt) deg C and [ (n - n_min - 1) * delt] deg C + ! ----------------------------------------------------------------------- + + if (do_smith_table) then + do i = 1, n - n_min + n_blend + tem = tice + delt * (real (i - 1, kind=kind_phys) - n_blend) + a = - 7.90298 * (tbasw / tem - 1.) + b = 5.02808 * log10 (tbasw / tem) + c = - 1.3816e-7 * (exp ((1. - tem / tbasw) * 11.344 * log (10.)) - 1.) + d = 8.1328e-3 * (exp ((tbasw / tem - 1.) * (- 3.49149) * log (10.)) - 1.) + e = log10 (esbasw) + esh = 0.1 * exp ((a + b + c + d + e) * log (10.)) + if (i .le. n_blend) then + esupc (i) = esh + else + table (i + n_min - n_blend) = esh + endif + enddo + else + do i = 1, n - n_min + n_blend + tem = tice + delt * (real (i - 1, kind=kind_phys) - n_blend) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas + esh = e00 * exp (fac2) + if (i .le. n_blend) then + esupc (i) = esh + else + table (i + n_min - n_blend) = esh + endif + enddo + endif + + ! ----------------------------------------------------------------------- + ! derive blended es over ice and supercooled water between - (n_blend * delt) deg C and 0 deg C + ! ----------------------------------------------------------------------- + + do i = 1, n_blend + tem = tice + delt * (real (i - 1, kind=kind_phys) - n_blend) + wice = 1.0 / (delt * n_blend) * (tice - tem) + wh2o = 1.0 / (delt * n_blend) * (tem - tice + delt * n_blend) + table (i + n_min - n_blend) = wice * table (i + n_min - n_blend) + wh2o * esupc (i) + enddo + +end subroutine qs_table_core + +! ======================================================================= +! saturation water vapor pressure table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +subroutine qs_table0 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i + + real (kind = r8) :: delt = 0.1 + real (kind = r8) :: tmin, tem, fac0, fac1, fac2 + + tmin = tice - 160. + + ! ----------------------------------------------------------------------- + ! compute es over water only + ! ----------------------------------------------------------------------- + + do i = 1, n + tem = tmin + delt * real (i - 1, kind=kind_phys) + fac0 = (tem - tice) / (tem * tice) + fac1 = fac0 * lv0 + fac2 = (dc_vap * log (tem / tice) + fac1) / rvgas + table0 (i) = e00 * exp (fac2) + enddo + +end subroutine qs_table0 + +! ======================================================================= +! saturation water vapor pressure table 1, water and ice +! blended between -20 deg C and 0 deg C +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +subroutine qs_table1 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 200, .false., table1) + +end subroutine qs_table1 + +! ======================================================================= +! saturation water vapor pressure table 2, water and ice +! same as table 1, but the blending is replaced with smoothing around 0 deg C +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +subroutine qs_table2 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 0, .false., table2) + +end subroutine qs_table2 + +! ======================================================================= +! saturation water vapor pressure table 3, water and ice +! blended between -20 deg C and 0 deg C +! the same as table 1, but from smithsonian meteorological tables page 350 +! ======================================================================= + +subroutine qs_table3 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 200, .true., table3) + +end subroutine qs_table3 + +! ======================================================================= +! saturation water vapor pressure table 4, water and ice +! same as table 3, but the blending is replaced with smoothing around 0 deg C +! the same as table 2, but from smithsonian meteorological tables page 350 +! ======================================================================= + +subroutine qs_table4 (n) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: n + + call qs_table_core (n, 0, .true., table4) + +end subroutine qs_table4 + +! ======================================================================= +! compute the saturated water pressure, core function +! ======================================================================= + +function es_core (length, tk, table, des) + + implicit none + + real(kind_phys) :: es_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: length + + real(kind_phys), intent (in) :: tk + + real(kind_phys), intent (in), dimension (length) :: table, des + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: it + + real(kind_phys) :: ap1, tmin + + if (.not. tables_are_initialized) call qs_init + + tmin = tice - 160. + ap1 = 10. * dim (tk, tmin) + 1. + ap1 = min (2621., ap1) + it = ap1 + es_core = table (it) + (ap1 - it) * des (it) + +end function es_core + +! ======================================================================= +! compute the saturated specific humidity, core function +! ======================================================================= + +function qs_core (length, tk, den, dqdt, table, des) + + implicit none + + real(kind_phys) :: qs_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: length + + real(kind_phys), intent (in) :: tk, den + + real(kind_phys), intent (in), dimension (length) :: table, des + + real(kind_phys), intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: it + + real(kind_phys) :: ap1, tmin + + tmin = tice - 160. + ap1 = 10. * dim (tk, tmin) + 1. + ap1 = min (2621., ap1) + qs_core = es_core (length, tk, table, des) / (rvgas * tk * den) + it = ap1 - 0.5 + dqdt = 10. * (des (it) + (ap1 - it) * (des (it + 1) - des (it))) / (rvgas * tk * den) + +end function qs_core + +! ======================================================================= +! compute the saturated water pressure based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wes_t (tk) + + implicit none + + real(kind_phys) :: wes_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk + + wes_t = es_core (length, tk, table0, des0) + +end function wes_t + +! ======================================================================= +! compute the saturated water pressure based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mes_t (tk) + + implicit none + + real(kind_phys) :: mes_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk + + mes_t = es_core (length, tk, table1, des1) + +end function mes_t + +! ======================================================================= +! compute the saturated water pressure based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function ies_t (tk) + + implicit none + + real(kind_phys) :: ies_t + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk + + ies_t = es_core (length, tk, table2, des2) + +end function ies_t + +! ======================================================================= +! compute the saturated specific humidity based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wqs_trho (tk, den, dqdt) + + implicit none + + real(kind_phys) :: wqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk, den + + real(kind_phys), intent (out) :: dqdt + + wqs_trho = qs_core (length, tk, den, dqdt, table0, des0) + +end function wqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mqs_trho (tk, den, dqdt) + + implicit none + + real(kind_phys) :: mqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk, den + + real(kind_phys), intent (out) :: dqdt + + mqs_trho = qs_core (length, tk, den, dqdt, table1, des1) + +end function mqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function iqs_trho (tk, den, dqdt) + + implicit none + + real(kind_phys) :: iqs_trho + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk, den + + real(kind_phys), intent (out) :: dqdt + + iqs_trho = qs_core (length, tk, den, dqdt, table2, des2) + +end function iqs_trho + +! ======================================================================= +! compute the saturated specific humidity based on table 0, water only +! useful for idealized experiments +! it can also be used in warm rain microphyscis only +! ======================================================================= + +function wqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real(kind_phys) :: wqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk, pa, qv + + real(kind_phys), intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys) :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + wqs_ptqv = wqs (tk, den, dqdt) + +end function wqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! ======================================================================= + +function mqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real(kind_phys) :: mqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk, pa, qv + + real(kind_phys), intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys) :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + mqs_ptqv = mqs (tk, den, dqdt) + +end function mqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 2, water and ice +! it is not designed for mixed-phase cloud microphysics +! used for ice microphysics (< 0 deg C) or warm rain microphysics (> 0 deg C) +! ======================================================================= + +function iqs_ptqv (tk, pa, qv, dqdt) + + implicit none + + real(kind_phys) :: iqs_ptqv + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: tk, pa, qv + + real(kind_phys), intent (out) :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys) :: den + + den = pa / (rdgas * tk * (1. + zvir * qv)) + + iqs_ptqv = iqs (tk, den, dqdt) + +end function iqs_ptqv + +! ======================================================================= +! compute the saturated specific humidity based on table 1, water and ice +! the most realistic saturation water vapor pressure for the full temperature range +! it is the 3d version of "mqs" +! ======================================================================= + +subroutine mqs3d (im, km, ks, tk, pa, qv, qs, dqdt) + + implicit none + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + integer, intent (in) :: im, km, ks + + real(kind_phys), intent (in), dimension (im, ks:km) :: tk, pa, qv + + real(kind_phys), intent (out), dimension (im, ks:km) :: qs + + real(kind_phys), intent (out), dimension (im, ks:km), optional :: dqdt + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + integer :: i, k + + real(kind_phys) :: dqdt0 + + if (present (dqdt)) then + do k = ks, km + do i = 1, im + qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt (i, k)) + enddo + enddo + else + do k = ks, km + do i = 1, im + qs (i, k) = mqs (tk (i, k), pa (i, k), qv (i, k), dqdt0) + enddo + enddo + endif + +end subroutine mqs3d + +! ======================================================================= +! compute wet buld temperature, core function +! Knox et al. (2017) +! ======================================================================= + +function wet_bulb_core (qv, tk, den, lcp) + + implicit none + + real(kind_phys) :: wet_bulb_core + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: qv, tk, den, lcp + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + logical :: do_adjust = .false. + + real(kind_phys) :: factor = 1. / 3. + real(kind_phys) :: qsat, tp, dqdt + + wet_bulb_core = tk + qsat = wqs (wet_bulb_core, den, dqdt) + tp = factor * (qsat - qv) / (1. + lcp * dqdt) * lcp + wet_bulb_core = wet_bulb_core - tp + + if (do_adjust .and. tp .gt. 0.0) then + qsat = wqs (wet_bulb_core, den, dqdt) + tp = (qsat - qv) / (1. + lcp * dqdt) * lcp + wet_bulb_core = wet_bulb_core - tp + endif + +end function wet_bulb_core + +! ======================================================================= +! compute wet buld temperature, dry air case +! ======================================================================= + +function wet_bulb_dry (qv, tk, den) + + implicit none + + real(kind_phys) :: wet_bulb_dry + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: qv, tk, den + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys) :: lcp + + lcp = hlv / cp_air + + wet_bulb_dry = wet_bulb_core (qv, tk, den, lcp) + +end function wet_bulb_dry + +! ======================================================================= +! compute wet buld temperature, moist air case +! ======================================================================= + +function wet_bulb_moist (qv, ql, qi, qr, qs, qg, tk, den) + + implicit none + + real(kind_phys) :: wet_bulb_moist + + ! ----------------------------------------------------------------------- + ! input / output arguments + ! ----------------------------------------------------------------------- + + real(kind_phys), intent (in) :: qv, ql, qi, qr, qs, qg, tk, den + + ! ----------------------------------------------------------------------- + ! local variables + ! ----------------------------------------------------------------------- + + real(kind_phys) :: lcp, q_liq, q_sol + + real (kind = r8) :: cvm + + q_liq = ql + qr + q_sol = qi + qs + qg + cvm = mhc (qv, q_liq, q_sol) + lcp = (lv00 + d1_vap * tk) / cvm + + wet_bulb_moist = wet_bulb_core (qv, tk, den, lcp) + +end function wet_bulb_moist + +end module gfdl_cloud_microphys_v3_mod diff --git a/physics/MP/Morrison_Gettelman/aerclm_def.F b/physics/MP/Morrison_Gettelman/aerclm_def.F index b6760f30c..3bfa6791a 100644 --- a/physics/MP/Morrison_Gettelman/aerclm_def.F +++ b/physics/MP/Morrison_Gettelman/aerclm_def.F @@ -3,15 +3,17 @@ module aerclm_def implicit none integer, parameter :: levsaer=72, ntrcaerm=15, timeaer=2 - integer :: latsaer, lonsaer, ntrcaer, levsw - integer :: n1sv, n2sv + integer :: latsaer, lonsaer, ntrcaer, levsw, tsaer + integer :: n1sv, n2sv, t1sv, t2sv integer :: iamin, iamax, jamin, jamax character*10 :: specname(ntrcaerm) + character*50 :: fname_dl real (kind=kind_phys):: aer_time(13) real (kind=kind_phys), allocatable, dimension(:) :: aer_lat real (kind=kind_phys), allocatable, dimension(:) :: aer_lon + real (kind=kind_phys), allocatable, dimension(:) :: aer_t real (kind=kind_io4), allocatable, dimension(:,:,:,:) :: aer_pres real (kind=kind_io4), allocatable, dimension(:,:,:,:,:) :: aerin diff --git a/physics/MP/Morrison_Gettelman/aerinterp.F90 b/physics/MP/Morrison_Gettelman/aerinterp.F90 index 97113a4e1..15963db7d 100644 --- a/physics/MP/Morrison_Gettelman/aerinterp.F90 +++ b/physics/MP/Morrison_Gettelman/aerinterp.F90 @@ -9,16 +9,17 @@ module aerinterp implicit none - private read_netfaer + private read_netfaer, read_netfaer_dl, fdnx_fname public :: read_aerdata, setindxaer, aerinterpol,read_aerdataf + public :: read_aerdata_dl, aerinterpol_dl,read_aerdataf_dl contains logical function netcdf_check(status, errmsg, errflg, why) use netcdf implicit none - character(len=*), intent(inout) :: errmsg + character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg integer, intent(in) :: status character(len=*), intent(in) :: why @@ -34,21 +35,407 @@ logical function netcdf_check(status, errmsg, errflg, why) endif END function netcdf_check - - SUBROUTINE read_aerdata (me, master, iflip, idate, errmsg, errflg) - use machine, only: kind_phys, kind_io4, kind_io8 +!!!!!!! + SUBROUTINE read_aerdata_dl (me, master, iflip, idate, FHOUR, errmsg, errflg) + use machine, only: kind_phys, kind_io4, kind_dbl_prec use aerclm_def use netcdf +!--- in/out + integer, intent(in) :: me, master, iflip, idate(4) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg + real(kind=kind_phys), intent(in) :: fhour +!--- locals + integer :: ncid, varid, ndims, hmx + integer :: i, j, k, n, ii, imon, klev + character :: fname*50, mn*2, vname*10, dy*2, myr*4 + logical :: file_exist + integer :: dimids(NF90_MAX_VAR_DIMS) + integer :: dimlen(NF90_MAX_VAR_DIMS) + integer IDAT(8),JDAT(8) + real(kind=kind_phys) rjday + real(kind=kind_dbl_prec) rinc(5) + integer jdow, jdoy, jday + + errflg = 0 + errmsg = ' ' + +! +!! =================================================================== + if (me == master) then + if ( iflip == 0 ) then ! data from toa to sfc + print *, "GFS is top-down" + else + print *, "GFS is bottom-up" + endif + endif +!! found first day needed to interpolated + IDAT = 0 + IDAT(1) = IDATE(4) + IDAT(2) = IDATE(2) + IDAT(3) = IDATE(3) + IDAT(5) = IDATE(1) + RINC = 0. + RINC(2) = FHOUR + CALL W3MOVDAT(RINC,IDAT,JDAT) +! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + +! +!! =================================================================== +!! check if all necessary files exist +!! =================================================================== + write(myr,'(i4.4)') jdat(1) + write(mn,'(i2.2)') jdat(2) + write(dy,'(i2.2)') jdat(3) + fname=trim("merra2_"//myr//mn//dy//".nc") + inquire (file = fname, exist = file_exist) + if (.not. file_exist) then + errmsg = 'Error in read_aerdata: file ' // trim(fname) // ' not found' + errflg = 1 + return + endif +! +!! =================================================================== +!! fetch dim spec and lat/lon from m01 data set +!! =================================================================== + ncid = -1 + if(.not.netcdf_check(nf90_open(fname , nf90_NOWRITE, ncid), & + errmsg, errflg, 'open '//trim(fname))) then + return + endif + + vname = trim(specname(1)) + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, vname, varid), & + errmsg, errflg, 'find id of '//trim(vname)//' var')) then + return + endif + ndims = 0 + if(.not.netcdf_check(nf90_inquire_variable(ncid, varid, ndims=ndims, dimids=dimids), & + errmsg, errflg, 'inquire details about '//trim(vname)//' var')) then + return + endif + do i=1,ndims + if(.not.netcdf_check(nf90_inquire_dimension(ncid, dimids(i), len=dimlen(i)), & + errmsg, errflg, 'inquire details about dimension')) then + return + endif + enddo + +! specify latsaer, lonsaer, hmx + lonsaer = dimlen(1) + latsaer = dimlen(2) + levsw = dimlen(3) + tsaer = dimlen(4) + + if(me==master) then + print *, 'MERRA2 dim: ',dimlen(1:ndims) + endif + +! allocate arrays + + if (.not. allocated(aer_lat)) then + allocate(aer_lat(latsaer)) + allocate(aer_lon(lonsaer)) + allocate(aer_t(tsaer)) + endif + +! construct lat/lon array + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, 'lat', varid), & + errmsg, errflg, 'find id of lat var')) then + return + endif + aer_lat = 0 + if(.not.netcdf_check(nf90_get_var(ncid, varid, aer_lat, (/ 1, 1, 1 /), (/latsaer, 1, 1/)), & + errmsg, errflg, 'read lat var')) then + return + endif + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, 'lon', varid), & + errmsg, errflg, 'find id of lon var')) then + return + endif + aer_lon = 0 + if(.not.netcdf_check(nf90_get_var(ncid, varid, aer_lon, (/ 1, 1, 1 /), (/lonsaer, 1, 1/)), & + errmsg, errflg, 'read lon var')) then + return + endif + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, 'time', varid), & + errmsg, errflg, 'find id of time var')) then + return + endif + aer_t = 0 + if(.not.netcdf_check(nf90_get_var(ncid, varid, aer_t, (/ 1, 1, 1 /), (/tsaer, 1, 1/)), & + errmsg, errflg, 'read t var')) then + return + endif + if(.not.netcdf_check(nf90_close(ncid), errmsg, errflg, 'close '//trim(fname))) then + return + endif + END SUBROUTINE read_aerdata_dl +! +!********************************************************************** + SUBROUTINE read_aerdataf_dl ( me, master, iflip, idate, FHOUR, errmsg, errflg) + use machine, only: kind_phys, kind_dbl_prec + use aerclm_def + !--- in/out integer, intent(in) :: me, master, iflip, idate(4) character(len=*), intent(inout) :: errmsg integer, intent(inout) :: errflg + real(kind=kind_phys), intent(in) :: fhour +!--- locals + integer :: i, j, k, n, ii, imon, klev, n1, n2 + logical :: file_exist, fd_upb + integer IDAT(8),JDAT(8) + real(kind=kind_phys) rjday + real(kind=kind_dbl_prec) rinc(5) + integer jdow, jdoy, jday + character myr*4, mn*2, dy*2 + + integer, allocatable :: invardims(:) +! + if (.not. allocated(aerin)) then + allocate(aerin(iamin:iamax,jamin:jamax,levsaer,ntrcaerm,timeaer)) + allocate(aer_pres(iamin:iamax,jamin:jamax,levsaer,timeaer)) + endif + +! allocate local working arrays +!! found interpolation months + IDAT = 0 + IDAT(1) = IDATE(4) + IDAT(2) = IDATE(2) + IDAT(3) = IDATE(3) + IDAT(5) = IDATE(1) + RINC = 0. + RINC(2) = FHOUR + CALL W3MOVDAT(RINC,IDAT,JDAT) +! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + write(myr,'(i4.4)') jdat(1) + write(mn,'(i2.2)') jdat(2) + write(dy,'(i2.2)') jdat(3) + fname_dl="merra2_"//myr//mn//dy//".nc" +! rjday is the minutes in a day + rjday = jdat(5)*60+jdat(6)+jdat(7)/60. +! +! n1sv saves the jdat(3), n2sv is the up boundary index + n1sv=jdat(3) + fd_upb=.false. + do j=2, tsaer + if ( aer_t(j)> rjday) then + n2sv = j + t2sv = aer_t(j) + fd_upb=.true. + exit + endif + enddo + if(fd_upb) then + t1sv = aer_t(j-1) + call read_netfaer_dl(fname_dl, j-1, iflip, 1, errmsg, errflg) + call read_netfaer_dl(fname_dl, n2sv, iflip, 2, errmsg, errflg) + else + t1sv = aer_t(tsaer) + call read_netfaer_dl(fname_dl, tsaer, iflip, 1, errmsg, errflg) + n2sv=1 + t2sv=1440. + call fdnx_fname (jdat(1), jdat(2),jdat(3),fname_dl) + call read_netfaer_dl(fname_dl, n2sv, iflip, 2, errmsg, errflg) + end if + END SUBROUTINE read_aerdataf_dl +!********************************************************************** +! + SUBROUTINE aerinterpol_dl( me,master,nthrds,npts,IDATE,FHOUR,iflip, jindx1,jindx2, & + ddy,iindx1,iindx2,ddx,lev,prsl,aerout, errmsg,errflg) +! + use machine, only: kind_phys, kind_dbl_prec + use aerclm_def + + implicit none + integer, intent(out) :: errflg + character(*), intent(out) :: errmsg + integer, intent(in) :: iflip + integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i,ii, klev + real(kind=kind_phys) fhour,temj, tx1, tx2,temi, tem, tem1, tem2 + real(kind=kind_phys), dimension(npts) :: temij,temiy,temjx,ddxy + +! + + integer JINDX1(npts), JINDX2(npts), iINDX1(npts), iINDX2(npts) + integer me,idate(4), master, nthrds + integer IDAT(8),JDAT(8) +! + real(kind=kind_phys) DDY(npts), ddx(npts),ttt + real(kind=kind_phys) aerout(npts,lev,ntrcaer) + real(kind=kind_phys) aerpm(npts,levsaer,ntrcaer) + real(kind=kind_phys) prsl(npts,lev), aerpres(npts,levsaer) + real(kind=kind_phys) rjday + real(kind=kind_dbl_prec) rinc(5) + integer jdow, jdoy, jday + character myr*4, mn*2, dy*2 +! + errflg = 0 + errmsg = ' ' + IDAT = 0 + IDAT(1) = IDATE(4) + IDAT(2) = IDATE(2) + IDAT(3) = IDATE(3) + IDAT(5) = IDATE(1) + RINC = 0. + RINC(2) = FHOUR + CALL W3MOVDAT(RINC,IDAT,JDAT) +! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) +! rjday is the minutes in a day + rjday = jdat(5)*60+jdat(6)+jdat(7)/60. + if(rjday >= t2sv .or. jdat(3).ne.n1sv) then !!need to either to read in a record or open a new file + call read_netfaer_dl(fname_dl,n2sv, iflip, 1, errmsg, errflg) + end if +!! =================================================================== + if(jdat(3).ne.n1sv) then ! a new day is produced from n2sv=1440 + n1sv=jdat(3) + t1sv=aer_t(1) + n2sv=2 + t2sv=aer_t(n2sv) + write(myr,'(i4.4)') jdat(1) + write(mn,'(i2.2)') jdat(2) + write(dy,'(i2.2)') jdat(3) + fname_dl="merra2_"//myr//mn//dy//".nc" + call read_netfaer_dl(fname_dl,n2sv, iflip, 2, errmsg, errflg) + else if (rjday >= t2sv) then + if(t2sv < aer_t(tsaer)) then + n1sv=jdat(3) + t1sv=t2sv + n2sv=n2sv+1 + t2sv=aer_t(n2sv) + write(myr,'(i4.4)') jdat(1) + write(mn,'(i2.2)') jdat(2) + write(dy,'(i2.2)') jdat(3) + fname_dl="merra2_"//myr//mn//dy//".nc" + call read_netfaer_dl(fname_dl,n2sv, iflip, 2, errmsg, errflg) + else !! need to read a new file + n1sv=jdat(3) + t1sv=aer_t(tsaer) + n2sv=1 + t2sv=1440. + call fdnx_fname (jdat(1), jdat(2),jdat(3),fname_dl) + call read_netfaer_dl(fname_dl, n2sv, iflip, 2, errmsg, errflg) + end if + end if +! + tx1 = (t2sv - rjday) / (t2sv - t1sv) + tx2 = 1.0 - tx1 + if (n2 > 12) n2 = n2 -12 + + do j=1,npts + TEMJ = 1.0 - DDY(J) + TEMI = 1.0 - DDX(J) + temij(j) = TEMI*TEMJ + temiy(j) = TEMI*DDY(j) + temjx(j) = TEMJ*DDX(j) + ddxy(j) = DDX(j)*DDY(J) + enddo + +#ifndef __GFORTRAN__ +!$OMP parallel num_threads(nthrds) default(none) & +!$OMP shared(npts,ntrcaer,aerin,aer_pres,prsl) & +!$OMP shared(ddx,ddy,jindx1,jindx2,iindx1,iindx2) & +!$OMP shared(aerpm,aerpres,aerout,lev,nthrds) & +!$OMP shared(temij,temiy,temjx,ddxy,tx1,tx2) & +!$OMP private(l,j,k,ii,i1,i2,j1,j2,tem,tem1,tem2) + +!$OMP do +#endif + DO L=1,levsaer + DO J=1,npts + J1 = JINDX1(J) + J2 = JINDX2(J) + I1 = IINDX1(J) + I2 = IINDX2(J) + DO ii=1,ntrcaer + aerpm(j,L,ii) = & + tx1*(TEMIJ(j)*aerin(I1,J1,L,ii,1)+DDXY(j)*aerin(I2,J2,L,ii,1) & + +TEMIY(j)*aerin(I1,J2,L,ii,1)+temjx(j)*aerin(I2,J1,L,ii,1))& + +tx2*(TEMIJ(j)*aerin(I1,J1,L,ii,2)+DDXY(j)*aerin(I2,J2,L,ii,2) & + +TEMIY(j)*aerin(I1,J2,L,ii,2)+temjx(j)*aerin(I2,J1,L,ii,2)) + ENDDO + + aerpres(j,L) = & + tx1*(TEMIJ(j)*aer_pres(I1,J1,L,1)+DDXY(j)*aer_pres(I2,J2,L,1) & + +TEMIY(j)*aer_pres(I1,J2,L,1)+temjx(j)*aer_pres(I2,J1,L,1))& + +tx2*(TEMIJ(j)*aer_pres(I1,J1,L,2)+DDXY(j)*aer_pres(I2,J2,L,2) & + +TEMIY(j)*aer_pres(I1,J2,L,2)+temjx(j)*aer_pres(I2,J1,L,2)) + ENDDO + ENDDO +#ifndef __GFORTRAN__ +!$OMP end do + +! don't flip, input is the same direction as GFS (bottom-up) +!$OMP do +#endif + DO J=1,npts + DO L=1,lev + if(prsl(j,L) >= aerpres(j,1)) then + DO ii=1, ntrcaer + aerout(j,L,ii) = aerpm(j,1,ii) !! sfc level + ENDDO + else if(prsl(j,L) <= aerpres(j,levsaer)) then + DO ii=1, ntrcaer + aerout(j,L,ii) = aerpm(j,levsaer,ii) !! toa top + ENDDO + else + DO k=1, levsaer-1 !! from sfc to toa + IF(prsl(j,L) <= aerpres(j,k) .and. prsl(j,L)>aerpres(j,k+1)) then + i1 = k + i2 = min(k+1,levsaer) + exit + ENDIF + ENDDO + tem = 1.0 / (aerpres(j,i1) - aerpres(j,i2)) + tem1 = (prsl(j,L) - aerpres(j,i2)) * tem + tem2 = (aerpres(j,i1) - prsl(j,L)) * tem + DO ii = 1, ntrcaer + aerout(j,L,ii) = aerpm(j,i1,ii)*tem1 + aerpm(j,i2,ii)*tem2 + ENDDO + endif + ENDDO !L-loop + ENDDO !J-loop +#ifndef __GFORTRAN__ +!$OMP end do + +!$OMP end parallel +#endif + + RETURN + END SUBROUTINE aerinterpol_dl + + SUBROUTINE read_aerdata (me, master, iflip, idate, errmsg, errflg) + use machine, only: kind_phys, kind_io4 + use aerclm_def + use netcdf + +!--- in/out + integer, intent(in) :: me, master, iflip, idate(4) + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !--- locals integer :: ncid, varid, ndims, hmx integer :: i, j, k, n, ii, imon, klev - character :: fname*50, mn*2, vname*10 + character :: fname*50, myr*4, mn*2, dy*2,vname*10 logical :: file_exist integer :: dimids(NF90_MAX_VAR_DIMS) integer :: dimlen(NF90_MAX_VAR_DIMS) @@ -67,7 +454,7 @@ SUBROUTINE read_aerdata (me, master, iflip, idate, errmsg, errflg) endif ! !! =================================================================== -!! check if all necessary files exist +!! check if one file exist !! =================================================================== do imon = 1, 12 write(mn,'(i2.2)') imon @@ -278,8 +665,8 @@ SUBROUTINE aerinterpol( me,master,nthrds,npts,IDATE,FHOUR,iflip, jindx1,jindx2, use aerclm_def implicit none - integer, intent(inout) :: errflg - character(*), intent(inout) :: errmsg + integer, intent(out) :: errflg + character(*), intent(out) :: errmsg integer, intent(in) :: iflip integer i1,i2, iday,j,j1,j2,l,npts,nc,n1,n2,lev,k,i,ii, klev real(kind=kind_phys) fhour,temj, tx1, tx2,temi, tem, tem1, tem2 @@ -426,14 +813,162 @@ SUBROUTINE aerinterpol( me,master,nthrds,npts,IDATE,FHOUR,iflip, jindx1,jindx2, RETURN END SUBROUTINE aerinterpol +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! private subroutines + subroutine fdnx_fname(lyear, lmn, ldy, fname) + integer, intent(inout) ::lyear, lmn, ldy + character, intent(out) :: fname*50 + integer, dimension(12) :: mndy + character myr*4, mn*2, dy*2 + data mndy/31, 28, 31,30,31,30,31,31,30,31,30,31/ + ldy=ldy+1 + if(lmn==12) then + if(ldy>mndy(12)) then + ldy=1 + lmn=1 + lyear=lyear+1 + end if + else if(lmn==2) then + if (mod(lyear,4)==0) then + if(ldy>mndy(2)+1) then + ldy=1 + lmn=3 + end if + else + if(ldy>mndy(2)) then + ldy=1 + lmn=3 + end if + end if + else + if(ldy>mndy(lmn)) then + ldy=1 + lmn=lmn+1 + end if + end if + write(myr,'(i4.4)') lyear + write(mn,'(i2.2)') lmn + write(dy,'(i2.2)') ldy + fname="merra2_"//myr//mn//dy//".nc" + RETURN + END SUBROUTINE fdnx_fname + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine read_netfaer_dl(fname, nf, iflip,nt, errmsg,errflg) + use machine, only: kind_phys, kind_io4 + use aerclm_def + use netcdf + integer, intent(in) :: iflip, nf, nt + character,intent(in) :: fname*50 + integer, intent(out) :: errflg + character(*), intent(out) :: errmsg + integer :: ncid, varid, i,j,k,ii,klev + character :: vname*10 + real(kind=kind_io4),allocatable,dimension(:,:,:) :: buff + real(kind=kind_io4),allocatable,dimension(:,:,:,:):: buffx + real(kind=kind_io4),allocatable,dimension(:,:) :: pres_tmp + integer lstart(4), lcount(4) +!! =================================================================== + allocate (buff(lonsaer, latsaer, levsw)) + allocate (pres_tmp(lonsaer, levsw)) + allocate (buffx(lonsaer, latsaer, levsw, 1)) + + errflg = 0 + errmsg = ' ' + buff = 0 + pres_tmp = 0 + buffx = 0 + + ncid = -1 + if(.not.netcdf_check(nf90_open(trim(fname), nf90_NOWRITE, ncid), & + errmsg, errflg, 'open '//trim(fname))) then + return + endif + lstart=(/1,1,1,nf/) + lcount=(/lonsaer, latsaer, levsw,1/) +! ====> construct 3-d pressure array (Pa) + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, "DELP", varid), & + errmsg, errflg, 'find id of DELP var')) then + return + endif + if(.not.netcdf_check(nf90_get_var(ncid, varid, buff, lstart, lcount), & + errmsg, errflg, 'read DELP var')) then + return + endif + + do j = jamin, jamax + do i = iamin, iamax +! constract pres_tmp (top-down), note input is top-down + pres_tmp(i,1) = 0. + do k=2, levsw + pres_tmp(i,k) = pres_tmp(i,k-1)+buff(i,j,k) + enddo !k-loop + enddo !i-loop (lon) + +! extract pres_tmp to fill aer_pres (in Pa) + do k = 1, levsaer + if ( iflip == 0 ) then ! data from toa to sfc + klev = k + else ! data from sfc to top + klev = ( levsw - k ) + 1 + endif + do i = iamin, iamax + aer_pres(i,j,k,nt) = 1.d0*pres_tmp(i,klev) + enddo !i-loop (lon) + enddo !k-loop (lev) + enddo !j-loop (lat) + +! ====> construct 4-d aerosol array (kg/kg) +! merra2 data is top down +! for GFS, iflip 0: toa to sfc; 1: sfc to toa + DO ii = 1, ntrcaerm + vname=trim(specname(ii)) + varid = -1 + if(.not.netcdf_check(nf90_inq_varid(ncid, vname, varid), & + errmsg, errflg, 'get id of '//trim(vname)//' var')) then + return + endif + if(.not.netcdf_check(nf90_get_var(ncid, varid, buffx, lstart, lcount), & + errmsg, errflg, 'read '//trim(vname)//' var')) then + return + endif + + do j = jamin, jamax + do k = 1, levsaer +! input is from toa to sfc + if ( iflip == 0 ) then ! data from toa to sfc + klev = k + else ! data from sfc to top + klev = ( levsw - k ) + 1 + endif + do i = iamin, iamax + aerin(i,j,k,ii,nt) = 1.d0*buffx(i,j,klev,1) + if(aerin(i,j,k,ii,nt) < 0 .or. aerin(i,j,k,ii,nt) > 1.) then + aerin(i,j,k,ii,nt) = 1.e-15 + endif + enddo !i-loop (lon) + enddo !k-loop (lev) + enddo !j-loop (lat) + + ENDDO ! ii-loop (ntracaerm) + +! close the file + if(.not.netcdf_check(nf90_close(ncid), errmsg, errflg, 'close '//trim(fname))) then + return + endif + deallocate (buff, pres_tmp) + deallocate (buffx) + END SUBROUTINE read_netfaer_dl +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine read_netfaer(nf, iflip,nt, errmsg,errflg) - use machine, only: kind_phys, kind_io4, kind_io8 + use machine, only: kind_phys, kind_io4 use aerclm_def use netcdf integer, intent(in) :: iflip, nf, nt - integer, intent(inout) :: errflg - character(*), intent(inout) :: errmsg + integer, intent(out) :: errflg + character(*), intent(out) :: errmsg integer :: ncid, varid, i,j,k,ii,klev character :: fname*50, mn*2, vname*10 real(kind=kind_io4),allocatable,dimension(:,:,:) :: buff diff --git a/physics/MP/NSSL/module_mp_nssl_2mom.F90 b/physics/MP/NSSL/module_mp_nssl_2mom.F90 index 963d2531c..1afbc13cf 100644 --- a/physics/MP/NSSL/module_mp_nssl_2mom.F90 +++ b/physics/MP/NSSL/module_mp_nssl_2mom.F90 @@ -1275,7 +1275,7 @@ END SUBROUTINE nssl_2mom_init_const !! NSSL MP setup routine (sets local options and array indices) SUBROUTINE nssl_2mom_init( & & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idoniconlytmp, & - & namelist_filename, & + & namelist_filename, internal_nml, & & nssl_graupelfallfac, & & nssl_hailfallfac, & & nssl_ehw0, & @@ -1319,7 +1319,8 @@ SUBROUTINE nssl_2mom_init( & integer, intent(in),optional :: infileunit - integer,parameter::strsize=512 + integer,parameter::strsize=64 + character(len=*), intent(in), optional :: internal_nml(:) character(len=strsize), intent(in), optional :: namelist_filename character(len=strsize) :: namelist_inputfile @@ -1474,22 +1475,24 @@ SUBROUTINE nssl_2mom_init( & irainbreak = 0 ENDIF ENDIF - - - - + +#ifdef INTERNAL_FILE_NML + read (internal_nml, nml = nssl_mp_params, iostat=istat) +#else + namelist_inputfile = 'namelist.input' ! default for WRF/cm1 - IF ( present( namelist_filename ) ) THEN + IF ( present( namelist_filename ) ) THEN namelist_inputfile = namelist_filename ELSE namelist_inputfile = 'input.nml' ENDIF - - IF ( .true. ) THEN ! set to true to enable internal namelist read - open(15,file=namelist_inputfile,status='old',form='formatted',action='read') - rewind(15) - read(15,NML=nssl_mp_params,iostat=istat) - close(15) + + open(15,file=trim(namelist_inputfile),status='old',form='formatted',action='read') + rewind(15) + read(15,NML=nssl_mp_params,iostat=istat) + close(15) +#endif + IF ( .true. ) THEN ! set to true to enable internal namelist read IF ( present ( myrank ) .and. present ( mpiroot ) ) THEN IF ( myrank == mpiroot ) THEN IF ( istat /= 0 ) THEN @@ -1501,10 +1504,9 @@ SUBROUTINE nssl_2mom_init( & open(15,file='nssl_mp_params.out',status='unknown',form='formatted') write(15,NML=nssl_mp_params) close(15) - ENDIF - ENDIF - ENDIF - + ENDIF + ENDIF + ENDIF IF ( iufccn > 0 ) THEN ! make sure to use option that uses UF ccn irenuc = 7 diff --git a/physics/MP/NSSL/mp_nssl.F90 b/physics/MP/NSSL/mp_nssl.F90 index db2edfb86..74e6c780f 100644 --- a/physics/MP/NSSL/mp_nssl.F90 +++ b/physics/MP/NSSL/mp_nssl.F90 @@ -28,8 +28,8 @@ module mp_nssl !! \htmlinclude mp_nssl_init.html !! subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & - mpirank, mpiroot,mpicomm, & - qc, qr, qi, qs, qh, & + fn_nml, input_nml_file, mpirank, mpiroot, & + mpicomm, qc, qr, qi, qs, qh, & ccw, crw, cci, csw, chw, vh, & con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps, & @@ -52,6 +52,8 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & integer, intent( out) :: errflg integer, intent(in) :: threads logical, intent(in) :: restart + character(len=*), intent(in) :: fn_nml + character(len=*), intent(in) :: input_nml_file(:) real(kind_phys), intent(in) :: con_g, con_rd, con_cp, con_rv, & con_t0c, con_cliq, con_csol, con_eps @@ -156,7 +158,9 @@ subroutine mp_nssl_init(ncol, nlev, errflg, errmsg, threads, restart, & ! write(0,*) 'call nssl_2mom_init' CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=ipc,mixphase=0, & - ihvol=ihailv,nssl_ehw0=nssl_ehw0,nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, & + namelist_filename=fn_nml,internal_nml=input_nml_file, & + ihvol=ihailv,nssl_ehw0=nssl_ehw0, & + nssl_ehlw0=nssl_ehlw0,errmsg=errmsg, & nssl_alphar=nssl_alphar, & nssl_alphah=nssl_alphah, & nssl_alphahl=nssl_alphahl, & diff --git a/physics/MP/NSSL/mp_nssl.meta b/physics/MP/NSSL/mp_nssl.meta index e818e8fe5..93a5aa65b 100644 --- a/physics/MP/NSSL/mp_nssl.meta +++ b/physics/MP/NSSL/mp_nssl.meta @@ -49,6 +49,22 @@ dimensions = () type = logical intent = in +[fn_nml] + standard_name = filename_of_namelist + long_name = namelist filename + units = none + dimensions = () + type = character + kind = len=* + intent = in +[input_nml_file] + standard_name = filename_of_internal_namelist + long_name = character string to store full namelist contents + units = none + dimensions = (number_of_lines_in_internal_namelist) + type = character + kind = len=* + intent = in [mpirank] standard_name = mpi_rank long_name = current MPI-rank diff --git a/physics/MP/TEMPO/TEMPO b/physics/MP/TEMPO/TEMPO new file mode 160000 index 000000000..c62efd27c --- /dev/null +++ b/physics/MP/TEMPO/TEMPO @@ -0,0 +1 @@ +Subproject commit c62efd27caa26f660edf24232f33f154e608b77a diff --git a/physics/MP/TEMPO/module_mp_tempo.F90 b/physics/MP/TEMPO/module_mp_tempo.F90 new file mode 100644 index 000000000..89c62f7ec --- /dev/null +++ b/physics/MP/TEMPO/module_mp_tempo.F90 @@ -0,0 +1,1506 @@ +! 3D TEMPO Driver for CCPP +!================================================================================================================= +module module_mp_tempo + + use machine, only: wp => kind_phys, sp => kind_sngl_prec, dp => kind_dbl_prec + use module_mp_tempo_params + use module_mp_tempo_utils, only : create_bins, table_Efrw, table_Efsw, table_dropEvap, & + table_ccnAct, qi_aut_qs, qr_acr_qg_par, qr_acr_qs_par, freezeH2O_par, calc_refl10cm, calc_effectRad + use module_mp_tempo_main, only : mp_tempo_main + use module_mp_radar + + implicit none + +contains + !================================================================================================================= + ! This subroutine handles initialzation of the microphysics scheme including building of lookup tables, + ! allocating arrays for the microphysics scheme, and defining gamma function variables. + subroutine tempo_init(is_aerosol_aware_in, merra2_aerosol_aware_in, is_hail_aware_in, & + mpicomm, mpirank, mpiroot, threads, errmsg, errflg) + + logical, intent(in) :: is_aerosol_aware_in + logical, intent(in) :: merra2_aerosol_aware_in + logical, intent(in), optional :: is_hail_aware_in + type(MPI_Comm), intent(in) :: mpicomm + integer, intent(in) :: mpirank, mpiroot + integer, intent(in) :: threads + character(len=*), intent(inout) :: errmsg + integer, intent(inout) :: errflg + + integer :: i, j, k, l, m, n + logical :: micro_init + real(wp) :: stime, etime + logical, parameter :: precomputed_tables = .false. + + ! Initialize physical constants + call mp_tempo_params_init() + + ! Set module variable is_aerosol_aware/merra2_aerosol_aware + configs%aerosol_aware = is_aerosol_aware_in + merra2_aerosol_aware = merra2_aerosol_aware_in + if (present(is_hail_aware_in)) then + configs%hail_aware = is_hail_aware_in + else + configs%hail_aware = .false. + endif + if (configs%aerosol_aware .and. merra2_aerosol_aware) then + errmsg = 'Logic error in tempo_init: only one of the two options can be true, ' // & + 'not both: is_aerosol_aware or merra2_aerosol_aware' + errflg = 1 + return + end if + if (mpirank==mpiroot) then + if (configs%aerosol_aware) then + write (*,'(a)') 'Using aerosol-aware version of TEMPO microphysics' + else if(merra2_aerosol_aware) then + write (*,'(a)') 'Using merra2 aerosol-aware version of TEMPO microphysics' + else + write (*,'(a)') 'Using non-aerosol-aware version of TEMPO microphysics' + end if + end if + + micro_init = .false. + + if (configs%hail_aware) then + dimNRHG = NRHG + else + av_g(idx_bg1) = av_g_old + bv_g(idx_bg1) = bv_g_old + dimNRHG = NRHG1 + endif + + if (mpirank==mpiroot) then + write (*,*) 'Hail-aware option is: ', configs%hail_aware + write (*,*) 'Hail-aware option dimNRHG is: ', dimNRHG + endif + + ! Allocate space for lookup tables (J. Michalakes 2009Jun08). + if (.not. allocated(tcg_racg)) then + allocate(tcg_racg(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + micro_init = .true. + endif + + ! Rain-graupel (including array above tcg_racg) + if (.not. allocated(tmr_racg)) allocate(tmr_racg(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + if (.not. allocated(tcr_gacr)) allocate(tcr_gacr(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + if (.not. allocated(tnr_racg)) allocate(tnr_racg(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + if (.not. allocated(tnr_gacr)) allocate(tnr_gacr(ntb_g1,ntb_g,dimNRHG,ntb_r1,ntb_r)) + + ! Rain-snow + if (.not. allocated(tcs_racs1)) allocate(tcs_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tmr_racs1)) allocate(tmr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tcs_racs2)) allocate(tcs_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tmr_racs2)) allocate(tmr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tcr_sacr1)) allocate(tcr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tms_sacr1)) allocate(tms_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tcr_sacr2)) allocate(tcr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tms_sacr2)) allocate(tms_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tnr_racs1)) allocate(tnr_racs1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tnr_racs2)) allocate(tnr_racs2(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tnr_sacr1)) allocate(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r)) + if (.not. allocated(tnr_sacr2)) allocate(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r)) + + ! Cloud water freezing + if (.not. allocated(tpi_qcfz)) allocate(tpi_qcfz(ntb_c,nbc,ntb_t1,ntb_IN)) + if (.not. allocated(tni_qcfz)) allocate(tni_qcfz(ntb_c,nbc,ntb_t1,ntb_IN)) + + ! Rain freezing + if (.not. allocated(tpi_qrfz)) allocate(tpi_qrfz(ntb_r,ntb_r1,ntb_t1,ntb_IN)) + if (.not. allocated(tpg_qrfz)) allocate(tpg_qrfz(ntb_r,ntb_r1,ntb_t1,ntb_IN)) + if (.not. allocated(tni_qrfz)) allocate(tni_qrfz(ntb_r,ntb_r1,ntb_t1,ntb_IN)) + if (.not. allocated(tnr_qrfz)) allocate(tnr_qrfz(ntb_r,ntb_r1,ntb_t1,ntb_IN)) + + ! Ice growth and conversion to snow + if (.not. allocated(tps_iaus)) allocate(tps_iaus(ntb_i,ntb_i1)) + if (.not. allocated(tni_iaus)) allocate(tni_iaus(ntb_i,ntb_i1)) + if (.not. allocated(tpi_ide)) allocate(tpi_ide(ntb_i,ntb_i1)) + + ! Collision efficiencies + if (.not. allocated(t_efrw)) allocate(t_efrw(nbr,nbc)) + if (.not. allocated(t_efsw)) allocate(t_efsw(nbs,nbc)) + + ! Cloud water + if (.not. allocated(tnr_rev)) allocate(tnr_rev(nbr,ntb_r1,ntb_r)) + if (.not. allocated(tpc_wev)) allocate(tpc_wev(nbc,ntb_c,nbc)) + if (.not. allocated(tnc_wev)) allocate(tnc_wev(nbc,ntb_c,nbc)) + + ! CCN + if (.not. allocated(tnccn_act)) allocate(tnccn_act(ntb_arc,ntb_arw,ntb_art,ntb_arr,ntb_ark)) + + !================================================================================================================= + if_micro_init: if (micro_init) then + + !> - From Martin et al. (1994), assign gamma shape parameter mu for cloud + !! drops according to general dispersion characteristics (disp=~0.25 + !! for maritime and 0.45 for continental) + !.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime + !.. to 2 for really dirty air. This not used in 2-moment cloud water + !.. scheme and nu_c used instead and varies from 2 to 15 (integer-only). + mu_c_l = min(15.0_wp, (1000.e6_wp/Nt_c_l + 2.)) + mu_c_o = min(15.0_wp, (1000.e6_wp/Nt_c_o + 2.)) + + !> - Compute Schmidt number to one-third used numerous times + Sc3 = Sc**(1./3.) + + !> - Compute minimum ice diam from mass, min snow/graupel mass from diam + D0i = (xm0i/am_i)**(1./bm_i) + xm0s = am_s * D0s**bm_s + xm0g = am_g(NRHG) * D0g**bm_g + + !> - Compute constants various exponents and gamma() associated with cloud, + !! rain, snow, and graupel + do n = 1, 15 + cce(1,n) = n + 1. + cce(2,n) = bm_r + n + 1. + cce(3,n) = bm_r + n + 4. + cce(4,n) = n + bv_c + 1. + cce(5,n) = bm_r + n + bv_c + 1. + ccg(1,n) = gamma(cce(1,n)) + ccg(2,n) = gamma(cce(2,n)) + ccg(3,n) = gamma(cce(3,n)) + ccg(4,n) = gamma(cce(4,n)) + ccg(5,n) = gamma(cce(5,n)) + ocg1(n) = 1.0 / ccg(1,n) + ocg2(n) = 1.0 / ccg(2,n) + enddo + + cie(1) = mu_i + 1. + cie(2) = bm_i + mu_i + 1. + cie(3) = bm_i + mu_i + bv_i + 1. + cie(4) = mu_i + bv_i + 1. + cie(5) = mu_i + 2. + cie(6) = bm_i*0.5 + mu_i + bv_i + 1. + cie(7) = bm_i*0.5 + mu_i + 1. + cig(1) = gamma(cie(1)) + cig(2) = gamma(cie(2)) + cig(3) = gamma(cie(3)) + cig(4) = gamma(cie(4)) + cig(5) = gamma(cie(5)) + cig(6) = gamma(cie(6)) + cig(7) = gamma(cie(7)) + oig1 = 1.0 / cig(1) + oig2 = 1.0 / cig(2) + obmi = 1.0 / bm_i + + cre(1) = bm_r + 1. + cre(2) = mu_r + 1. + cre(3) = bm_r + mu_r + 1. + cre(4) = bm_r*2. + mu_r + 1. + cre(5) = mu_r + bv_r + 1. + cre(6) = bm_r + mu_r + bv_r + 1. + cre(7) = bm_r*0.5 + mu_r + bv_r + 1. + cre(8) = bm_r + mu_r + bv_r + 3. + cre(9) = mu_r + bv_r + 3. + cre(10) = mu_r + 2. + cre(11) = 0.5*(bv_r + 5. + 2.*mu_r) + cre(12) = bm_r*0.5 + mu_r + 1. + cre(13) = bm_r*2. + mu_r + bv_r + 1. + + do n = 1, 13 + crg(n) = gamma(cre(n)) + enddo + + obmr = 1.0 / bm_r + ore1 = 1.0 / cre(1) + org1 = 1.0 / crg(1) + org2 = 1.0 / crg(2) + org3 = 1.0 / crg(3) + + cse(1) = bm_s + 1. + cse(2) = bm_s + 2. + cse(3) = bm_s*2. + cse(4) = bm_s + bv_s + 1. + cse(5) = bm_s*2. + bv_s + 1. + cse(6) = bm_s*2. + 1. + cse(7) = bm_s + mu_s + 1. + cse(8) = bm_s + mu_s + 2. + cse(9) = bm_s + mu_s + 3. + cse(10) = bm_s + mu_s + bv_s + 1. + cse(11) = bm_s*2. + mu_s + bv_s + 1. + cse(12) = bm_s*2. + mu_s + 1. + cse(13) = bv_s + 2. + cse(14) = bm_s + bv_s + cse(15) = mu_s + 1. + cse(16) = 1.0 + (1.0 + bv_s)/2. + + if (original_thompson) then + cse(17) = cse(16) + mu_s + 1. + cse(18) = bv_s + mu_s + 3. + do n = 1, 18 + csg(n) = gamma(cse(n)) + enddo + else + cse(17) = bm_s + bv_s + 2. + do n = 1, 17 + csg(n) = gamma(cse(n)) + enddo + endif + + oams = 1.0 / am_s + obms = 1.0 / bm_s + ocms = oams**obms + + cge(1,:) = bm_g + 1. + cge(2,:) = mu_g + 1. + cge(3,:) = bm_g + mu_g + 1. + cge(4,:) = bm_g*2. + mu_g + 1. + cge(10,:) = mu_g + 2. + cge(12,:) = bm_g*0.5 + mu_g + 1. + + do m = 1, NRHG + cge(5,m) = bm_g*2. + mu_g + bv_g(m) + 1. + cge(6,m) = bm_g + mu_g + bv_g(m) + 1. + cge(7,m) = bm_g*0.5 + mu_g + bv_g(m) + 1. + cge(8,m) = mu_g + bv_g(m) + 1. ! not used + cge(9,m) = mu_g + bv_g(m) + 3. + cge(11,m) = 0.5*(bv_g(m) + 5. + 2.*mu_g) + enddo + + do m = 1, NRHG + do n = 1, 12 + cgg(n,m) = gamma(cge(n,m)) + enddo + enddo + + oamg = 1.0 / am_g + obmg = 1.0 / bm_g + + do m = 1, NRHG + oamg(m) = 1.0 / am_g(m) + ocmg(m) = oamg(m)**obmg + enddo + + oge1 = 1.0 / cge(1,1) + ogg1 = 1.0 / cgg(1,1) + ogg2 = 1.0 / cgg(2,1) + ogg3 = 1.0 / cgg(3,1) + + !================================================================================================================= + ! Simplify various rate eqns the best we can now. + + ! Rain collecting cloud water and cloud ice + t1_qr_qc = PI * 0.25 * av_r * crg(9) + t1_qr_qi = PI * 0.25 * av_r * crg(9) + t2_qr_qi = PI * 0.25 * am_r*av_r * crg(8) + + ! Graupel collecting cloud water + ! t1_qg_qc = PI*.25*av_g * cgg(9) + + ! Snow collecting cloud water + t1_qs_qc = PI * 0.25 * av_s + + ! Snow collecting cloud ice + t1_qs_qi = PI * 0.25 * av_s + + ! Evaporation of rain; ignore depositional growth of rain. + t1_qr_ev = 0.78 * crg(10) + t2_qr_ev = 0.308 * Sc3 * SQRT(av_r) * crg(11) + + ! Sublimation/depositional growth of snow + t1_qs_sd = 0.86 + t2_qs_sd = 0.28 * Sc3 * SQRT(av_s) + + ! Melting of snow + t1_qs_me = PI * 4. *C_sqrd * olfus * 0.86 + t2_qs_me = PI * 4. *C_sqrd * olfus * 0.28 * Sc3 * SQRT(av_s) + + ! Sublimation/depositional growth of graupel + t1_qg_sd = 0.86 * cgg(10,1) + ! t2_qg_sd = 0.28*Sc3*SQRT(av_g) * cgg(11) + + ! Melting of graupel + t1_qg_me = PI * 4. * C_cube * olfus * 0.86 * cgg(10,1) + ! t2_qg_me = PI*4.*C_cube*olfus * 0.28*Sc3*SQRT(av_g) * cgg(11) + + + ! Constants for helping find lookup table indexes. + nic2 = nint(log10(r_c(1))) + nii2 = nint(log10(r_i(1))) + nii3 = nint(log10(Nt_i(1))) + nir2 = nint(log10(r_r(1))) + nir3 = nint(log10(N0r_exp(1))) + nis2 = nint(log10(r_s(1))) + nig2 = nint(log10(r_g(1))) + nig3 = nint(log10(N0g_exp(1))) + niIN2 = nint(log10(Nt_IN(1))) + + ! Create bins of cloud water (from minimum diameter to 100 microns). + Dc(1) = D0c*1.0_dp + dtc(1) = D0c*1.0_dp + do n = 2, nbc + Dc(n) = Dc(n-1) + 1.0e-6_dp + dtc(n) = (Dc(n) - Dc(n-1)) + enddo + + ! Create bins of cloud ice (from min diameter up to 2x min snow size). + call create_bins(numbins=nbi, lowbin=D0i*1.0_dp, highbin=D0s*2.0_dp, & + bins=Di, deltabins=dti) + + ! Create bins of rain (from min diameter up to 5 mm). + call create_bins(numbins=nbr, lowbin=D0r*1.0_dp, highbin=0.005_dp, & + bins=Dr, deltabins=dtr) + + ! Create bins of snow (from min diameter up to 2 cm). + call create_bins(numbins=nbs, lowbin=D0s*1.0_dp, highbin=0.02_dp, & + bins=Ds, deltabins=dts) + + ! Create bins of graupel (from min diameter up to 5 cm). + call create_bins(numbins=nbg, lowbin=D0g*1.0_dp, highbin=0.05_dp, & + bins=Dg, deltabins=dtg) + + ! Create bins of cloud droplet number concentration (1 to 3000 per cc). + call create_bins(numbins=nbc, lowbin=1.0_dp, highbin=3000.0_dp, & + bins=t_Nc) + t_Nc = t_Nc * 1.0e6_dp + nic1 = log(t_Nc(nbc)/t_Nc(1)) + + !================================================================================================================= + ! Create lookup tables for most costly calculations + + ! Assign mpicomm to module variable + mpi_communicator = mpicomm + + ! Standard tables are only written by master MPI task; + ! (physics init cannot be called by multiple threads, + ! hence no need to test for a specific thread number) + if (mpirank==mpiroot) then + thompson_table_writer = .true. + else + thompson_table_writer = .false. + end if + + precomputed_tables_1: if (.not.precomputed_tables) then + + call cpu_time(stime) + + do m = 1, ntb_r + do k = 1, ntb_r1 + do n = 1, dimNRHG + do j = 1, ntb_g + do i = 1, ntb_g1 + tcg_racg(i,j,n,k,m) = 0.0_dp + tmr_racg(i,j,n,k,m) = 0.0_dp + tcr_gacr(i,j,n,k,m) = 0.0_dp + tnr_racg(i,j,n,k,m) = 0.0_dp + tnr_gacr(i,j,n,k,m) = 0.0_dp + enddo + enddo + enddo + enddo + enddo + + do m = 1, ntb_r + do k = 1, ntb_r1 + do j = 1, ntb_t + do i = 1, ntb_s + tcs_racs1(i,j,k,m) = 0.0_dp + tmr_racs1(i,j,k,m) = 0.0_dp + tcs_racs2(i,j,k,m) = 0.0_dp + tmr_racs2(i,j,k,m) = 0.0_dp + tcr_sacr1(i,j,k,m) = 0.0_dp + tms_sacr1(i,j,k,m) = 0.0_dp + tcr_sacr2(i,j,k,m) = 0.0_dp + tms_sacr2(i,j,k,m) = 0.0_dp + tnr_racs1(i,j,k,m) = 0.0_dp + tnr_racs2(i,j,k,m) = 0.0_dp + tnr_sacr1(i,j,k,m) = 0.0_dp + tnr_sacr2(i,j,k,m) = 0.0_dp + enddo + enddo + enddo + enddo + + do m = 1, ntb_IN + do k = 1, ntb_t1 + do j = 1, ntb_r1 + do i = 1, ntb_r + tpi_qrfz(i,j,k,m) = 0.0_dp + tni_qrfz(i,j,k,m) = 0.0_dp + tpg_qrfz(i,j,k,m) = 0.0_dp + tnr_qrfz(i,j,k,m) = 0.0_dp + enddo + enddo + do j = 1, nbc + do i = 1, ntb_c + tpi_qcfz(i,j,k,m) = 0.0_dp + tni_qcfz(i,j,k,m) = 0.0_dp + enddo + enddo + enddo + enddo + + do j = 1, ntb_i1 + do i = 1, ntb_i + tps_iaus(i,j) = 0.0_dp + tni_iaus(i,j) = 0.0_dp + tpi_ide(i,j) = 0.0_dp + enddo + enddo + + do j = 1, nbc + do i = 1, nbr + t_Efrw(i,j) = 0.0 + enddo + do i = 1, nbs + t_Efsw(i,j) = 0.0 + enddo + enddo + + do k = 1, ntb_r + do j = 1, ntb_r1 + do i = 1, nbr + tnr_rev(i,j,k) = 0.0_dp + enddo + enddo + enddo + + do k = 1, nbc + do j = 1, ntb_c + do i = 1, nbc + tpc_wev(i,j,k) = 0.0_dp + tnc_wev(i,j,k) = 0.0_dp + enddo + enddo + enddo + + do m = 1, ntb_ark + do l = 1, ntb_arr + do k = 1, ntb_art + do j = 1, ntb_arw + do i = 1, ntb_arc + tnccn_act(i,j,k,l,m) = 1.0 + enddo + enddo + enddo + enddo + enddo + + if (mpirank==mpiroot) write (*,*)'creating microphysics lookup tables ... ' + if (mpirank==mpiroot) write (*,'(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') & + ' using: mu_c_o=',mu_c_o,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g + + !> - Call table_ccnact() to read a static file containing CCN activation of aerosols. The + !! data were created from a parcel model by Feingold & Heymsfield with + !! further changes by Eidhammer and Kriedenweis + if (mpirank==mpiroot) write(*,*) ' calling table_ccnAct routine' + call table_ccnAct(errmsg, errflg) + if (.not. errflg==0) return + + !> - Call table_efrw() and table_efsw() to creat collision efficiency table + !! between rain/snow and cloud water + if (mpirank==mpiroot) write(*,*) ' creating qc collision eff tables' + call table_Efrw + call table_Efsw + + !> - Call table_dropevap() to creat rain drop evaporation table + if (mpirank==mpiroot) write(*,*) ' creating rain evap table' + call table_dropEvap + + !> - Call qi_aut_qs() to create conversion of some ice mass into snow category + if (mpirank==mpiroot) write(*,*) ' creating ice converting to snow table' + call qi_aut_qs + + call cpu_time(etime) + if (mpirank==mpiroot) print '("Calculating TEMPO tables part 1 took ",f10.3," seconds.")', etime-stime + + end if precomputed_tables_1 + + !> - Call radar_init() to initialize various constants for computing radar reflectivity + call cpu_time(stime) + xam_r = am_r + xbm_r = bm_r + xmu_r = mu_r + xam_s = am_s + xbm_s = bm_s + xmu_s = mu_s + xam_g = am_g(idx_bg1) + xbm_g = bm_g + xmu_g = mu_g + call radar_init + call cpu_time(etime) + if (mpirank==mpiroot) print '("Calling radar_init took ",f10.3," seconds.")', etime-stime + + if_not_iiwarm: if (.not. iiwarm) then + + precomputed_tables_2: if (.not.precomputed_tables) then + + call cpu_time(stime) + + !> - Call qr_acr_qg() to create rain collecting graupel & graupel collecting rain table + if (mpirank==mpiroot) write(*,*) ' creating rain collecting graupel table' + call cpu_time(stime) + if (dimNRHG == NRHG) then + call qr_acr_qg_par(dimNRHG, qr_acr_qg_hailaware_file) + using_hail_aware_table = .true. + else + call qr_acr_qg_par(dimNRHG, qr_acr_qg_file) + endif + call cpu_time(etime) + if (mpirank==mpiroot) print '("Computing rain collecting graupel table took ",f10.3," seconds.")', etime-stime + + !> - Call qr_acr_qs() to create rain collecting snow & snow collecting rain table + if (mpirank==mpiroot) write (*,*) ' creating rain collecting snow table' + call cpu_time(stime) + call qr_acr_qs_par + call cpu_time(etime) + if (mpirank==mpiroot) print '("Computing rain collecting snow table took ",f10.3," seconds.")', etime-stime + + !> - Call freezeh2o() to create cloud water and rain freezing (Bigg, 1953) table + if (mpirank==mpiroot) write(*,*) ' creating freezing of water drops table' + call cpu_time(stime) + call freezeH2O_par(threads) + call cpu_time(etime) + if (mpirank==mpiroot) print '("Computing freezing of water drops table took ",f10.3," seconds.")', etime-stime + + call cpu_time(etime) + if (mpirank==mpiroot) print '("Calculating TEMPO tables part 2 took ",f10.3," seconds.")', etime-stime + + end if precomputed_tables_2 + + endif if_not_iiwarm + + if (mpirank==mpiroot) write(*,*) ' ... DONE microphysical lookup tables' + + endif if_micro_init + + end subroutine tempo_init + + !================================================================================================================= + ! This is a wrapper routine designed to transfer values from 3D to 1D. + ! Required microphysics variables are qv, qc, qr, nr, qi, ni, qs, qg + ! Optional microphysics variables are aerosol aware (nc, nwfa, nifa, nwfa2d, nifa2d), and hail aware (ng, qg) + + subroutine tempo_3d_to_1d_driver(qv, qc, qr, qi, qs, qg, qb, ni, nr, nc, ng, & + nwfa, nifa, nwfa2d, nifa2d, & + tt, th, pii, & + p, w, dz, dt_in, dt_inner, & + sedi_semi, decfl, lsm, & + RAINNC, RAINNCV, & + SNOWNC, SNOWNCV, & + ICENC, ICENCV, & + GRAUPELNC, GRAUPELNCV, SR, & + refl_10cm, diagflag, do_radar_ref, & + max_hail_diam_sfc, & + vt_dbz_wt, first_time_step, & + re_cloud, re_ice, re_snow, & + has_reqc, has_reqi, has_reqs, & + aero_ind_fdb, rand_perturb_on, & + kme_stoch, & + rand_pert, spp_prt_list, spp_var_list, & + spp_stddev_cutoff, n_var_spp, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its,ite, jts,jte, kts,kte, & ! tile dims + fullradar_diag, istep, nsteps, & + errmsg, errflg, & + ! Extended diagnostics, array pointers + ! only associated if ext_diag flag is .true. + ext_diag, & + !vts1, txri, txrc, & + prw_vcdc, & + prw_vcde, tpri_inu, tpri_ide_d, & + tpri_ide_s, tprs_ide, tprs_sde_d, & + tprs_sde_s, tprg_gde_d, & + tprg_gde_s, tpri_iha, tpri_wfz, & + tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & + tprg_rcs, tprs_rcs, & + tprr_rci, tprg_rcg, & + tprw_vcd_c, tprw_vcd_e, tprr_sml, & + tprr_gml, tprr_rcg, & + tprr_rcs, tprv_rev, tten3, qvten3, & + qrten3, qsten3, qgten3, qiten3, niten3, & + nrten3, ncten3, qcten3, & + pfils, pflls) + + !..Subroutine arguments + integer, intent(in):: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + qv, qc, qr, qi, qs, qg, ni, nr + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + tt, th + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(in):: & + pii + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + nc, nwfa, nifa, qb, ng + real(wp), dimension(ims:ime, jms:jme), optional, intent(in):: nwfa2d, nifa2d + integer, dimension(ims:ime, jms:jme), intent(in):: lsm + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + re_cloud, re_ice, re_snow + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: pfils, pflls + integer, intent(in) :: rand_perturb_on, kme_stoch, n_var_spp + real(wp), dimension(:,:), optional, intent(in) :: rand_pert + real(wp), dimension(:), optional, intent(in) :: spp_prt_list + real(wp), dimension(:), intent(in), optional :: spp_stddev_cutoff + character(len=10), optional, dimension(:), intent(in) :: spp_var_list + integer, intent(in):: has_reqc, has_reqi, has_reqs + + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(in):: & + p, w, dz + real(wp), dimension(ims:ime, jms:jme), intent(inout):: & + RAINNC, RAINNCV, SR + real(wp), dimension(ims:ime, jms:jme), optional, intent(inout):: & + SNOWNC, SNOWNCV, & + ICENC, ICENCV, & + GRAUPELNC, GRAUPELNCV + real(wp), dimension(ims:ime, kms:kme, jms:jme), intent(inout):: & + refl_10cm + real(wp), dimension(ims:ime, jms:jme), intent(inout):: & + max_hail_diam_sfc + real(wp), dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + vt_dbz_wt + logical, intent(in) :: first_time_step + real(wp), intent(in):: dt_in, dt_inner + logical, intent(in) :: sedi_semi + integer, intent(in) :: decfl + ! To support subcycling: current step and maximum number of steps + integer, intent (in) :: istep, nsteps + logical, intent (in) :: fullradar_diag + ! Extended diagnostics, array pointers only associated if ext_diag flag is .true. + logical, intent (in) :: ext_diag + logical, optional, intent(in):: aero_ind_fdb + real(wp), optional, dimension(:,:,:), intent(inout):: & + !vts1, txri, txrc, & + prw_vcdc, & + prw_vcde, tpri_inu, tpri_ide_d, & + tpri_ide_s, tprs_ide, & + tprs_sde_d, tprs_sde_s, tprg_gde_d, & + tprg_gde_s, tpri_iha, tpri_wfz, & + tpri_rfz, tprg_rfz, tprs_scw, tprg_scw, & + tprg_rcs, tprs_rcs, & + tprr_rci, tprg_rcg, & + tprw_vcd_c, tprw_vcd_e, tprr_sml, & + tprr_gml, tprr_rcg, & + tprr_rcs, tprv_rev, tten3, qvten3, & + qrten3, qsten3, qgten3, qiten3, niten3, & + nrten3, ncten3, qcten3 + + !..Local variables + real(wp), dimension(kts:kte):: & + qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, qb1d, & + ni1d, nr1d, nc1d, ng1d, nwfa1d, nifa1d, & + t1d, p1d, w1d, dz1d, rho, dBZ, pfil1, pfll1 + !..Extended diagnostics, single column arrays + real(wp), dimension(:), allocatable:: & + !vtsk1, txri1, txrc1, & + prw_vcdc1, & + prw_vcde1, tpri_inu1, tpri_ide1_d, & + tpri_ide1_s, tprs_ide1, & + tprs_sde1_d, tprs_sde1_s, tprg_gde1_d, & + tprg_gde1_s, tpri_iha1, tpri_wfz1, & + tpri_rfz1, tprg_rfz1, tprs_scw1, tprg_scw1,& + tprg_rcs1, tprs_rcs1, & + tprr_rci1, tprg_rcg1, & + tprw_vcd1_c, tprw_vcd1_e, tprr_sml1, & + tprr_gml1, tprr_rcg1, & + tprr_rcs1, tprv_rev1, tten1, qvten1, & + qrten1, qsten1, qgten1, qiten1, niten1, & + nrten1, ncten1, qcten1 + + real(wp), dimension(kts:kte):: re_qc1d, re_qi1d, re_qs1d + + real(wp), dimension(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic + real(wp) :: dt, pptrain, pptsnow, pptgraul, pptice + real(wp) :: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max + real(wp) :: ygra1, zans1 + real(dp) :: lamg, lam_exp, lamr, N0_min, N0_exp + integer:: lsml + real(wp) :: rand1, rand2, rand3, rand_pert_max + integer:: i, j, k, m + integer:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr + integer:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr + integer:: kmax_qc,kmax_qr,kmax_qi,kmax_qs,kmax_qg,kmax_ni,kmax_nr + integer:: i_start, j_start, i_end, j_end + logical, optional, intent(in) :: diagflag + integer, optional, intent(in) :: do_radar_ref + logical :: melti = .false. + integer :: ndt, it + + ! CCPP error handling + character(len=*), optional, intent( out) :: errmsg + integer, optional, intent( out) :: errflg + + ! CCPP + if (present(errmsg)) errmsg = '' + if (present(errflg)) errflg = 0 + + ! No need to test for every subcycling step + test_only_once: if (first_time_step .and. istep==1) then + ! Activate this code when removing the guard above + + if ( (present(tt) .and. (present(th) .or. present(pii))) .or. & + (.not.present(tt) .and. .not.(present(th) .and. present(pii))) ) then + if (present(errmsg) .and. present(errflg)) then + write(errmsg, '(a)') 'Logic error in tempo_3d_to_1d_driver: provide either tt or th+pii' + errflg = 1 + return + else + write(*,'(a)') 'Logic error in tempo_3d_to_1d_driver: provide either tt or th+pii' + stop + end if + end if + + if (configs%aerosol_aware .and. (.not.present(nc) .or. & + .not.present(nwfa) .or. & + .not.present(nifa) .or. & + .not.present(nwfa2d) .or. & + .not.present(nifa2d) )) then + if (present(errmsg) .and. present(errflg)) then + write(errmsg, '(*(a))') 'Logic error in tempo_3d_to_1d_driver: provide nc, nwfa, nifa, nwfa2d', & + ' and nifa2d for aerosol-aware version of TEMPO microphysics' + errflg = 1 + return + else + write(*, '(*(a))') 'Logic error in tempo_3d_to_1d_driver: provide nc, nwfa, nifa, nwfa2d', & + ' and nifa2d for aerosol-aware version of TEMPO microphysics' + stop + end if + else if (merra2_aerosol_aware .and. (.not.present(nc) .or. & + .not.present(nwfa) .or. & + .not.present(nifa) )) then + if (present(errmsg) .and. present(errflg)) then + write(errmsg, '(*(a))') 'Logic error in tempo_3d_to_1d_driver: provide nc, nwfa, and nifa', & + ' for merra2 aerosol-aware version of TEMPO microphysics' + errflg = 1 + return + else + write(*, '(*(a))') 'Logic error in tempo_3d_to_1d_driver: provide nc, nwfa, and nifa', & + ' for merra2 aerosol-aware version of TEMPO microphysics' + stop + end if + else if (.not.configs%aerosol_aware .and. .not.merra2_aerosol_aware .and. & + (present(nwfa) .or. present(nifa) .or. present(nwfa2d) .or. present(nifa2d))) then + write(*,*) 'WARNING, nc/nwfa/nifa/nwfa2d/nifa2d present but is_aerosol_aware/merra2_aerosol_aware are FALSE' + end if + end if test_only_once + + ! These must be alwyas allocated + !allocate (vtsk1(kts:kte)) + !allocate (txri1(kts:kte)) + !allocate (txrc1(kts:kte)) + allocate_extended_diagnostics: if (ext_diag) then + allocate (prw_vcdc1(kts:kte)) + allocate (prw_vcde1(kts:kte)) + allocate (tpri_inu1(kts:kte)) + allocate (tpri_ide1_d(kts:kte)) + allocate (tpri_ide1_s(kts:kte)) + allocate (tprs_ide1(kts:kte)) + allocate (tprs_sde1_d(kts:kte)) + allocate (tprs_sde1_s(kts:kte)) + allocate (tprg_gde1_d(kts:kte)) + allocate (tprg_gde1_s(kts:kte)) + allocate (tpri_iha1(kts:kte)) + allocate (tpri_wfz1(kts:kte)) + allocate (tpri_rfz1(kts:kte)) + allocate (tprg_rfz1(kts:kte)) + allocate (tprs_scw1(kts:kte)) + allocate (tprg_scw1(kts:kte)) + allocate (tprg_rcs1(kts:kte)) + allocate (tprs_rcs1(kts:kte)) + allocate (tprr_rci1(kts:kte)) + allocate (tprg_rcg1(kts:kte)) + allocate (tprw_vcd1_c(kts:kte)) + allocate (tprw_vcd1_e(kts:kte)) + allocate (tprr_sml1(kts:kte)) + allocate (tprr_gml1(kts:kte)) + allocate (tprr_rcg1(kts:kte)) + allocate (tprr_rcs1(kts:kte)) + allocate (tprv_rev1(kts:kte)) + allocate (tten1(kts:kte)) + allocate (qvten1(kts:kte)) + allocate (qrten1(kts:kte)) + allocate (qsten1(kts:kte)) + allocate (qgten1(kts:kte)) + allocate (qiten1(kts:kte)) + allocate (niten1(kts:kte)) + allocate (nrten1(kts:kte)) + allocate (ncten1(kts:kte)) + allocate (qcten1(kts:kte)) + else + allocate (prw_vcdc1 (0)) + allocate (prw_vcde1 (0)) + allocate (tpri_inu1 (0)) + allocate (tpri_ide1_d(0)) + allocate (tpri_ide1_s(0)) + allocate (tprs_ide1 (0)) + allocate (tprs_sde1_d(0)) + allocate (tprs_sde1_s(0)) + allocate (tprg_gde1_d(0)) + allocate (tprg_gde1_s(0)) + allocate (tpri_iha1 (0)) + allocate (tpri_wfz1 (0)) + allocate (tpri_rfz1 (0)) + allocate (tprg_rfz1 (0)) + allocate (tprs_scw1 (0)) + allocate (tprg_scw1 (0)) + allocate (tprg_rcs1 (0)) + allocate (tprs_rcs1 (0)) + allocate (tprr_rci1 (0)) + allocate (tprg_rcg1 (0)) + allocate (tprw_vcd1_c(0)) + allocate (tprw_vcd1_e(0)) + allocate (tprr_sml1 (0)) + allocate (tprr_gml1 (0)) + allocate (tprr_rcg1 (0)) + allocate (tprr_rcs1 (0)) + allocate (tprv_rev1 (0)) + allocate (tten1 (0)) + allocate (qvten1 (0)) + allocate (qrten1 (0)) + allocate (qsten1 (0)) + allocate (qgten1 (0)) + allocate (qiten1 (0)) + allocate (niten1 (0)) + allocate (nrten1 (0)) + allocate (ncten1 (0)) + allocate (qcten1 (0)) + end if allocate_extended_diagnostics + + !+---+ + i_start = its + j_start = jts + i_end = ite + j_end = jte + + !..For idealized testing by developer. + ! if ( (ide-ids+1).gt.4 .and. (jde-jds+1).lt.4 .and. & + ! ids.eq.its.and.ide.eq.ite.and.jds.eq.jts.and.jde.eq.jte) then + ! i_start = its + 2 + ! i_end = ite + ! j_start = jts + ! j_end = jte + ! endif + + ! dt = dt_in + RAINNC(:,:) = 0.0 + SNOWNC(:,:) = 0.0 + ICENC(:,:) = 0.0 + GRAUPELNC(:,:) = 0.0 + pcp_ra(:,:) = 0.0 + pcp_sn(:,:) = 0.0 + pcp_gr(:,:) = 0.0 + pcp_ic(:,:) = 0.0 + pfils(:,:,:) = 0.0 + pflls(:,:,:) = 0.0 + rand_pert_max = 0.0 + ndt = max(nint(dt_in/dt_inner),1) + dt = dt_in/ndt + if(dt_in .le. dt_inner) dt= dt_in + + !Get the Thompson MP SPP magnitude and standard deviation cutoff, + !then compute rand_pert_max + + if (rand_perturb_on .ne. 0) then + do k =1,n_var_spp + select case (spp_var_list(k)) + case('mp') + rand_pert_max = spp_prt_list(k)*spp_stddev_cutoff(k) + end select + enddo + endif + + do it = 1, ndt + + qc_max = 0. + qr_max = 0. + qs_max = 0. + qi_max = 0. + qg_max = 0 + ni_max = 0. + nr_max = 0. + imax_qc = 0 + imax_qr = 0 + imax_qi = 0 + imax_qs = 0 + imax_qg = 0 + imax_ni = 0 + imax_nr = 0 + jmax_qc = 0 + jmax_qr = 0 + jmax_qi = 0 + jmax_qs = 0 + jmax_qg = 0 + jmax_ni = 0 + jmax_nr = 0 + kmax_qc = 0 + kmax_qr = 0 + kmax_qi = 0 + kmax_qs = 0 + kmax_qg = 0 + kmax_ni = 0 + kmax_nr = 0 + + j_loop: do j = j_start, j_end + i_loop: do i = i_start, i_end + + !+---+-----------------------------------------------------------------+ + !..Introduce stochastic parameter perturbations by creating as many scalar rand1, rand2, ... + !.. variables as needed to perturb different pieces of microphysics. gthompsn 21Mar2018 + ! Setting spp_mp_opt to 1 gives graupel Y-intercept pertubations (2^0) + ! 2 gives cloud water distribution gamma shape parameter perturbations (2^1) + ! 4 gives CCN & IN activation perturbations (2^2) + ! 3 gives both 1+2 + ! 5 gives both 1+4 + ! 6 gives both 2+4 + ! 7 gives all 1+2+4 + ! For now (22Mar2018), standard deviation should be up to 0.75 and cut-off at 3.0 + ! stddev in order to constrain the various perturbations from being too extreme. + !+---+-----------------------------------------------------------------+ + rand1 = 0.0 + rand2 = 0.0 + rand3 = 0.0 + if (rand_perturb_on .ne. 0) then + if (MOD(rand_perturb_on,2) .ne. 0) rand1 = rand_pert(i,1) + m = RSHIFT(ABS(rand_perturb_on),1) + if (MOD(m,2) .ne. 0) rand2 = rand_pert(i,1)*2. + m = RSHIFT(ABS(rand_perturb_on),2) + if (MOD(m,2) .ne. 0) rand3 = 0.25*(rand_pert(i,1)+rand_pert_max) + m = RSHIFT(ABS(rand_perturb_on),3) + endif + !+---+-----------------------------------------------------------------+ + + pptrain = 0. + pptsnow = 0. + pptgraul = 0. + pptice = 0. + RAINNCV(i,j) = 0. + IF ( PRESENT (snowncv) ) THEN + SNOWNCV(i,j) = 0. + ENDIF + IF ( PRESENT (icencv) ) THEN + ICENCV(i,j) = 0. + ENDIF + IF ( PRESENT (graupelncv) ) THEN + GRAUPELNCV(i,j) = 0. + ENDIF + SR(i,j) = 0. + + do k = kts, kte + if (present(tt)) then + t1d(k) = tt(i,k,j) + else + t1d(k) = th(i,k,j)*pii(i,k,j) + end if + p1d(k) = p(i,k,j) + w1d(k) = w(i,k,j) + dz1d(k) = dz(i,k,j) + qv1d(k) = qv(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qr1d(k) = qr(i,k,j) + qs1d(k) = qs(i,k,j) + qg1d(k) = qg(i,k,j) + ni1d(k) = ni(i,k,j) + nr1d(k) = nr(i,k,j) + rho(k) = RoverRv * p1d(k) / (R * t1d(k) * (qv1d(k)+RoverRv)) + + ! These arrays are always allocated and must be initialized + !vtsk1(k) = 0. + !txrc1(k) = 0. + !txri1(k) = 0. + initialize_extended_diagnostics: if (ext_diag) then + prw_vcdc1(k) = 0. + prw_vcde1(k) = 0. + tpri_inu1(k) = 0. + tpri_ide1_d(k) = 0. + tpri_ide1_s(k) = 0. + tprs_ide1(k) = 0. + tprs_sde1_d(k) = 0. + tprs_sde1_s(k) = 0. + tprg_gde1_d(k) = 0. + tprg_gde1_s(k) = 0. + tpri_iha1(k) = 0. + tpri_wfz1(k) = 0. + tpri_rfz1(k) = 0. + tprg_rfz1(k) = 0. + tprs_scw1(k) = 0. + tprg_scw1(k) = 0. + tprg_rcs1(k) = 0. + tprs_rcs1(k) = 0. + tprr_rci1(k) = 0. + tprg_rcg1(k) = 0. + tprw_vcd1_c(k) = 0. + tprw_vcd1_e(k) = 0. + tprr_sml1(k) = 0. + tprr_gml1(k) = 0. + tprr_rcg1(k) = 0. + tprr_rcs1(k) = 0. + tprv_rev1(k) = 0. + tten1(k) = 0. + qvten1(k) = 0. + qrten1(k) = 0. + qsten1(k) = 0. + qgten1(k) = 0. + qiten1(k) = 0. + niten1(k) = 0. + nrten1(k) = 0. + ncten1(k) = 0. + qcten1(k) = 0. + endif initialize_extended_diagnostics + enddo + lsml = lsm(i,j) + if (configs%aerosol_aware .or. merra2_aerosol_aware) then + do k = kts, kte + nc1d(k) = nc(i,k,j) + nwfa1d(k) = nwfa(i,k,j) + nifa1d(k) = nifa(i,k,j) + enddo + else + do k = kts, kte + if(lsml == 1) then + nc1d(k) = Nt_c_l / rho(k) + else + nc1d(k) = Nt_c_o / rho(k) + endif + nwfa1d(k) = nwfa_default + nifa1d(k) = nifa_default + enddo + endif + + ! ng and qb are optional hail-aware variables + if ((present(ng)) .and. (present(qb))) then + configs%hail_aware = .true. + do k = kts, kte + ng1d(k) = ng(i,k,j) + qb1d(k) = qb(i,k,j) + enddo + else + do k = kte, kts, -1 + ! This is the one-moment graupel formulation + if (qg1d(k) > R1) then + ygra1 = log10(max(1.e-9, qg1d(k)*rho(k))) + zans1 = 3.4 + 2.0/7.0*(ygra1+8.0) + ! zans1 = max(2.0, min(zans1, 6.0)) + N0_exp = max(gonv_min, min(10.0**(zans1), gonv_max)) + lam_exp = (n0_exp*am_g(idx_bg1)*cgg(1,1) / (rho(k)*qg1d(k)))**oge1 + lamg = lam_exp * (cgg(3,1)*ogg2*ogg1)**obmg + ng1d(k) = cgg(2,1) * ogg3*rho(k) * qg1d(k) * lamg**bm_g / am_g(idx_bg1) + ng1d(k) = max(R2, (ng1d(k)/rho(k))) + qb1d(k) = qg1d(k) / rho_g(idx_bg1) + else + ng1d(k) = 0 + qb1d(k) = 0 + endif + enddo + endif + + !> - Call mp_thompson() + call mp_tempo_main(qv1d=qv1d, qc1d=qc1d, qi1d=qi1d, qr1d=qr1d, qs1d=qs1d, qg1d=qg1d, qb1d=qb1d, & + ni1d=ni1d, nr1d=nr1d, nc1d=nc1d, ng1d=ng1d, nwfa1d=nwfa1d, nifa1d=nifa1d, t1d=t1d, p1d=p1d, & + w1d=w1d, dzq=dz1d, pptrain=pptrain, pptsnow=pptsnow, pptgraul=pptgraul, pptice=pptice, & + rand1=rand1, rand2=rand3, rand3=rand3, & + ext_diag=ext_diag, sedi_semi=sedi_semi, decfl=decfl, & + prw_vcdc1=prw_vcdc1, & + prw_vcde1=prw_vcde1, & + tpri_inu1=tpri_inu1, tpri_ide1_d=tpri_ide1_d, tpri_ide1_s=tpri_ide1_s, tprs_ide1=tprs_ide1, & + tprs_sde1_d=tprs_sde1_d, tprs_sde1_s=tprs_sde1_s, & + tprg_gde1_d=tprg_gde1_d, tprg_gde1_s=tprg_gde1_s, tpri_iha1=tpri_iha1, tpri_wfz1=tpri_wfz1, & + tpri_rfz1=tpri_rfz1, tprg_rfz1=tprg_rfz1, tprs_scw1=tprs_scw1, tprg_scw1=tprg_scw1, & + tprg_rcs1=tprg_rcs1, tprs_rcs1=tprs_rcs1, tprr_rci1=tprr_rci1, & + tprg_rcg1=tprg_rcg1, tprw_vcd1_c=tprw_vcd1_c, & + tprw_vcd1_e=tprw_vcd1_e, tprr_sml1=tprr_sml1, tprr_gml1=tprr_gml1, tprr_rcg1=tprr_rcg1, & + tprr_rcs1=tprr_rcs1, tprv_rev1=tprv_rev1, & + tten1=tten1, qvten1=qvten1, qrten1=qrten1, qsten1=qsten1, & + qgten1=qgten1, qiten1=qiten1, niten1=niten1, nrten1=nrten1, ncten1=ncten1, qcten1=qcten1, & + pfil1=pfil1, pfll1=pfll1, lsml=lsml, & + kts=kts, kte=kte, dt=dt, ii=i, jj=j, configs=configs) + + + pcp_ra(i,j) = pcp_ra(i,j) + pptrain + pcp_sn(i,j) = pcp_sn(i,j) + pptsnow + pcp_gr(i,j) = pcp_gr(i,j) + pptgraul + pcp_ic(i,j) = pcp_ic(i,j) + pptice + RAINNCV(i,j) = pptrain + pptsnow + pptgraul + pptice + RAINNC(i,j) = RAINNC(i,j) + pptrain + pptsnow + pptgraul + pptice + IF ( PRESENT(snowncv) .AND. PRESENT(snownc) ) THEN + ! Add ice to snow if separate ice not present + IF ( .NOT.PRESENT(icencv) .OR. .NOT.PRESENT(icenc) ) THEN + SNOWNCV(i,j) = pptsnow + pptice + SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + pptice + ELSE + SNOWNCV(i,j) = pptsnow + SNOWNC(i,j) = SNOWNC(i,j) + pptsnow + ENDIF + ENDIF + ! Use separate ice if present (as in FV3) + IF ( PRESENT(icencv) .AND. PRESENT(icenc) ) THEN + ICENCV(i,j) = pptice + ICENC(i,j) = ICENC(i,j) + pptice + ENDIF + IF ( PRESENT(graupelncv) .AND. PRESENT(graupelnc) ) THEN + GRAUPELNCV(i,j) = pptgraul + GRAUPELNC(i,j) = GRAUPELNC(i,j) + pptgraul + ENDIF + SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12) + + + + !..Reset lowest model level to initial state aerosols (fake sfc source). + !.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol + !.. number tendency (number per kg per second). + if (configs%aerosol_aware) then + if ( present (aero_ind_fdb) ) then + if ( .not. aero_ind_fdb) then + nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt + nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt + endif + else + nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt + nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt + end if + + do k = kts, kte + nc(i,k,j) = nc1d(k) + nwfa(i,k,j) = nwfa1d(k) + nifa(i,k,j) = nifa1d(k) + enddo + endif + + if (merra2_aerosol_aware) then + do k = kts, kte + nc(i,k,j) = nc1d(k) + nwfa(i,k,j) = nwfa1d(k) + nifa(i,k,j) = nifa1d(k) + enddo + endif + + if ((present(ng)) .and. (present(qb))) then + do k = kts, kte + ng(i,k,j) = ng1d(k) + qb(i,k,j) = qb1d(k) + enddo + endif + + do k = kts, kte + qv(i,k,j) = qv1d(k) + qc(i,k,j) = qc1d(k) + qi(i,k,j) = qi1d(k) + qr(i,k,j) = qr1d(k) + qs(i,k,j) = qs1d(k) + qg(i,k,j) = qg1d(k) + ni(i,k,j) = ni1d(k) + nr(i,k,j) = nr1d(k) + pfils(i,k,j) = pfils(i,k,j) + pfil1(k) + pflls(i,k,j) = pflls(i,k,j) + pfll1(k) + if (present(tt)) then + tt(i,k,j) = t1d(k) + else + th(i,k,j) = t1d(k)/pii(i,k,j) + endif + + if (qc1d(k) .gt. qc_max) then + imax_qc = i + jmax_qc = j + kmax_qc = k + qc_max = qc1d(k) + elseif (qc1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qc ', qc1d(k), & + ' at i,j,k=', i,j,k + endif + if (qr1d(k) .gt. qr_max) then + imax_qr = i + jmax_qr = j + kmax_qr = k + qr_max = qr1d(k) + elseif (qr1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qr ', qr1d(k), & + ' at i,j,k=', i,j,k + endif + if (nr1d(k) .gt. nr_max) then + imax_nr = i + jmax_nr = j + kmax_nr = k + nr_max = nr1d(k) + elseif (nr1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative nr ', nr1d(k), & + ' at i,j,k=', i,j,k + endif + if (qs1d(k) .gt. qs_max) then + imax_qs = i + jmax_qs = j + kmax_qs = k + qs_max = qs1d(k) + elseif (qs1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qs ', qs1d(k), & + ' at i,j,k=', i,j,k + endif + if (qi1d(k) .gt. qi_max) then + imax_qi = i + jmax_qi = j + kmax_qi = k + qi_max = qi1d(k) + elseif (qi1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qi ', qi1d(k), & + ' at i,j,k=', i,j,k + endif + if (qg1d(k) .gt. qg_max) then + imax_qg = i + jmax_qg = j + kmax_qg = k + qg_max = qg1d(k) + elseif (qg1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qg ', qg1d(k), & + ' at i,j,k=', i,j,k + endif + if (ni1d(k) .gt. ni_max) then + imax_ni = i + jmax_ni = j + kmax_ni = k + ni_max = ni1d(k) + elseif (ni1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative ni ', ni1d(k), & + ' at i,j,k=', i,j,k + endif + if (qv1d(k) .lt. 0.0) then + write(*,'(a,e16.7,a,3i8)') 'WARNING, negative qv ', qv1d(k), & + ' at i,j,k=', i,j,k + if (k.lt.kte-2 .and. k.gt.kts+1) then + write(*,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j) + qv(i,k,j) = max(1.e-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j))) + else + qv(i,k,j) = 1.e-7 + endif + endif + enddo + + assign_extended_diagnostics: if (ext_diag) then + do k=kts,kte + !vts1(i,k,j) = vtsk1(k) + !txri(i,k,j) = txri(i,k,j) + txri1(k) + !txrc(i,k,j) = txrc(i,k,j) + txrc1(k) + prw_vcdc(i,k,j) = prw_vcdc(i,k,j) + prw_vcdc1(k) + prw_vcde(i,k,j) = prw_vcde(i,k,j) + prw_vcde1(k) + tpri_inu(i,k,j) = tpri_inu(i,k,j) + tpri_inu1(k) + tpri_ide_d(i,k,j) = tpri_ide_d(i,k,j) + tpri_ide1_d(k) + tpri_ide_s(i,k,j) = tpri_ide_s(i,k,j) + tpri_ide1_s(k) + tprs_ide(i,k,j) = tprs_ide(i,k,j) + tprs_ide1(k) + tprs_sde_s(i,k,j) = tprs_sde_s(i,k,j) + tprs_sde1_s(k) + tprs_sde_d(i,k,j) = tprs_sde_d(i,k,j) + tprs_sde1_d(k) + tprg_gde_d(i,k,j) = tprg_gde_d(i,k,j) + tprg_gde1_d(k) + tprg_gde_s(i,k,j) = tprg_gde_s(i,k,j) + tprg_gde1_s(k) + tpri_iha(i,k,j) = tpri_iha(i,k,j) + tpri_iha1(k) + tpri_wfz(i,k,j) = tpri_wfz(i,k,j) + tpri_wfz1(k) + tpri_rfz(i,k,j) = tpri_rfz(i,k,j) + tpri_rfz1(k) + tprg_rfz(i,k,j) = tprg_rfz(i,k,j) + tprg_rfz1(k) + tprs_scw(i,k,j) = tprs_scw(i,k,j) + tprs_scw1(k) + tprg_scw(i,k,j) = tprg_scw(i,k,j) + tprg_scw1(k) + tprg_rcs(i,k,j) = tprg_rcs(i,k,j) + tprg_rcs1(k) + tprs_rcs(i,k,j) = tprs_rcs(i,k,j) + tprs_rcs1(k) + tprr_rci(i,k,j) = tprr_rci(i,k,j) + tprr_rci1(k) + tprg_rcg(i,k,j) = tprg_rcg(i,k,j) + tprg_rcg1(k) + tprw_vcd_c(i,k,j) = tprw_vcd_c(i,k,j) + tprw_vcd1_c(k) + tprw_vcd_e(i,k,j) = tprw_vcd_e(i,k,j) + tprw_vcd1_e(k) + tprr_sml(i,k,j) = tprr_sml(i,k,j) + tprr_sml1(k) + tprr_gml(i,k,j) = tprr_gml(i,k,j) + tprr_gml1(k) + tprr_rcg(i,k,j) = tprr_rcg(i,k,j) + tprr_rcg1(k) + tprr_rcs(i,k,j) = tprr_rcs(i,k,j) + tprr_rcs1(k) + tprv_rev(i,k,j) = tprv_rev(i,k,j) + tprv_rev1(k) + tten3(i,k,j) = tten3(i,k,j) + tten1(k) + qvten3(i,k,j) = qvten3(i,k,j) + qvten1(k) + qrten3(i,k,j) = qrten3(i,k,j) + qrten1(k) + qsten3(i,k,j) = qsten3(i,k,j) + qsten1(k) + qgten3(i,k,j) = qgten3(i,k,j) + qgten1(k) + qiten3(i,k,j) = qiten3(i,k,j) + qiten1(k) + niten3(i,k,j) = niten3(i,k,j) + niten1(k) + nrten3(i,k,j) = nrten3(i,k,j) + nrten1(k) + ncten3(i,k,j) = ncten3(i,k,j) + ncten1(k) + qcten3(i,k,j) = qcten3(i,k,j) + qcten1(k) + + enddo + endif assign_extended_diagnostics + + if (ndt>1 .and. it==ndt) then + + SR(i,j) = (pcp_sn(i,j) + pcp_gr(i,j) + pcp_ic(i,j))/(RAINNC(i,j)+1.e-12) + RAINNCV(i,j) = RAINNC(i,j) + IF ( PRESENT (snowncv) ) THEN + SNOWNCV(i,j) = SNOWNC(i,j) + ENDIF + IF ( PRESENT (icencv) ) THEN + ICENCV(i,j) = ICENC(i,j) + ENDIF + IF ( PRESENT (graupelncv) ) THEN + GRAUPELNCV(i,j) = GRAUPELNC(i,j) + ENDIF + endif + + ! Diagnostic calculations only for last step + ! if Thompson MP is called multiple times + last_step_only: IF ((ndt>1 .and. it==ndt) .or. & + (nsteps>1 .and. istep==nsteps) .or. & + (nsteps==1 .and. ndt==1)) THEN + +!! max_hail_diam_sfc(i,j) = hail_mass_99th_percentile(kts, kte, qg1d, t1d, p1d, qv1d) + + !> - Call calc_refl10cm() + + diagflag_present: IF ( PRESENT (diagflag) ) THEN + if (diagflag .and. do_radar_ref == 1) then + ! + ! Only set melti to true at the output times + if (fullradar_diag) then + melti=.true. + else + melti=.false. + endif + ! + if (present(vt_dbz_wt)) then + call calc_refl10cm (qv1d=qv1d, qc1d=qc1d, qr1d=qr1d, nr1d=nr1d, qs1d=qs1d, qg1d=qg1d, & + ng1d=ng1d, qb1d=qb1d, t1d=t1d, p1d=p1d, dBZ=dBZ, rand1=rand1, kts=kts, kte=kte, ii=i, jj=j, & + melti=melti, vt_dBZ=vt_dbz_wt(i,:,j), & + first_time_step=first_time_step, configs=configs) + else + call calc_refl10cm (qv1d=qv1d, qc1d=qc1d, qr1d=qr1d, nr1d=nr1d, qs1d=qs1d, qg1d=qg1d, & + ng1d=ng1d, qb1d=qb1d, t1d=t1d, p1d=p1d, dBZ=dBZ, rand1=rand1, kts=kts, kte=kte, ii=i, jj=j, & + melti=melti, configs=configs) + end if + do k = kts, kte + refl_10cm(i,k,j) = max(-35., dBZ(k)) + enddo + endif + ENDIF diagflag_present + + IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN + do k = kts, kte + re_qc1d(k) = re_qc_min + re_qi1d(k) = re_qi_min + re_qs1d(k) = re_qs_min + enddo + !> - Call calc_effectrad() + call calc_effectRad (t1d=t1d, p1d=p1d, qv1d=qv1d, qc1d=qc1d, & + nc1d=nc1d, qi1d=qi1d, ni1d=ni1d, qs1d=qs1d, & + re_qc1d=re_qc1d, re_qi1d=re_qi1d, re_qs1d=re_qs1d, & + kts=kts, kte=kte, lsml=lsml, configs=configs) + do k = kts, kte + re_cloud(i,k,j) = max(re_qc_min, min(re_qc1d(k), re_qc_max)) + re_ice(i,k,j) = max(re_qi_min, min(re_qi1d(k), re_qi_max)) + re_snow(i,k,j) = max(re_qs_min, min(re_qs1d(k), re_qs_max)) + enddo + ENDIF + ENDIF last_step_only + + enddo i_loop + enddo j_loop + + ! DEBUG - GT + ! write(*,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', & + ! 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', & + ! 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', & + ! 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', & + ! 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', & + ! 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', & + ! 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')', & + ! 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' + ! END DEBUG - GT + enddo ! end of nt loop + + do j = j_start, j_end + do k = kts, kte + do i = i_start, i_end + pfils(i,k,j) = pfils(i,k,j)/dt_in + pflls(i,k,j) = pflls(i,k,j)/dt_in + enddo + enddo + enddo + + ! These are always allocated + !deallocate (vtsk1) + !deallocate (txri1) + !deallocate (txrc1) + deallocate_extended_diagnostics: if (ext_diag) then + deallocate (prw_vcdc1) + deallocate (prw_vcde1) + deallocate (tpri_inu1) + deallocate (tpri_ide1_d) + deallocate (tpri_ide1_s) + deallocate (tprs_ide1) + deallocate (tprs_sde1_d) + deallocate (tprs_sde1_s) + deallocate (tprg_gde1_d) + deallocate (tprg_gde1_s) + deallocate (tpri_iha1) + deallocate (tpri_wfz1) + deallocate (tpri_rfz1) + deallocate (tprg_rfz1) + deallocate (tprs_scw1) + deallocate (tprg_scw1) + deallocate (tprg_rcs1) + deallocate (tprs_rcs1) + deallocate (tprr_rci1) + deallocate (tprg_rcg1) + deallocate (tprw_vcd1_c) + deallocate (tprw_vcd1_e) + deallocate (tprr_sml1) + deallocate (tprr_gml1) + deallocate (tprr_rcg1) + deallocate (tprr_rcs1) + deallocate (tprv_rev1) + deallocate (tten1) + deallocate (qvten1) + deallocate (qrten1) + deallocate (qsten1) + deallocate (qgten1) + deallocate (qiten1) + deallocate (niten1) + deallocate (nrten1) + deallocate (ncten1) + deallocate (qcten1) + end if deallocate_extended_diagnostics + + END SUBROUTINE tempo_3d_to_1d_driver + !> @} + + !>\ingroup aathompson + SUBROUTINE tempo_finalize() + + IMPLICIT NONE + + if (ALLOCATED(tcg_racg)) DEALLOCATE(tcg_racg) + if (ALLOCATED(tmr_racg)) DEALLOCATE(tmr_racg) + if (ALLOCATED(tcr_gacr)) DEALLOCATE(tcr_gacr) + if (ALLOCATED(tnr_racg)) DEALLOCATE(tnr_racg) + if (ALLOCATED(tnr_gacr)) DEALLOCATE(tnr_gacr) + + if (ALLOCATED(tcs_racs1)) DEALLOCATE(tcs_racs1) + if (ALLOCATED(tmr_racs1)) DEALLOCATE(tmr_racs1) + if (ALLOCATED(tcs_racs2)) DEALLOCATE(tcs_racs2) + if (ALLOCATED(tmr_racs2)) DEALLOCATE(tmr_racs2) + if (ALLOCATED(tcr_sacr1)) DEALLOCATE(tcr_sacr1) + if (ALLOCATED(tms_sacr1)) DEALLOCATE(tms_sacr1) + if (ALLOCATED(tcr_sacr2)) DEALLOCATE(tcr_sacr2) + if (ALLOCATED(tms_sacr2)) DEALLOCATE(tms_sacr2) + if (ALLOCATED(tnr_racs1)) DEALLOCATE(tnr_racs1) + if (ALLOCATED(tnr_racs2)) DEALLOCATE(tnr_racs2) + if (ALLOCATED(tnr_sacr1)) DEALLOCATE(tnr_sacr1) + if (ALLOCATED(tnr_sacr2)) DEALLOCATE(tnr_sacr2) + + if (ALLOCATED(tpi_qcfz)) DEALLOCATE(tpi_qcfz) + if (ALLOCATED(tni_qcfz)) DEALLOCATE(tni_qcfz) + + if (ALLOCATED(tpi_qrfz)) DEALLOCATE(tpi_qrfz) + if (ALLOCATED(tpg_qrfz)) DEALLOCATE(tpg_qrfz) + if (ALLOCATED(tni_qrfz)) DEALLOCATE(tni_qrfz) + if (ALLOCATED(tnr_qrfz)) DEALLOCATE(tnr_qrfz) + + if (ALLOCATED(tps_iaus)) DEALLOCATE(tps_iaus) + if (ALLOCATED(tni_iaus)) DEALLOCATE(tni_iaus) + if (ALLOCATED(tpi_ide)) DEALLOCATE(tpi_ide) + + if (ALLOCATED(t_Efrw)) DEALLOCATE(t_Efrw) + if (ALLOCATED(t_Efsw)) DEALLOCATE(t_Efsw) + + if (ALLOCATED(tnr_rev)) DEALLOCATE(tnr_rev) + if (ALLOCATED(tpc_wev)) DEALLOCATE(tpc_wev) + if (ALLOCATED(tnc_wev)) DEALLOCATE(tnc_wev) + + if (ALLOCATED(tnccn_act)) DEALLOCATE(tnccn_act) + + END SUBROUTINE tempo_finalize + +end module module_mp_tempo + !+---+-----------------------------------------------------------------+ + !ctrlL + !+---+-----------------------------------------------------------------+ + !+---+-----------------------------------------------------------------+ + diff --git a/physics/MP/TEMPO/mp_tempo.F90 b/physics/MP/TEMPO/mp_tempo.F90 new file mode 100644 index 000000000..174eaac2e --- /dev/null +++ b/physics/MP/TEMPO/mp_tempo.F90 @@ -0,0 +1,1126 @@ +!>\file mp_tempo.F90 +!! This file contains aerosol-aware TEMPO MP scheme. + + +!>\defgroup aatempo Aerosol-Aware TEMPO MP Module +!! This module contains the aerosol-aware TEMPO microphysics scheme. +module mp_tempo + + use mpi_f08 + use machine, only : kind_phys + + use module_mp_tempo_params + use module_mp_tempo_utils, only : make_IceNumber, make_RainNumber, make_DropletNumber + use module_mp_tempo, only : tempo_init, tempo_3d_to_1d_driver, tempo_finalize + + implicit none + + public :: mp_tempo_init, mp_tempo_run, mp_tempo_finalize + + private + + integer, parameter :: ext_ndiag3d = 37 + + contains + +!> This subroutine is a wrapper around the actual tempo_init(). +!! \section arg_table_mp_tempo_init Argument Table +!! \htmlinclude mp_tempo_init.html +!! + subroutine mp_tempo_init(ncol, nlev, con_pi, con_t0c, con_rv, & + con_cp, con_rgas, con_boltz, con_amd, & + con_amw, con_avgd, con_hvap, con_hfus, & + con_g, con_rd, con_eps, & + restart, imp_physics, & + imp_physics_tempo, convert_dry_rho, & + spechum, qc, qr, qi, qs, qg, ni, nr, & + chw, vh, & + is_aerosol_aware, merra2_aerosol_aware, & + is_hail_aware, & + nc, nwfa2d, nifa2d, & + nwfa, nifa, tgrs, prsl, phil, area, & + aerfld, mpicomm, mpirank, mpiroot, & + threads, ext_diag, diag3d, & + is_initialized, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: ncol + integer, intent(in ) :: nlev + real(kind_phys), intent(in ) :: con_pi, con_t0c, con_rv, con_cp, con_rgas, & + con_boltz, con_amd, con_amw, con_avgd, & + con_hvap, con_hfus, con_g, con_rd, con_eps + logical, intent(in ) :: restart + logical, intent(inout) :: is_initialized + integer, intent(in ) :: imp_physics + integer, intent(in ) :: imp_physics_tempo + ! Hydrometeors + logical, intent(in ) :: convert_dry_rho + real(kind_phys), intent(inout) :: spechum(:,:) + real(kind_phys), intent(inout) :: qc(:,:) + real(kind_phys), intent(inout) :: qr(:,:) + real(kind_phys), intent(inout) :: qi(:,:) + real(kind_phys), intent(inout) :: qs(:,:) + real(kind_phys), intent(inout) :: qg(:,:) + real(kind_phys), intent(inout) :: ni(:,:) + real(kind_phys), intent(inout) :: nr(:,:) + real(kind_phys), intent(inout), optional :: chw(:,:), vh(:,:) + ! Aerosols + logical, intent(in ) :: is_aerosol_aware + logical, intent(in ) :: merra2_aerosol_aware + logical, intent(in ) :: is_hail_aware + real(kind_phys), intent(inout), optional :: nc(:,:) + real(kind_phys), intent(inout), optional :: nwfa(:,:) + real(kind_phys), intent(inout), optional :: nifa(:,:) + real(kind_phys), intent(inout), optional :: nwfa2d(:) + real(kind_phys), intent(inout), optional :: nifa2d(:) + real(kind_phys), intent(in) :: aerfld(:,:,:) + ! State variables + real(kind_phys), intent(in ) :: tgrs(:,:) + real(kind_phys), intent(in ) :: prsl(:,:) + real(kind_phys), intent(in ) :: phil(:,:) + real(kind_phys), intent(in ) :: area(:) + ! MPI information + type(MPI_Comm), intent(in ) :: mpicomm + integer, intent(in ) :: mpirank + integer, intent(in ) :: mpiroot + ! Threading/blocking information + integer, intent(in ) :: threads + ! Extended diagnostics + logical, intent(in ) :: ext_diag + real(kind_phys), intent(in ), optional :: diag3d(:,:,:) + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! + real(kind_phys) :: qv(1:ncol,1:nlev) ! kg kg-1 (water vapor mixing ratio) + real(kind_phys) :: hgt(1:ncol,1:nlev) ! m + real(kind_phys) :: rho(1:ncol,1:nlev) ! kg m-3 + real(kind_phys) :: orho(1:ncol,1:nlev) ! m3 kg-1 + real(kind_phys) :: nc_local(1:ncol,1:nlev) ! needed because nc is only allocated if is_aerosol_aware is true + ! + real (kind=kind_phys) :: h_01, z1, niIN3, niCCN3 + integer :: i, k + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + + if (is_initialized) return + + ! Consistency checks + if (imp_physics/=imp_physics_tempo) then + write(errmsg,'(*(a))') "Logic error: namelist choice of microphysics is different from TEMPO MP" + errflg = 1 + return + end if + + if (ext_diag) then + if (size(diag3d,dim=3) /= ext_ndiag3d) then + write(errmsg,'(*(a))') "Logic error: number of diagnostic 3d arrays from model does not match requirements" + errflg = 1 + return + end if + end if + + if (is_aerosol_aware .and. merra2_aerosol_aware) then + write(errmsg,'(*(a))') "Logic error: Only one TEMPO aerosol option can be true, either is_aerosol_aware or merra2_aerosol_aware)" + errflg = 1 + return + end if + + ! Call TEMPO init (also sets initial default values of physical constants) + if (mpirank==mpiroot) write(*,*) 'Calling tempo_init() with is_aerosol_aware = ', is_aerosol_aware + + call tempo_init(is_aerosol_aware_in=is_aerosol_aware, & + merra2_aerosol_aware_in=merra2_aerosol_aware, & + is_hail_aware_in=is_hail_aware, & + mpicomm=mpicomm, mpirank=mpirank, mpiroot=mpiroot, & + threads=threads, errmsg=errmsg, errflg=errflg) + if (errflg /= 0) return + + ! For restart runs, the init is done here + if (restart) then + is_initialized = .true. + return + end if + + ! Set local TEMPO MP module constants from host model and overwrite derived constants calculated in module_mp_tempo_params/mp_tempo_params_init() + PI = con_pi + lvap0 = con_hvap + lfus = con_hfus + lsub = lvap0 + lfus + olfus = 1./lfus + + Rv = con_Rv + R = con_rd + RoverRv = con_eps + Cp2 = con_cp + T_0 = con_t0c + R_uni = con_rgas + k_b = con_boltz + N_avo = con_avgd + + oRv = 1.0 / Rv + am_r = PI * rho_w2 / 6.0 + am_i = PI * rho_i / 6.0 + am_g = (/PI*rho_g(1)/6.0, & + PI*rho_g(2)/6.0, & + PI*rho_g(3)/6.0, & + PI*rho_g(4)/6.0, & + PI*rho_g(5)/6.0, & + PI*rho_g(6)/6.0, & + PI*rho_g(7)/6.0, & + PI*rho_g(8)/6.0, & + PI*rho_g(9)/6.0/) + + M_w = con_amw*1.0E-3 !module_mp_tempo expects kg/mol + M_a = con_amd*1.0E-3 !module_mp_tempo expects kg/mol + ma_w = M_w/N_avo + + ar_volume = 4.0 / 3.0 * PI * (2.5e-6)**3 + + ! Geopotential height in m2 s-2 to height in m + hgt = phil/con_g + + ! Ensure non-negative mass mixing ratios of all water variables + where(spechum<0) spechum = 1.0E-10 ! COMMENT, gthompsn, spechum should *never* be identically zero. + where(qc<0) qc = 0.0 + where(qr<0) qr = 0.0 + where(qi<0) qi = 0.0 + where(qs<0) qs = 0.0 + where(qg<0) qg = 0.0 + + !> - Convert specific humidity to water vapor mixing ratio. + !> - Also, hydrometeor variables are mass or number mixing ratio + !> - either kg of species per kg of dry air, or per kg of (dry + vapor). + if (merra2_aerosol_aware) then + call get_niwfa(aerfld, nifa, nwfa, ncol, nlev) + end if + + + qv = spechum/(1.0_kind_phys-spechum) + + if (convert_dry_rho) then + qc = qc/(1.0_kind_phys-spechum) + qr = qr/(1.0_kind_phys-spechum) + qi = qi/(1.0_kind_phys-spechum) + qs = qs/(1.0_kind_phys-spechum) + qg = qg/(1.0_kind_phys-spechum) + + ni = ni/(1.0_kind_phys-spechum) + nr = nr/(1.0_kind_phys-spechum) + if (is_hail_aware) then + chw = chw/(1.0_kind_phys-spechum) + vh = vh/(1.0_kind_phys-spechum) + endif + if (is_aerosol_aware .or. merra2_aerosol_aware) then + nc = nc/(1.0_kind_phys-spechum) + nwfa = nwfa/(1.0_kind_phys-spechum) + nifa = nifa/(1.0_kind_phys-spechum) + end if + end if + + ! Density of moist air in kg m-3 and inverse density of air + rho = con_eps*prsl/(con_rd*tgrs*(qv+con_eps)) + orho = 1.0/rho + + ! Ensure we have 1st guess ice number where mass non-zero but no number. + where(qi .LE. 0.0) ni=0.0 + where(qi .GT. 0 .and. ni .LE. 0.0) ni = make_IceNumber(qi*rho, tgrs) * orho + where(qi .EQ. 0.0 .and. ni .GT. 0.0) ni=0.0 + + ! Ensure we have 1st guess rain number where mass non-zero but no number. + where(qr .LE. 0.0) nr=0.0 + where(qr .GT. 0 .and. nr .LE. 0.0) nr = make_RainNumber(qr*rho, tgrs) * orho + where(qr .EQ. 0.0 .and. nr .GT. 0.0) nr=0.0 + + if (is_hail_aware) then + where(qg .LE. 0.0) chw=0.0 + where(qg .LE. 0.0) vh=0.0 + endif + + !..Check for existing aerosol data, both CCN and IN aerosols. If missing + !.. fill in just a basic vertical profile, somewhat boundary-layer following. + if (is_aerosol_aware) then + + ! Potential cloud condensation nuclei (CCN) + if (MAXVAL(nwfa) .lt. eps) then + if (mpirank==mpiroot) write(*,*) ' Apparently there are no initial CCN aerosols.' + do i = 1, ncol + if (hgt(i,1).le.1000.0) then + h_01 = 0.8 + elseif (hgt(i,1).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(i,1)*0.001 - 1.0) + endif + niCCN3 = -1.0*ALOG(naCCN1/naCCN0)/h_01 + nwfa(i,1) = naCCN1+naCCN0*exp(-((hgt(i,2)-hgt(i,1))/1000.)*niCCN3) + z1 = hgt(i,2)-hgt(i,1) + nwfa2d(i) = nwfa(i,1) * 0.000196 * (50./z1) + do k = 2, nlev + nwfa(i,k) = naCCN1+naCCN0*exp(-((hgt(i,k)-hgt(i,1))/1000.)*niCCN3) + enddo + enddo + else + if (mpirank==mpiroot) write(*,*) ' Apparently initial CCN aerosols are present.' + if (MAXVAL(nwfa2d) .lt. eps) then + !+---+-----------------------------------------------------------------+ + !..Scale the lowest level aerosol data into an emissions rate. This is + !.. very far from ideal, but need higher emissions where larger amount + !.. of (climo) existing and lesser emissions where there exists fewer to + !.. begin as a first-order simplistic approach. Later, proper connection to + !.. emission inventory would be better, but, for now, scale like this: + !.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per second per grid box unit + !.. that was tested as ~(20kmx20kmx50m = 2.E10 m**-3) + !+---+-----------------------------------------------------------------+ + if (mpirank==mpiroot) write(*,*) ' Apparently there are no initial CCN aerosol surface emission rates.' + do i = 1, ncol + z1 = hgt(i,2)-hgt(i,1) + nwfa2d(i) = nwfa(i,1) * 0.000196 * (50./z1) + enddo + else + if (mpirank==mpiroot) write(*,*) ' Apparently initial CCN aerosol surface emission rates are present.' + endif + endif + + ! Potential ice nuclei (IN) + if (MAXVAL(nifa) .lt. eps) then + if (mpirank==mpiroot) write(*,*) ' Apparently there are no initial IN aerosols.' + do i = 1, ncol + if (hgt(i,1).le.1000.0) then + h_01 = 0.8 + elseif (hgt(i,1).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(i,1)*0.001 - 1.0) + endif + niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01 + nifa(i,1) = naIN1+naIN0*exp(-((hgt(i,2)-hgt(i,1))/1000.)*niIN3) + nifa2d(i) = 0. + do k = 2, nlev + nifa(i,k) = naIN1+naIN0*exp(-((hgt(i,k)-hgt(i,1))/1000.)*niIN3) + enddo + enddo + else + if (mpirank==mpiroot) write(*,*) ' Apparently initial IN aerosols are present.' + if (MAXVAL(nifa2d) .lt. eps) then + if (mpirank==mpiroot) write(*,*) ' Apparently there are no initial IN aerosol surface emission rates, set to zero.' + ! calculate IN surface flux here, right now just set to zero + nifa2d = 0. + else + if (mpirank==mpiroot) write(*,*) ' Apparently initial IN aerosol surface emission rates are present.' + endif + endif + + ! Ensure we have 1st guess cloud droplet number where mass non-zero but no number. + where(qc .LE. 0.0) nc=0.0 + where(qc .GT. 0 .and. nc .LE. 0.0) nc = make_DropletNumber(qc*rho, nwfa*rho) * orho + where(qc .EQ. 0.0 .and. nc .GT. 0.0) nc = 0.0 + + ! Ensure non-negative aerosol number concentrations. + where(nwfa .LE. 0.0) nwfa = 1.1E6 + where(nifa .LE. 0.0) nifa = naIN1*0.01 + + ! Copy to local array for calculating cloud effective radii below + nc_local = nc + + else if (merra2_aerosol_aware) then + + ! Ensure we have 1st guess cloud droplet number where mass non-zero but no number. + where(qc .LE. 0.0) nc=0.0 + where(qc .GT. 0 .and. nc .LE. 0.0) nc = make_DropletNumber(qc*rho, nwfa*rho) * orho + where(qc .EQ. 0.0 .and. nc .GT. 0.0) nc = 0.0 + + else + + ! Constant droplet concentration for single moment cloud water as in + ! module_mp_thompson.F90, only needed for effective radii calculation + nc_local = Nt_c_l/rho + + end if + + if (convert_dry_rho) then + !qc = qc/(1.0_kind_phys+qv) + !qr = qr/(1.0_kind_phys+qv) + !qi = qi/(1.0_kind_phys+qv) + !qs = qs/(1.0_kind_phys+qv) + !qg = qg/(1.0_kind_phys+qv) + + ni = ni/(1.0_kind_phys+qv) + nr = nr/(1.0_kind_phys+qv) + if (is_hail_aware) then + chw = chw/(1.0_kind_phys+qv) + vh = vh/(1.0_kind_phys+qv) + endif + if (is_aerosol_aware .or. merra2_aerosol_aware) then + nc = nc/(1.0_kind_phys+qv) + nwfa = nwfa/(1.0_kind_phys+qv) + nifa = nifa/(1.0_kind_phys+qv) + end if + end if + + is_initialized = .true. + + end subroutine mp_tempo_init + + +!> \section arg_table_mp_tempo_run Argument Table +!! \htmlinclude mp_tempo_run.html +!! +!>\ingroup aatempo +!>\section gen_tempo_hrrr TEMPO MP General Algorithm +!>@{ + subroutine mp_tempo_run(ncol, nlev, con_g, con_rd, & + con_eps, convert_dry_rho, & + spechum, qc, qr, qi, qs, qg, ni, nr, & + chw, vh, & + is_aerosol_aware, is_hail_aware, & + merra2_aerosol_aware, nc, nwfa, nifa,& + nwfa2d, nifa2d, aero_ind_fdb, & + tgrs, prsl, phii, omega, & + sedi_semi, decfl, islmsk, dtp, & + dt_inner, & + first_time_step, istep, nsteps, & + prcp, rain, graupel, ice, snow, sr, & + refl_10cm, fullradar_diag, & + max_hail_diam_sfc, & + do_radar_ref, aerfld, & + mpicomm, mpirank, mpiroot, blkno, & + ext_diag, diag3d, reset_diag3d, & + spp_wts_mp, spp_mp, n_var_spp, & + spp_prt_list, spp_var_list, & + spp_stddev_cutoff, & + cplchm, pfi_lsan, pfl_lsan, & + is_initialized, errmsg, errflg) + + implicit none + + ! Interface variables + logical, intent(inout) :: is_initialized + ! Dimensions and constants + integer, intent(in ) :: ncol + integer, intent(in ) :: nlev + real(kind_phys), intent(in ) :: con_g + real(kind_phys), intent(in ) :: con_rd + real(kind_phys), intent(in ) :: con_eps + ! Hydrometeors + logical, intent(in ) :: convert_dry_rho + real(kind_phys), intent(inout) :: spechum(:,:) + real(kind_phys), intent(inout) :: qc(:,:) + real(kind_phys), intent(inout) :: qr(:,:) + real(kind_phys), intent(inout) :: qi(:,:) + real(kind_phys), intent(inout) :: qs(:,:) + real(kind_phys), intent(inout) :: qg(:,:) + real(kind_phys), intent(inout) :: ni(:,:) + real(kind_phys), intent(inout) :: nr(:,:) + real(kind_phys), optional, intent(inout) :: chw(:,:), vh(:,:) + ! Aerosols + logical, intent(in) :: is_aerosol_aware, fullradar_diag + logical, intent(in) :: merra2_aerosol_aware, is_hail_aware + real(kind_phys), optional, intent(inout) :: nc(:,:) + real(kind_phys), optional, intent(inout) :: nwfa(:,:) + real(kind_phys), optional, intent(inout) :: nifa(:,:) + real(kind_phys), optional, intent(in ) :: nwfa2d(:) + real(kind_phys), optional, intent(in ) :: nifa2d(:) + real(kind_phys), intent(in) :: aerfld(:,:,:) + logical, optional, intent(in ) :: aero_ind_fdb + ! State variables and timestep information + real(kind_phys), intent(inout) :: tgrs(:,:) + real(kind_phys), intent(in ) :: prsl(:,:) + real(kind_phys), intent(in ) :: phii(:,:) + real(kind_phys), intent(in ) :: omega(:,:) + integer, intent(in ) :: islmsk(:) + real(kind_phys), intent(in ) :: dtp + logical, intent(in ) :: first_time_step + integer, intent(in ) :: istep, nsteps + real, intent(in ) :: dt_inner + ! Precip/rain/snow/graupel fall amounts and fraction of frozen precip + real(kind_phys), intent(inout) :: prcp(:) + real(kind_phys), intent(inout), optional :: rain(:) + real(kind_phys), intent(inout), optional :: graupel(:) + real(kind_phys), intent(inout), optional :: ice(:) + real(kind_phys), intent(inout), optional :: snow(:) + real(kind_phys), intent( out) :: sr(:) + ! Radar reflectivity + real(kind_phys), intent(inout) :: refl_10cm(:,:) + real(kind_phys), intent(inout) :: max_hail_diam_sfc(:) + logical, intent(in ) :: do_radar_ref + logical, intent(in) :: sedi_semi + integer, intent(in) :: decfl + ! MPI and block information + integer, intent(in) :: blkno + type(MPI_Comm), intent(in) :: mpicomm + integer, intent(in) :: mpirank + integer, intent(in) :: mpiroot + ! Extended diagnostic output + logical, intent(in) :: ext_diag + real(kind_phys), target, intent(inout), optional :: diag3d(:,:,:) + logical, intent(in) :: reset_diag3d + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! SPP + integer, intent(in) :: spp_mp + integer, intent(in) :: n_var_spp + real(kind_phys), intent(in), optional :: spp_wts_mp(:,:) + real(kind_phys), intent(in), optional :: spp_prt_list(:) + character(len=10), intent(in), optional :: spp_var_list(:) + real(kind_phys), intent(in), optional :: spp_stddev_cutoff(:) + + logical, intent (in) :: cplchm + ! ice and liquid water 3d precipitation fluxes - only allocated if cplchm is .true. + real(kind=kind_phys), intent(inout), dimension(:,:), optional :: pfi_lsan + real(kind=kind_phys), intent(inout), dimension(:,:), optional :: pfl_lsan + + ! Local variables + + ! Reduced time step if subcycling is used + real(kind_phys) :: dtstep + integer :: ndt + ! Air density + real(kind_phys) :: rho(1:ncol,1:nlev) !< kg m-3 + ! Water vapor mixing ratio (instead of specific humidity) + real(kind_phys) :: qv(1:ncol,1:nlev) !< kg kg-1 + ! Vertical velocity and level width + real(kind_phys) :: w(1:ncol,1:nlev) !< m s-1 + real(kind_phys) :: dz(1:ncol,1:nlev) !< m + ! Rain/snow/graupel fall amounts + real(kind_phys) :: rain_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: graupel_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: ice_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: snow_mp(1:ncol) ! mm, dummy, not used + real(kind_phys) :: delta_rain_mp(1:ncol) ! mm + real(kind_phys) :: delta_graupel_mp(1:ncol) ! mm + real(kind_phys) :: delta_ice_mp(1:ncol) ! mm + real(kind_phys) :: delta_snow_mp(1:ncol) ! mm + + real(kind_phys) :: pfils(1:ncol,1:nlev,1) + real(kind_phys) :: pflls(1:ncol,1:nlev,1) + ! Radar reflectivity + logical :: diagflag ! must be true if do_radar_ref is true, not used otherwise + integer :: do_radar_ref_mp ! integer instead of logical do_radar_ref + ! Effective cloud radii - turned off in CCPP (taken care off in radiation) + logical, parameter :: do_effective_radii = .false. + integer, parameter :: has_reqc = 0 + integer, parameter :: has_reqi = 0 + integer, parameter :: has_reqs = 0 + integer, parameter :: kme_stoch = 1 + integer :: spp_mp_opt + ! Dimensions used in mp_gt_driver + integer :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + ! Pointer arrays for extended diagnostics + !real(kind_phys), dimension(:,:,:), pointer :: vts1 => null() + !real(kind_phys), dimension(:,:,:), pointer :: txri => null() + !real(kind_phys), dimension(:,:,:), pointer :: txrc => null() + real(kind_phys), dimension(:,:,:), pointer :: prw_vcdc => null() + real(kind_phys), dimension(:,:,:), pointer :: prw_vcde => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_inu => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_ide_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_ide_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_ide => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_sde_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_sde_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_gde_d => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_gde_s => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_iha => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_wfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tpri_rfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rfz => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_scw => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_scw => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rcs => null() + real(kind_phys), dimension(:,:,:), pointer :: tprs_rcs => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rci => null() + real(kind_phys), dimension(:,:,:), pointer :: tprg_rcg => null() + real(kind_phys), dimension(:,:,:), pointer :: tprw_vcd_c => null() + real(kind_phys), dimension(:,:,:), pointer :: tprw_vcd_e => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_sml => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_gml => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rcg => null() + real(kind_phys), dimension(:,:,:), pointer :: tprr_rcs => null() + real(kind_phys), dimension(:,:,:), pointer :: tprv_rev => null() + real(kind_phys), dimension(:,:,:), pointer :: tten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qvten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qrten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qsten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qgten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qiten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: niten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: nrten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: ncten3 => null() + real(kind_phys), dimension(:,:,:), pointer :: qcten3 => null() + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + + if (is_hail_aware .and. sedi_semi) then + write(errmsg, fmt='((a))') 'Cannot use hail-aware TEMPO with sedi_semi... plese set sedi_semi=.false.' + errflg = 1 + return + endif + + if (first_time_step .and. istep==1 .and. blkno==1) then + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_tempo_run called before mp_tempo_init' + errflg = 1 + return + end if + ! Check forr optional arguments of aerosol-aware microphysics + if (is_aerosol_aware .and. .not. (present(nc) .and. & + present(nwfa) .and. & + present(nifa) .and. & + present(nwfa2d) .and. & + present(nifa2d) )) then + write(errmsg,fmt='(*(a))') 'Logic error in mp_tempo_run:', & + ' aerosol-aware microphysics require all of the', & + ' following optional arguments:', & + ' nc, nwfa, nifa, nwfa2d, nifa2d' + errflg = 1 + return + else if (merra2_aerosol_aware .and. .not. (present(nc) .and. & + present(nwfa) .and. & + present(nifa) )) then + write(errmsg,fmt='(*(a))') 'Logic error in mp_tempo_run:', & + ' merra2 aerosol-aware microphysics require the', & + ' following optional arguments: nc, nwfa, nifa' + errflg = 1 + return + end if + ! Consistency cheecks - subcycling and inner loop at the same time are not supported + if (nsteps>1 .and. dt_inner < dtp) then + write(errmsg,'(*(a))') "Logic error: Subcycling and inner loop cannot be used at the same time" + errflg = 1 + return + else if (mpirank==mpiroot .and. nsteps>1) then + write(*,'(a,i0,a,a,f6.2,a)') 'TEMPO MP is using ', nsteps, ' substep(s) per time step with an ', & + 'effective time step of ', dtp/real(nsteps, kind=kind_phys), ' seconds' + else if (mpirank==mpiroot .and. dt_inner < dtp) then + ndt = max(nint(dtp/dt_inner),1) + write(*,'(a,i0,a,a,f6.2,a)') 'TEMPO MP is using ', ndt, ' inner loops per time step with an ', & + 'effective time step of ', dtp/real(ndt, kind=kind_phys), ' seconds' + end if + end if + + ! Set stochastic physics selection to apply all perturbations + if ( spp_mp==7 ) then + spp_mp_opt=7 + else + spp_mp_opt=0 + endif + + ! Set reduced time step if subcycling is used + if (nsteps>1) then + dtstep = dtp/real(nsteps, kind=kind_phys) + else + dtstep = dtp + end if + if (merra2_aerosol_aware) then + call get_niwfa(aerfld, nifa, nwfa, ncol, nlev) + end if + + !> - Convert specific humidity to water vapor mixing ratio. + !> - Also, hydrometeor variables are mass or number mixing ratio + !> - either kg of species per kg of dry air, or per kg of (dry + vapor). + + ! DH* - do this only if istep == 1? Would be ok if it was + ! guaranteed that nothing else in the same subcycle group + ! was using these arrays, but it is somewhat dangerous. + qv = spechum/(1.0_kind_phys-spechum) + + if (convert_dry_rho) then + qc = qc/(1.0_kind_phys-spechum) + qr = qr/(1.0_kind_phys-spechum) + qi = qi/(1.0_kind_phys-spechum) + qs = qs/(1.0_kind_phys-spechum) + qg = qg/(1.0_kind_phys-spechum) + + ni = ni/(1.0_kind_phys-spechum) + nr = nr/(1.0_kind_phys-spechum) + if (is_hail_aware) then + chw = chw/(1.0_kind_phys-spechum) + vh = vh/(1.0_kind_phys-spechum) + endif + if (is_aerosol_aware .or. merra2_aerosol_aware) then + nc = nc/(1.0_kind_phys-spechum) + nwfa = nwfa/(1.0_kind_phys-spechum) + nifa = nifa/(1.0_kind_phys-spechum) + end if + end if + ! *DH + + !> - Density of air in kg m-3 + rho = con_eps*prsl/(con_rd*tgrs*(qv+con_eps)) + + !> - Convert omega in Pa s-1 to vertical velocity w in m s-1 + w = -omega/(rho*con_g) + + !> - Layer width in m from geopotential in m2 s-2 + dz = (phii(:,2:nlev+1) - phii(:,1:nlev)) / con_g + + ! Accumulated values inside Thompson scheme, not used; + ! only use delta and add to inout variables (different units) + rain_mp = 0 + graupel_mp = 0 + ice_mp = 0 + snow_mp = 0 + delta_rain_mp = 0 + delta_graupel_mp = 0 + delta_ice_mp = 0 + delta_snow_mp = 0 + + ! Flags for calculating radar reflectivity; diagflag is redundant + if (do_radar_ref) then + diagflag = .true. + do_radar_ref_mp = 1 + else + diagflag = .false. + do_radar_ref_mp = 0 + end if + + ! Set internal dimensions + ids = 1 + ims = 1 + its = 1 + ide = ncol + ime = ncol + ite = ncol + jds = 1 + jms = 1 + jts = 1 + jde = 1 + jme = 1 + jte = 1 + kds = 1 + kms = 1 + kts = 1 + kde = nlev + kme = nlev + kte = nlev + if(cplchm) then + pfi_lsan = 0.0 + pfl_lsan = 0.0 + end if + + ! Set pointers for extended diagnostics + set_extended_diagnostic_pointers: if (ext_diag) then + if (reset_diag3d) then + diag3d = 0.0 + end if + !vts1 => diag3d(:,:,X:X) + !txri => diag3d(:,:,X:X) + !txrc => diag3d(:,:,X:X) + prw_vcdc => diag3d(:,:,1:1) + prw_vcde => diag3d(:,:,2:2) + tpri_inu => diag3d(:,:,3:3) + tpri_ide_d => diag3d(:,:,4:4) + tpri_ide_s => diag3d(:,:,5:5) + tprs_ide => diag3d(:,:,6:6) + tprs_sde_d => diag3d(:,:,7:7) + tprs_sde_s => diag3d(:,:,8:8) + tprg_gde_d => diag3d(:,:,9:9) + tprg_gde_s => diag3d(:,:,10:10) + tpri_iha => diag3d(:,:,11:11) + tpri_wfz => diag3d(:,:,12:12) + tpri_rfz => diag3d(:,:,13:13) + tprg_rfz => diag3d(:,:,14:14) + tprs_scw => diag3d(:,:,15:15) + tprg_scw => diag3d(:,:,16:16) + tprg_rcs => diag3d(:,:,17:17) + tprs_rcs => diag3d(:,:,18:18) + tprr_rci => diag3d(:,:,19:19) + tprg_rcg => diag3d(:,:,20:20) + tprw_vcd_c => diag3d(:,:,21:21) + tprw_vcd_e => diag3d(:,:,22:22) + tprr_sml => diag3d(:,:,23:23) + tprr_gml => diag3d(:,:,24:24) + tprr_rcg => diag3d(:,:,25:25) + tprr_rcs => diag3d(:,:,26:26) + tprv_rev => diag3d(:,:,27:27) + tten3 => diag3d(:,:,28:28) + qvten3 => diag3d(:,:,29:29) + qrten3 => diag3d(:,:,30:30) + qsten3 => diag3d(:,:,31:31) + qgten3 => diag3d(:,:,32:32) + qiten3 => diag3d(:,:,33:33) + niten3 => diag3d(:,:,34:34) + nrten3 => diag3d(:,:,35:35) + ncten3 => diag3d(:,:,36:36) + qcten3 => diag3d(:,:,37:37) + else + allocate(prw_vcdc (0,0,0)) + allocate(prw_vcde (0,0,0)) + allocate(tpri_inu (0,0,0)) + allocate(tpri_ide_d (0,0,0)) + allocate(tpri_ide_s (0,0,0)) + allocate(tprs_ide (0,0,0)) + allocate(tprs_sde_d (0,0,0)) + allocate(tprs_sde_s (0,0,0)) + allocate(tprg_gde_d (0,0,0)) + allocate(tprg_gde_s (0,0,0)) + allocate(tpri_iha (0,0,0)) + allocate(tpri_wfz (0,0,0)) + allocate(tpri_rfz (0,0,0)) + allocate(tprg_rfz (0,0,0)) + allocate(tprs_scw (0,0,0)) + allocate(tprg_scw (0,0,0)) + allocate(tprg_rcs (0,0,0)) + allocate(tprs_rcs (0,0,0)) + allocate(tprr_rci (0,0,0)) + allocate(tprg_rcg (0,0,0)) + allocate(tprw_vcd_c (0,0,0)) + allocate(tprw_vcd_e (0,0,0)) + allocate(tprr_sml (0,0,0)) + allocate(tprr_gml (0,0,0)) + allocate(tprr_rcg (0,0,0)) + allocate(tprr_rcs (0,0,0)) + allocate(tprv_rev (0,0,0)) + allocate(tten3 (0,0,0)) + allocate(qvten3 (0,0,0)) + allocate(qrten3 (0,0,0)) + allocate(qsten3 (0,0,0)) + allocate(qgten3 (0,0,0)) + allocate(qiten3 (0,0,0)) + allocate(niten3 (0,0,0)) + allocate(nrten3 (0,0,0)) + allocate(ncten3 (0,0,0)) + allocate(qcten3 (0,0,0)) + end if set_extended_diagnostic_pointers + !> - Call mp_gt_driver() with or without aerosols, with or without effective radii, ... + if (is_aerosol_aware) then + if (is_hail_aware) then + call tempo_3d_to_1d_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, qb=vh, ni=ni, nr=nr, & + nc=nc, ng=chw, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, dt_inner=dt_inner, & + sedi_semi=sedi_semi, decfl=decfl, lsm=islmsk, & + rainnc=rain_mp, rainncv=delta_rain_mp, & + snownc=snow_mp, snowncv=delta_snow_mp, & + icenc=ice_mp, icencv=delta_ice_mp, & + graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & + refl_10cm=refl_10cm, & + diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + max_hail_diam_sfc=max_hail_diam_sfc, & + has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & + aero_ind_fdb=aero_ind_fdb, rand_perturb_on=spp_mp_opt, & + kme_stoch=kme_stoch, & + rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & + spp_prt_list=spp_prt_list, n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & + fullradar_diag=fullradar_diag, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, pfils=pfils, pflls=pflls) + else + +! write(errmsg,'(*(a))') "TEMPO aerosol-aware UNTESTED -- DO NOT USE" +! errflg = 1 +! return + call tempo_3d_to_1d_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & + nc=nc, nwfa=nwfa, nifa=nifa, nwfa2d=nwfa2d, nifa2d=nifa2d, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, dt_inner=dt_inner, & + sedi_semi=sedi_semi, decfl=decfl, lsm=islmsk, & + rainnc=rain_mp, rainncv=delta_rain_mp, & + snownc=snow_mp, snowncv=delta_snow_mp, & + icenc=ice_mp, icencv=delta_ice_mp, & + graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & + refl_10cm=refl_10cm, & + diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + max_hail_diam_sfc=max_hail_diam_sfc, & + has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & + aero_ind_fdb=aero_ind_fdb, rand_perturb_on=spp_mp_opt, & + kme_stoch=kme_stoch, & + rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & + spp_prt_list=spp_prt_list, n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & + fullradar_diag=fullradar_diag, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, pfils=pfils, pflls=pflls) + ! ! vts1=vts1, txri=txri, txrc=txrc, & + ! prw_vcdc=prw_vcdc, & + ! prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + ! tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + ! tprs_sde_d=tprs_sde_d, & + ! tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + ! tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + ! tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + ! tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + ! tprs_rcs=tprs_rcs, & + ! tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + ! tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + ! tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + ! tprv_rev=tprv_rev, tten3=tten3, & + ! qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + ! qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + ! qcten3=qcten3, + endif + else if (merra2_aerosol_aware) then + write(errmsg,'(*(a))') "TEMPO aerosol-aware with MERRA2 UNTESTED -- DO NOT USE" + errflg = 1 + return + call tempo_3d_to_1d_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & + nc=nc, nwfa=nwfa, nifa=nifa, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, dt_inner=dt_inner, & + sedi_semi=sedi_semi, decfl=decfl, lsm=islmsk, & + rainnc=rain_mp, rainncv=delta_rain_mp, & + snownc=snow_mp, snowncv=delta_snow_mp, & + icenc=ice_mp, icencv=delta_ice_mp, & + graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & + refl_10cm=refl_10cm, & + diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + max_hail_diam_sfc=max_hail_diam_sfc, & + has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & + aero_ind_fdb=aero_ind_fdb, rand_perturb_on=spp_mp_opt, & + kme_stoch=kme_stoch, & + rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & + spp_prt_list=spp_prt_list, n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & + fullradar_diag=fullradar_diag, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, pfils=pfils, pflls=pflls) + ! ! vts1=vts1, txri=txri, txrc=txrc, & + ! prw_vcdc=prw_vcdc, & + ! prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + ! tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + ! tprs_sde_d=tprs_sde_d, & + ! tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + ! tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + ! tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + ! tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + ! tprs_rcs=tprs_rcs, & + ! tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + ! tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + ! tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + ! tprv_rev=tprv_rev, tten3=tten3, & + ! qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + ! qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + ! qcten3=qcten3, + else + call tempo_3d_to_1d_driver(qv=qv, qc=qc, qr=qr, qi=qi, qs=qs, qg=qg, ni=ni, nr=nr, & + tt=tgrs, p=prsl, w=w, dz=dz, dt_in=dtstep, dt_inner=dt_inner, & + sedi_semi=sedi_semi, decfl=decfl, lsm=islmsk, & + rainnc=rain_mp, rainncv=delta_rain_mp, & + snownc=snow_mp, snowncv=delta_snow_mp, & + icenc=ice_mp, icencv=delta_ice_mp, & + graupelnc=graupel_mp, graupelncv=delta_graupel_mp, sr=sr, & + refl_10cm=refl_10cm, & + diagflag=diagflag, do_radar_ref=do_radar_ref_mp, & + max_hail_diam_sfc=max_hail_diam_sfc, & + has_reqc=has_reqc, has_reqi=has_reqi, has_reqs=has_reqs, & + rand_perturb_on=spp_mp_opt, kme_stoch=kme_stoch, & + rand_pert=spp_wts_mp, spp_var_list=spp_var_list, & + spp_prt_list=spp_prt_list, n_var_spp=n_var_spp, & + spp_stddev_cutoff=spp_stddev_cutoff, & + ids=ids, ide=ide, jds=jds, jde=jde, kds=kds, kde=kde, & + ims=ims, ime=ime, jms=jms, jme=jme, kms=kms, kme=kme, & + its=its, ite=ite, jts=jts, jte=jte, kts=kts, kte=kte, & + fullradar_diag=fullradar_diag, istep=istep, nsteps=nsteps, & + first_time_step=first_time_step, errmsg=errmsg, errflg=errflg, & + ! Extended diagnostics + ext_diag=ext_diag, pfils=pfils, pflls=pflls) + !! vts1=vts1, txri=txri, txrc=txrc, & + ! prw_vcdc=prw_vcdc, & + ! prw_vcde=prw_vcde, tpri_inu=tpri_inu, tpri_ide_d=tpri_ide_d, & + ! tpri_ide_s=tpri_ide_s, tprs_ide=tprs_ide, & + ! tprs_sde_d=tprs_sde_d, & + ! tprs_sde_s=tprs_sde_s, tprg_gde_d=tprg_gde_d, & + ! tprg_gde_s=tprg_gde_s, tpri_iha=tpri_iha, & + ! tpri_wfz=tpri_wfz, tpri_rfz=tpri_rfz, tprg_rfz=tprg_rfz, & + ! tprs_scw=tprs_scw, tprg_scw=tprg_scw, tprg_rcs=tprg_rcs, & + ! tprs_rcs=tprs_rcs, & + ! tprr_rci=tprr_rci, tprg_rcg=tprg_rcg, tprw_vcd_c=tprw_vcd_c, & + ! tprw_vcd_e=tprw_vcd_e, tprr_sml=tprr_sml, tprr_gml=tprr_gml, & + ! tprr_rcg=tprr_rcg, tprr_rcs=tprr_rcs, & + ! tprv_rev=tprv_rev, tten3=tten3, & + ! qvten3=qvten3, qrten3=qrten3, qsten3=qsten3, qgten3=qgten3, & + ! qiten3=qiten3, niten3=niten3, nrten3=nrten3, ncten3=ncten3, & + ! qcten3=qcten3) + end if + if (errflg/=0) return + + ! DH* - do this only if istep == nsteps? Would be ok if it was + ! guaranteed that nothing else in the same subcycle group + ! was using these arrays, but it is somewhat dangerous. + + !> - Convert water vapor mixing ratio back to specific humidity + spechum = qv/(1.0_kind_phys+qv) + + if (convert_dry_rho) then + qc = qc/(1.0_kind_phys+qv) + qr = qr/(1.0_kind_phys+qv) + qi = qi/(1.0_kind_phys+qv) + qs = qs/(1.0_kind_phys+qv) + qg = qg/(1.0_kind_phys+qv) + + ni = ni/(1.0_kind_phys+qv) + nr = nr/(1.0_kind_phys+qv) + if (is_hail_aware) then + chw = chw/(1.0_kind_phys+qv) + vh = vh/(1.0_kind_phys+qv) + endif + if (is_aerosol_aware .or. merra2_aerosol_aware) then + nc = nc/(1.0_kind_phys+qv) + nwfa = nwfa/(1.0_kind_phys+qv) + nifa = nifa/(1.0_kind_phys+qv) + end if + end if + ! *DH + + !> - Convert rainfall deltas from mm to m (on physics timestep); add to inout variables + ! "rain" in Thompson MP refers to precipitation (total of liquid rainfall+snow+graupel+ice) + prcp = prcp + max(0.0, delta_rain_mp/1000.0_kind_phys) + graupel = graupel + max(0.0, delta_graupel_mp/1000.0_kind_phys) + ice = ice + max(0.0, delta_ice_mp/1000.0_kind_phys) + snow = snow + max(0.0, delta_snow_mp/1000.0_kind_phys) + rain = rain + max(0.0, (delta_rain_mp - (delta_graupel_mp + delta_ice_mp + delta_snow_mp))/1000.0_kind_phys) + + ! Recompute sr at last subcycling step + if (nsteps>1 .and. istep == nsteps) then + ! Unlike inside mp_gt_driver, rain does not contain frozen precip + sr = (snow + graupel + ice)/(rain + snow + graupel + ice +1.e-12) + end if + + ! output instantaneous ice/snow and rain water 3d precipitation fluxes + if(cplchm) then + pfi_lsan(:,:) = pfils(:,:,1) + pfl_lsan(:,:) = pflls(:,:,1) + end if + + ! DH* Not really needed because they go out of scope ... + ! But having them in here seems to cause problems with Intel? + ! It looked like this is also nullifying the pointers passed + ! from the CCPP caps. + !unset_extended_diagnostic_pointers: if (ext_diag) then + ! !vts1 => null() + ! !txri => null() + ! !txrc => null() + ! prw_vcdc => null() + ! prw_vcde => null() + ! tpri_inu => null() + ! tpri_ide_d => null() + ! tpri_ide_s => null() + ! tprs_ide => null() + ! tprs_sde_d => null() + ! tprs_sde_s => null() + ! tprg_gde_d => null() + ! tprg_gde_s => null() + ! tpri_iha => null() + ! tpri_wfz => null() + ! tpri_rfz => null() + ! tprg_rfz => null() + ! tprs_scw => null() + ! tprg_scw => null() + ! tprg_rcs => null() + ! tprs_rcs => null() + ! tprr_rci => null() + ! tprg_rcg => null() + ! tprw_vcd_c => null() + ! tprw_vcd_e => null() + ! tprr_sml => null() + ! tprr_gml => null() + ! tprr_rcg => null() + ! tprr_rcs => null() + ! tprv_rev => null() + ! tten3 => null() + ! qvten3 => null() + ! qrten3 => null() + ! qsten3 => null() + ! qgten3 => null() + ! qiten3 => null() + ! niten3 => null() + ! nrten3 => null() + ! ncten3 => null() + ! qcten3 => null() + !end if unset_extended_diagnostic_pointers + ! *DH + + end subroutine mp_tempo_run +!>@} + +!> \section arg_table_mp_tempo_finalize Argument Table +!! \htmlinclude mp_tempo_finalize.html +!! + subroutine mp_tempo_finalize(is_initialized, errmsg, errflg) + + implicit none + logical, intent(inout) :: is_initialized + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + + if (.not.is_initialized) return + + call tempo_finalize() + + is_initialized = .false. + + end subroutine mp_tempo_finalize + + subroutine get_niwfa(aerfld, nifa, nwfa, ncol, nlev) + ! To calculate nifa and nwfa from bins of aerosols. + ! In GOCART and MERRA2, aerosols are given as mixing ratio (kg/kg). To + ! convert from kg/kg to #/kg, the "unit mass" (mass of one particle) + ! within the mass bins is calculated. A lognormal size distribution + ! within aerosol bins is used to find the size based upon the median + ! mass. NIFA is mainly summarized over five dust bins and NWFA over the + ! other 10 bins. The parameters besides each bins are carefully tuned + ! for a good performance of the scheme. + ! + ! The fields for the last index of the aerfld array + ! are specified as below. + ! 1: dust bin 1, 0.1 to 1.0 micrometers + ! 2: dust bin 2, 1.0 to 1.8 micrometers + ! 3: dust bin 3, 1.8 to 3.0 micrometers + ! 4: dust bin 4, 3.0 to 6.0 micrometers + ! 5: dust bin 5, 6.0 to 10.0 micrometers + ! 6: sea salt bin 1, 0.03 to 0.1 micrometers + ! 7: sea salt bin 2, 0.1 to 0.5 micrometers + ! 8: sea salt bin 3, 0.5 to 1.5 micrometers + ! 9: sea salt bin 4, 1.5 to 5.0 micrometers + ! 10: sea salt bin 5, 5.0 to 10.0 micrometers + ! 11: Sulfate, 0.35 (mean) micrometers + ! 15: water-friendly organic carbon, 0.35 (mean) micrometers + ! + ! Bin densities are as follows: + ! 1: dust bin 1: 2500 kg/m2 + ! 2-5: dust bin 2-5: 2650 kg/m2 + ! 6-10: sea salt bins 6-10: 2200 kg/m2 + ! 11: sulfate: 1700 kg/m2 + ! 15: organic carbon: 1800 kg/m2 + + implicit none + integer, intent(in)::ncol, nlev + real (kind=kind_phys), dimension(:,:,:), intent(in) :: aerfld + real (kind=kind_phys), dimension(:,:), intent(out ):: nifa, nwfa + + nifa=(aerfld(:,:,1)/4.0737762+aerfld(:,:,2)/30.459203+aerfld(:,:,3)/153.45048+ & + aerfld(:,:,4)/1011.5142+ aerfld(:,:,5)/5683.3501)*1.e15 + + nwfa=((aerfld(:,:,6)/0.0045435214+aerfld(:,:,7)/0.2907854+aerfld(:,:,8)/12.91224+ & + aerfld(:,:,9)/206.2216+ aerfld(:,:,10)/4326.23)*9.+aerfld(:,:,11)/0.3053104*5+ & + aerfld(:,:,15)/0.3232698*8)*1.e15 + end subroutine get_niwfa + +end module mp_tempo diff --git a/physics/MP/TEMPO/mp_tempo.meta b/physics/MP/TEMPO/mp_tempo.meta new file mode 100644 index 000000000..0bac3e856 --- /dev/null +++ b/physics/MP/TEMPO/mp_tempo.meta @@ -0,0 +1,981 @@ +[ccpp-table-properties] + name = mp_tempo + type = scheme + dependencies = ../../hooks/machine.F + dependencies = ../module_mp_radar.F90 + dependencies = TEMPO/module_mp_tempo_params.F90 + dependencies = TEMPO/module_mp_tempo_utils.F90 + dependencies = TEMPO/module_mp_tempo_main.F90 + dependencies = module_mp_tempo.F90 + +######################################################################## +[ccpp-arg-table] + name = mp_tempo_init + type = scheme +[ncol] + standard_name = horizontal_dimension + long_name = horizontal dimension + units = count + dimensions = () + type = integer + intent = in +[nlev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[con_pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[con_t0c] + standard_name = temperature_at_zero_celsius + long_name = temperature at 0 degrees Celsius + units = K + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rv] + standard_name = gas_constant_water_vapor + long_name = ideal gas constant for water vapor + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_cp] + standard_name = specific_heat_of_dry_air_at_constant_pressure + long_name = specific heat of dry air at constant pressure + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rgas] + standard_name = molar_gas_constant + long_name = universal ideal molar gas constant + units = J K-1 mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_boltz] + standard_name = boltzmann_constant + long_name = Boltzmann constant + units = J K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amd] + standard_name = molecular_weight_of_dry_air + long_name = molecular weight of dry air + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_amw] + standard_name = molecular_weight_of_water_vapor + long_name = molecular weight of water vapor + units = g mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_avgd] + standard_name = avogadro_consant + long_name = Avogadro constant + units = mol-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hvap] + standard_name = latent_heat_of_vaporization_of_water_at_0C + long_name = latent heat of evaporation/sublimation + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_hfus] + standard_name = latent_heat_of_fusion_of_water_at_0C + long_name = latent heat of fusion + units = J kg-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[restart] + standard_name = flag_for_restart + long_name = flag for restart (warmstart) or coldstart + units = flag + dimensions = () + type = logical + intent = in +[imp_physics] + standard_name = control_for_microphysics_scheme + long_name = choice of microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[imp_physics_tempo] + standard_name = identifier_for_tempo_microphysics_scheme + long_name = choice of TEMPO microphysics scheme + units = flag + dimensions = () + type = integer + intent = in +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in +[spechum] + standard_name = specific_humidity + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qc] + standard_name = cloud_liquid_water_mixing_ratio + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qr] + standard_name = rain_mixing_ratio + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qi] + standard_name = cloud_ice_mixing_ratio + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qs] + standard_name = snow_mixing_ratio + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qg] + standard_name = graupel_mixing_ratio + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[chw] + standard_name = mass_number_concentration_of_graupel_in_air + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[vh] + standard_name = graupel_volume + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[ni] + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[nr] + standard_name = mass_number_concentration_of_rain_water_in_air + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[is_aerosol_aware] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol-aware physics + units = flag + dimensions = () + type = logical + intent = in +[is_hail_aware] + standard_name = flag_for_hail_physics + long_name = flag for hail-aware physics + units = flag + dimensions = () + type = logical + intent = in +[merra2_aerosol_aware] + standard_name = do_merra2_aerosol_awareness + long_name = flag for merra2 aerosol-aware physics for example the thompson microphysics + units = flag + dimensions = () + type = logical + intent = in +[nc] + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[nwfa2d] + standard_name = tendency_of_hygroscopic_aerosols_at_surface_adjacent_layer + long_name = instantaneous fake water-friendly surface aerosol source + units = kg-1 s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[nifa2d] + standard_name = tendency_of_nonhygroscopic_ice_nucleating_aerosols_at_surface_adjacent_layer + long_name = instantaneous fake ice-friendly surface aerosol source + units = kg-1 s-1 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[nwfa] + standard_name = mass_number_concentration_of_hygroscopic_aerosols + long_name = number concentration of water-friendly aerosols + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[nifa] + standard_name = mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols + long_name = number concentration of ice-friendly aerosols + units = kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[tgrs] + standard_name = air_temperature + long_name = model layer mean temperature + units = K + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[phil] + standard_name = geopotential + long_name = geopotential at model layer centers + units = m2 s-2 + dimensions = (horizontal_dimension,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[area] + standard_name = cell_area + long_name = area of the grid cell + units = m2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in +[aerfld] + standard_name = mass_mixing_ratio_of_aerosol_from_gocart_or_merra2 + long_name = mass mixing ratio of aerosol from gocart or merra2 + units = kg kg-1 + dimensions = (horizontal_dimension,vertical_layer_dimension,number_of_aerosol_tracers_MG) + type = real + kind = kind_phys + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = MPI_Comm + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[threads] + standard_name = number_of_openmp_threads + long_name = number of OpenMP threads available to scheme + units = count + dimensions = () + type = integer + intent = in +[ext_diag] + standard_name = flag_for_extended_diagnostic_output_from_thompson_microphysics + long_name = flag for extended diagnostic output from thompson microphysics + units = flag + dimensions = () + type = logical + intent = in +[diag3d] + standard_name = extended_diagnostics_output_from_thompson_microphysics + long_name = set of 3d arrays for extended diagnostics output from thompson microphysics + units = none + dimensions = (horizontal_dimension,vertical_layer_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) + type = real + kind = kind_phys + intent = in + optional = True +[is_initialized] + standard_name = flag_for_thompson_mp_scheme_initialization + long_name = flag carrying scheme initialization status + units = flag + dimensions = () + type = logical + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = mp_tempo_run + type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[nlev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[con_g] + standard_name = gravitational_acceleration + long_name = gravitational acceleration + units = m s-2 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_rd] + standard_name = gas_constant_of_dry_air + long_name = ideal gas constant for dry air + units = J kg-1 K-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[con_eps] + standard_name = ratio_of_dry_air_to_water_vapor_gas_constants + long_name = rd/rv + units = none + dimensions = () + type = real + kind = kind_phys + intent = in +[convert_dry_rho] + standard_name = flag_for_converting_hydrometeors_from_moist_to_dry_air + long_name = flag for converting hydrometeors from moist to dry air + units = flag + dimensions = () + type = logical + intent = in +[spechum] + standard_name = specific_humidity_of_new_state + long_name = water vapor specific humidity + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qc] + standard_name = cloud_liquid_water_mixing_ratio_of_new_state + long_name = cloud water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qr] + standard_name = rain_mixing_ratio_of_new_state + long_name = rain water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qi] + standard_name = cloud_ice_mixing_ratio_of_new_state + long_name = ice water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qs] + standard_name = snow_mixing_ratio_of_new_state + long_name = snow water mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[qg] + standard_name = graupel_mixing_ratio_of_new_state + long_name = graupel mixing ratio wrt dry+vapor (no condensates) + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[chw] + standard_name = mass_number_concentration_of_graupel_of_new_state + long_name = graupel number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[vh] + standard_name = graupel_volume_of_new_state + long_name = graupel particle volume + units = m3 kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[ni] + standard_name = mass_number_concentration_of_cloud_ice_water_crystals_in_air_of_new_state + long_name = ice number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[nr] + standard_name = mass_number_concentration_of_rain_of_new_state + long_name = rain number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[is_aerosol_aware] + standard_name = flag_for_aerosol_physics + long_name = flag for aerosol-aware physics + units = flag + dimensions = () + type = logical + intent = in +[is_hail_aware] + standard_name = flag_for_hail_physics + long_name = flag for hail-aware physics + units = flag + dimensions = () + type = logical + intent = in +[merra2_aerosol_aware] + standard_name = do_merra2_aerosol_awareness + long_name = flag for merra2 aerosol-aware physics for example the thompson microphysics + units = flag + dimensions = () + type = logical + intent = in +[nc] + standard_name = mass_number_concentration_of_cloud_liquid_water_particles_in_air_of_new_state + long_name = cloud droplet number concentration + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[nwfa] + standard_name = mass_number_concentration_of_hygroscopic_aerosols_of_new_state + long_name = number concentration of water-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[nifa] + standard_name = mass_number_concentration_of_nonhygroscopic_ice_nucleating_aerosols_of_new_state + long_name = number concentration of ice-friendly aerosols + units = kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[nwfa2d] + standard_name = tendency_of_hygroscopic_aerosols_at_surface_adjacent_layer + long_name = instantaneous fake water-friendly surface aerosol source + units = kg-1 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[nifa2d] + standard_name = tendency_of_nonhygroscopic_ice_nucleating_aerosols_at_surface_adjacent_layer + long_name = instantaneous fake ice-friendly surface aerosol source + units = kg-1 s-1 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[aero_ind_fdb] + standard_name = do_smoke_aerosol_indirect_feedback + long_name = flag for wfa ifa emission indirect feedback + units = flag + dimensions = () + type = logical + intent = in +[tgrs] + standard_name = air_temperature_of_new_state + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[prsl] + standard_name = air_pressure + long_name = mean layer pressure + units = Pa + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[phii] + standard_name = geopotential_at_interface + long_name = geopotential at model layer interfaces + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_interface_dimension) + type = real + kind = kind_phys + intent = in +[omega] + standard_name = lagrangian_tendency_of_air_pressure + long_name = layer mean vertical velocity + units = Pa s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[sedi_semi] + standard_name = flag_for_semi_Lagrangian_sedi_rain + long_name = flag for semi Lagrangian sedi of rain + units = flag + dimensions = () + type = logical + intent = in +[decfl] + standard_name = deformed_CFL_factor + long_name = deformed CFL factor + units = count + dimensions = () + type = integer + intent = in +[islmsk] + standard_name = sea_land_ice_mask + long_name = sea/land/ice mask (=0/1/2) + units = flag + dimensions = (horizontal_loop_extent) + type = integer + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[dt_inner] + standard_name = time_step_for_inner_loop + long_name = time step for inner loop + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[first_time_step] + standard_name = flag_for_first_timestep + long_name = flag for first time step for time integration loop (cold/warmstart) + units = flag + dimensions = () + type = logical + intent = in +[istep] + standard_name = ccpp_loop_counter + long_name = loop counter for subcycling loops in CCPP + units = index + dimensions = () + type = integer + intent = in +[nsteps] + standard_name = ccpp_loop_extent + long_name = loop extent for subcycling loops in CCPP + units = count + dimensions = () + type = integer + intent = in +[prcp] + standard_name = lwe_thickness_of_explicit_precipitation_amount + long_name = explicit precipitation (rain, ice, snow, graupel) on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[rain] + standard_name = lwe_thickness_of_explicit_rain_amount + long_name = explicit rain fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = True +[graupel] + standard_name = lwe_thickness_of_graupel_amount + long_name = graupel fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = True +[ice] + standard_name = lwe_thickness_of_ice_amount + long_name = ice fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = True +[snow] + standard_name = lwe_thickness_of_snow_amount + long_name = snow fall on physics timestep + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout + optional = True +[sr] + standard_name = ratio_of_snowfall_to_rainfall + long_name = ratio of snowfall to large-scale rainfall + units = frac + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = out +[refl_10cm] + standard_name = radar_reflectivity_10cm + long_name = instantaneous refl_10cm + units = dBZ + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[max_hail_diam_sfc] + standard_name = max_hail_diameter_sfc + long_name = instantaneous maximum hail diameter at lowest model level + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = inout +[fullradar_diag] + standard_name = do_full_radar_reflectivity + long_name = flag for computing full radar reflectivity + units = flag + dimensions = () + type = logical + intent = in +[do_radar_ref] + standard_name = flag_for_radar_reflectivity + long_name = flag for radar reflectivity + units = flag + dimensions = () + type = logical + intent = in +[aerfld] + standard_name = mass_mixing_ratio_of_aerosol_from_gocart_or_merra2 + long_name = mass mixing ratio of aerosol from gocart or merra2 + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_aerosol_tracers_MG) + type = real + kind = kind_phys + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = MPI_Comm + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[blkno] + standard_name = ccpp_block_number + long_name = number of block for explicit data blocking in CCPP + units = index + dimensions = () + type = integer + intent = in +[ext_diag] + standard_name = flag_for_extended_diagnostic_output_from_thompson_microphysics + long_name = flag for extended diagnostic output from thompson microphysics + units = flag + dimensions = () + type = logical + intent = in +[diag3d] + standard_name = extended_diagnostics_output_from_thompson_microphysics + long_name = set of 3d arrays for extended diagnostics output from thompson microphysics + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension,number_of_3d_diagnostic_output_arrays_from_thompson_microphysics) + type = real + kind = kind_phys + intent = inout + optional = True +[reset_diag3d] + standard_name = flag_reset_extended_diagnostics_output_arrays_from_thompson_microphysics + long_name = flag for resetting extended diagnostics output arrays from thompson microphysics + units = flag + dimensions = () + type = logical + intent = in +[spp_wts_mp] + standard_name = spp_weights_for_microphysics_scheme + long_name = spp weights for microphysics scheme + units = 1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + intent = in + optional = True +[spp_mp] + standard_name = control_for_microphysics_spp_perturbations + long_name = control for microphysics spp perturbations + units = count + dimensions = () + type = integer + intent = in +[n_var_spp] + standard_name = number_of_perturbed_spp_schemes + long_name = number of perturbed spp schemes + units = count + dimensions = () + type = integer + intent = in +[spp_prt_list] + standard_name = magnitude_of_spp_perturbations + long_name = magnitude of spp perturbations + units = 1 + dimensions = (number_of_perturbed_spp_schemes) + type = real + kind = kind_phys + intent = in + optional = True +[spp_stddev_cutoff] + standard_name = magnitude_of_spp_standard_deviation_cutoff + long_name = magnitude of spp standard deviation cutoff + units = 1 + dimensions = (number_of_perturbed_spp_schemes) + type = real + kind = kind_phys + intent = in + optional = True +[spp_var_list] + standard_name = perturbed_spp_schemes + long_name = perturbed spp schemes + units = none + dimensions = (number_of_perturbed_spp_schemes) + type = character + kind = len=10 + intent = in + optional = True +[cplchm] + standard_name = flag_for_chemistry_coupling + long_name = flag controlling cplchm collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[pfi_lsan] + standard_name = ice_flux_due_to_large_scale_precipitation + long_name = instantaneous 3D flux of ice from nonconvective precipitation + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[pfl_lsan] + standard_name = liquid_flux_due_to_large_scale_precipitation + long_name = instantaneous 3D flux of liquid water from nonconvective precipitation + units = kg m-2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout + optional = True +[is_initialized] + standard_name = flag_for_thompson_mp_scheme_initialization + long_name = flag carrying scheme initialization status + units = flag + dimensions = () + type = logical + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = mp_tempo_finalize + type = scheme +[is_initialized] + standard_name = flag_for_thompson_mp_scheme_initialization + long_name = flag carrying scheme initialization status + units = flag + dimensions = () + type = logical + intent = inout +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/MP/TEMPO/mp_tempo_post.F90 b/physics/MP/TEMPO/mp_tempo_post.F90 new file mode 100644 index 000000000..e8b531f83 --- /dev/null +++ b/physics/MP/TEMPO/mp_tempo_post.F90 @@ -0,0 +1,150 @@ +module mp_tempo_post + + use mpi_f08 + use machine, only : kind_phys + + implicit none + + public :: mp_tempo_post_init, mp_tempo_post_run, mp_tempo_post_finalize + + private + + logical :: is_initialized = .false. + + logical :: apply_limiter + +contains + +!! \section arg_table_mp_tempo_post_init Argument Table +!! \htmlinclude mp_tempo_post_init.html +!! + subroutine mp_tempo_post_init(ttendlim, errmsg, errflg) + + implicit none + + ! Interface variables + real(kind_phys), intent(in) :: ttendlim + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Local variables + integer :: i + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Check initialization state + if (is_initialized) return + + if (ttendlim < 0) then + apply_limiter = .false. + else + apply_limiter = .true. + end if + + is_initialized = .true. + + end subroutine mp_tempo_post_init + +!> \section arg_table_mp_tempo_post_run Argument Table +!! \htmlinclude mp_tempo_post_run.html +!! + subroutine mp_tempo_post_run(ncol, nlev, tgrs_save, tgrs, prslk, dtp, ttendlim, & + kdt, mpicomm, mpirank, mpiroot, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in) :: ncol + integer, intent(in) :: nlev + real(kind_phys), dimension(:,:), intent(in) :: tgrs_save + real(kind_phys), dimension(:,:), intent(inout) :: tgrs + real(kind_phys), dimension(:,:), intent(in) :: prslk + real(kind_phys), intent(in) :: dtp + real(kind_phys), intent(in) :: ttendlim + integer, intent(in) :: kdt + ! MPI information + type(MPI_Comm), intent(in ) :: mpicomm + integer, intent(in ) :: mpirank + integer, intent(in ) :: mpiroot + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Local variables + real(kind_phys), dimension(1:ncol,1:nlev) :: mp_tend + integer :: i, k +#ifdef DEBUG + integer :: events +#endif + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Check initialization state + if (.not.is_initialized) then + write(errmsg, fmt='((a))') 'mp_tempo_post_run called before mp_tempo_post_init' + errflg = 1 + return + end if + + ! If limiter is deactivated, return immediately + if (.not.apply_limiter) return + + ! mp_tend and ttendlim are expressed in potential temperature + mp_tend = (tgrs - tgrs_save)/prslk + +#ifdef DEBUG + events = 0 +#endif + do k=1,nlev + do i=1,ncol + mp_tend(i,k) = max( -ttendlim*dtp, min( ttendlim*dtp, mp_tend(i,k) ) ) + +#ifdef DEBUG + if (tgrs_save(i,k) + mp_tend(i,k)*prslk(i,k) .ne. tgrs(i,k)) then + write(0,'(a,3i6,3e16.7)') "mp_tempo_post_run mp_tend limiter: kdt, i, k, t_old, t_new, t_lim:", & + & kdt, i, k, tgrs_save(i,k), tgrs(i,k), tgrs_save(i,k) + mp_tend(i,k)*prslk(i,k) + events = events + 1 + end if +#endif + tgrs(i,k) = tgrs_save(i,k) + mp_tend(i,k)*prslk(i,k) + end do + end do + +#ifdef DEBUG + if (events > 0) then + write(0,'(a,i0,a,i0,a,i0)') "mp_tempo_post_run: ttendlim applied ", events, "/", nlev*ncol, & + & " times at timestep ", kdt + end if +#endif + + end subroutine mp_tempo_post_run + +!! \section arg_table_mp_tempo_post_finalize Argument Table +!! \htmlinclude mp_tempo_post_finalize.html +!! + subroutine mp_tempo_post_finalize(errmsg, errflg) + + implicit none + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! initialize ccpp error handling variables + errmsg = '' + errflg = 0 + + ! Check initialization state + if (.not. is_initialized) return + + is_initialized = .false. + + end subroutine mp_tempo_post_finalize + +end module mp_tempo_post diff --git a/physics/MP/TEMPO/mp_tempo_post.meta b/physics/MP/TEMPO/mp_tempo_post.meta new file mode 100644 index 000000000..e51edbf27 --- /dev/null +++ b/physics/MP/TEMPO/mp_tempo_post.meta @@ -0,0 +1,154 @@ +[ccpp-table-properties] + name = mp_tempo_post + type = scheme + dependencies = ../../hooks/machine.F + +######################################################################## +[ccpp-arg-table] + name = mp_tempo_post_init + type = scheme +[ttendlim] + standard_name = max_tendency_of_air_potential_temperature_due_to_large_scale_precipitation + long_name = temperature tendency limiter per physics time step + units = K s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = mp_tempo_post_run + type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[nlev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[tgrs_save] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tgrs] + standard_name = air_temperature_of_new_state + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = inout +[prslk] + standard_name = dimensionless_exner_function + long_name = dimensionless Exner function at model layer centers + units = none + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[dtp] + standard_name = timestep_for_physics + long_name = physics timestep + units = s + dimensions = () + type = real + kind = kind_phys + intent = in +[ttendlim] + standard_name = max_tendency_of_air_potential_temperature_due_to_large_scale_precipitation + long_name = temperature tendency limiter per physics time step + units = K s-1 + dimensions = () + type = real + kind = kind_phys + intent = in +[kdt] + standard_name = index_of_timestep + long_name = current forecast iteration + units = index + dimensions = () + type = integer + intent = in +[mpicomm] + standard_name = mpi_communicator + long_name = MPI communicator + units = index + dimensions = () + type = MPI_Comm + intent = in +[mpirank] + standard_name = mpi_rank + long_name = current MPI-rank + units = index + dimensions = () + type = integer + intent = in +[mpiroot] + standard_name = mpi_root + long_name = master MPI-rank + units = index + dimensions = () + type = integer + intent = in +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out + +######################################################################## +[ccpp-arg-table] + name = mp_tempo_post_finalize + type = scheme +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/MP/TEMPO/mp_tempo_pre.F90 b/physics/MP/TEMPO/mp_tempo_pre.F90 new file mode 100644 index 000000000..1e5b7b92d --- /dev/null +++ b/physics/MP/TEMPO/mp_tempo_pre.F90 @@ -0,0 +1,44 @@ +!>\file mp_tempo_pre.F90 +!! + +! CCPP license goes here, as well as further documentation +!>\ingroup aatempo +module mp_tempo_pre + + use machine, only : kind_phys + + implicit none + + public :: mp_tempo_pre_run + + private + + contains + +!> \section arg_table_mp_tempo_pre_run Argument Table +!! \htmlinclude mp_tempo_pre_run.html +!! + subroutine mp_tempo_pre_run(ncol, nlev, tgrs, tgrs_save, errmsg, errflg) + + implicit none + + ! Interface variables + integer, intent(in ) :: ncol + integer, intent(in ) :: nlev + real(kind_phys), intent(in ) :: tgrs(:,:) + real(kind_phys), intent( out) :: tgrs_save(:,:) + + ! CCPP error handling + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Initialize the CCPP error handling variables + errmsg = '' + errflg = 0 + + ! Save current air temperature for tendency limiters in mp_tempo_post + tgrs_save = tgrs + + end subroutine mp_tempo_pre_run + +end module mp_tempo_pre diff --git a/physics/MP/TEMPO/mp_tempo_pre.meta b/physics/MP/TEMPO/mp_tempo_pre.meta new file mode 100644 index 000000000..2c6b44c34 --- /dev/null +++ b/physics/MP/TEMPO/mp_tempo_pre.meta @@ -0,0 +1,54 @@ +[ccpp-table-properties] + name = mp_tempo_pre + type = scheme + dependencies = ../../hooks/machine.F + +######################################################################## +[ccpp-arg-table] + name = mp_tempo_pre_run + type = scheme +[ncol] + standard_name = horizontal_loop_extent + long_name = horizontal loop extent + units = count + dimensions = () + type = integer + intent = in +[nlev] + standard_name = vertical_layer_dimension + long_name = number of vertical levels + units = count + dimensions = () + type = integer + intent = in +[tgrs] + standard_name = air_temperature_of_new_state + long_name = model layer mean temperature + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[tgrs_save] + standard_name = air_temperature_save + long_name = air temperature before entering a physics scheme + units = K + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[errmsg] + standard_name = ccpp_error_message + long_name = error message for error handling in CCPP + units = none + dimensions = () + type = character + kind = len=* + intent = out +[errflg] + standard_name = ccpp_error_code + long_name = error code for error handling in CCPP + units = 1 + dimensions = () + type = integer + intent = out diff --git a/physics/MP/GFDL/multi_gases.F90 b/physics/MP/multi_gases.F90 similarity index 100% rename from physics/MP/GFDL/multi_gases.F90 rename to physics/MP/multi_gases.F90 diff --git a/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 b/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 index 9e3d14cd7..509c50c45 100644 --- a/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 +++ b/physics/PBL/MYNN_EDMF/module_bl_mynn.F90 @@ -2628,7 +2628,7 @@ SUBROUTINE mym_turbulence ( & & sh, sm, & & El, & & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, & - & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & + & qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, & & tke_budget, & & Psig_bl,Psig_shcu,cldfra_bl1D, & & bl_mynn_mixlength, & diff --git a/physics/PBL/SATMEDMF/mfscuq.f b/physics/PBL/SATMEDMF/mfscuq.f index b2a48d1b6..e9be00026 100644 --- a/physics/PBL/SATMEDMF/mfscuq.f +++ b/physics/PBL/SATMEDMF/mfscuq.f @@ -15,7 +15,9 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix, & thlx,thvx,thlvx,gdx,thetae, & krad,mrad,radmin,buo,wush,tkemean,vez0fun,xmfd, - & tcdo,qcdo,ucdo,vcdo,xlamdeq,a1) + & tcdo,qcdo,ucdo,vcdo,xlamdeq,a1, +!The following flag is for SA-3D-TKE (kyf) + & sa3dtke) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -31,6 +33,7 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, integer krad(im), mrad(im) ! logical cnvflg(im) + logical sa3dtke !flag for SA-3D-TKE scheme (kyf) real(kind=kind_phys) delt real(kind=kind_phys) q1(ix,km,ntrac1),t1(ix,km), & u1(ix,km), v1(ix,km), @@ -427,6 +430,16 @@ subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, endif enddo ! +!> - Set updraft fraction to 0 when using SA-3D-TKE scheme (kyf) +!! Scale-aware capability is done with pfnl in satmedmfvdifq.F +!! Zhu et al. (2025) +! + if (sa3dtke) then + do i = 1, im + sigma(i) = 0. + enddo + endif +! !> - Compute scale-aware function based on !! Arakawa and Wu (2013) \cite arakawa_and_wu_2013 ! diff --git a/physics/PBL/SATMEDMF/satmedmfvdifq.F b/physics/PBL/SATMEDMF/satmedmfvdifq.F index 64e7bc32d..818ead5e9 100644 --- a/physics/PBL/SATMEDMF/satmedmfvdifq.F +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.F @@ -7,6 +7,9 @@ module satmedmfvdifq use mfpbltq_mod use tridi_mod use mfscuq_mod + !PCC_CANOPY_utilities + use canopy_utils_mod + contains !> \defgroup module_satmedmfvdifq GFS TKE-EDMF PBL Module @@ -74,7 +77,9 @@ end subroutine satmedmfvdifq_init !! (mfscuq.f). !! \section detail_satmedmfvidfq GFS satmedmfvdifq Detailed Algorithm subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & - & ntiw,ntke,grav,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & + & ntiw,ntke,grav,pi,rd,cp,rv,hvap,hfus,fv,eps,epsm1, & +!The following three variables are for SA-3D-TKE + & def_1,def_2,def_3,sa3dtke,dku3d_h,dku3d_e, & & dv,du,tdt,rtg,u1,v1,t1,q1,usfco,vsfco,icplocn2atm, & & swh,hlw,xmu,garea,zvfun,sigmaf, & & psk,rbsoil,zorl,u10m,v10m,fm,fh, & @@ -82,10 +87,16 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & prsi,del,prsl,prslk,phii,phil,delt, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl,dkt,dku,tkeh, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & - & rlmx,elmx,sfc_rlm,tc_pbl, & + & rlmx,elmx,sfc_rlm,tc_pbl,use_lpt, & +!IVAI: canopy inputs from AQM + & do_canopy, cplaqm, claie, cfch, cfrt, cclu, cpopu, & +!IVAI & ntqv,dtend,dtidx,index_of_temperature,index_of_x_wind, & & index_of_y_wind,index_of_process_pbl,gen_tend,ldiag3d, & - & errmsg,errflg) + & errmsg,errflg) +!IVAI: aux arrays +! & naux2d,naux3d,aux2d,aux3d) + ! use machine , only : kind_phys use funcphys , only : fpvs @@ -97,21 +108,30 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & ntke, ntqv integer, intent(in) :: sfc_rlm integer, intent(in) :: tc_pbl + integer, intent(in) :: use_lpt integer, intent(in) :: kinver(:) integer, intent(out) :: kpbl(:) logical, intent(in) :: gen_tend,ldiag3d ! - real(kind=kind_phys), intent(in) :: grav,rd,cp,rv,hvap,hfus,fv, & + real(kind=kind_phys), intent(in) :: grav,pi,rd,cp,rv,hvap,hfus,fv, & & eps,epsm1 real(kind=kind_phys), intent(in) :: delt, xkzm_m, xkzm_h, xkzm_s real(kind=kind_phys), intent(in) :: dspfac, bl_upfr, bl_dnfr real(kind=kind_phys), intent(in) :: rlmx, elmx +!PCC CANOPY------------------------------------ + logical, intent(in) :: do_canopy, cplaqm +!IVAI: canopy inputs + real(kind=kind_phys), optional, intent(in) :: claie(:), cfch(:), & + & cfrt(:), cclu(:), cpopu(:) + !---------------------------------------------- real(kind=kind_phys), intent(inout) :: dv(:,:), du(:,:), & & tdt(:,:), rtg(:,:,:), tkeh(:,:) real(kind=kind_phys), intent(in) :: & & u1(:,:), v1(:,:), & & usfco(:), vsfco(:), & & t1(:,:), q1(:,:,:), & +!The following two variables are for SA-3D-TKE + & def_1(:,:), def_2(:,:), def_3(:,:), & & swh(:,:), hlw(:,:), & & xmu(:), garea(:), & & zvfun(:), sigmaf(:), & @@ -136,10 +156,17 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys), intent(out) :: & & dkt(:,:), dku(:,:) ! + logical, intent(in) :: sa3dtke !flag for SA-3D-TKE scheme + logical, intent(in) :: dspheat character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg +!For passing dku to the dyn_core (SA-3D-TKE scheme) + real(kind=kind_phys), intent(out) :: + & dku3d_h(:,:),dku3d_e(:,:) + + ! flag for tke dissipative heating ! !---------------------------------------------------------------------- @@ -248,6 +275,24 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & & tem, tem1, tem2, tem3, & ptem, ptem0, ptem1, ptem2 ! +!The following variables are for SA-3D-TKE + integer kk + real(kind=kind_phys) thetal(im,km),dku_les(im,km),dkt_les(im,km), + & elm_les(im,km),ele_les(im,km),pftke(im), + & dkq_les(im,km),pfl(im), + & dku_h(im,km),dkq_h(im,km),dddmp, + & cpl1,cpl2,cpl3,cpl4, + & cpl5,cpl6,pfnl(im),cpnl1,cpnl2,cpnl3,cpnl4, + & cpnl5,cpnl6,cptke1,cptke2,cptke3, + & inv3 + + real(kind=kind_phys) ak(im,km),bk(im,km),ck(im,km),pk(im,km), + & f3(im,km),rizt(im,km) + real(kind=kind_phys) aa1,aa2,bb1,bb2,cc1,alpha1, alpha2, alpha3, + & alpha4,alpha5,ssh,ssm,gh,aa,bb,cc,dd + integer l_tkemax,kscl + real(kind=kind_phys) tkemax, scl, kmaxles, esmax + real(kind=kind_phys) slfac ! real(kind=kind_phys) vegflo, vegfup, z0lo, z0up, vc0, zc0 @@ -259,6 +304,40 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & real(kind=kind_phys) h1 real(kind=kind_phys) bfac, mffac + + real(kind=kind_phys) qice(im,km),qliq(im,km) + +!PCC_CANOPY------------------------------------ + integer COUNTCAN,KCAN + integer kount !IVAI + real(kind=kind_phys) FCH, MOL, HOL, TLCAN, + & SIGMACAN, RRCAN, BBCAN, + & AACAN, ZCAN, ZFL, BOTCAN, + & EDDYVEST1, EDDYVEST_INT + + ! in canopy eddy diffusivity [ m**2/s ] + real(kind=kind_phys), allocatable :: EDDYVESTX ( : ) + ! in canopy layer [m] + real(kind=kind_phys), allocatable :: ZCANX ( : ) + ! Declare local maximum canopy layers + integer, parameter :: MAXCAN = 1000 + integer, parameter :: mvt = 30 ! use 30 instead of 27 + !Based on MODIS IGBP 20 Category Dataset + real :: fch_table(mvt) !< top of canopy (m) + data ( fch_table(i),i=1,mvt) / + & 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, + & 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, + & 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, + & 2.00, 0.50, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / +!---------------------------------------------- + +!IVAI +! integer, intent(in) :: naux2d,naux3d +! real(kind_phys), intent(inout) :: aux2d(:,:) +! real(kind_phys), intent(inout) :: aux3d(:,:,:) +!IVAI + !! parameter(bfac=100.) parameter(wfac=7.0,cfac=4.5) @@ -282,7 +361,25 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & parameter(ck1=0.15,ch1=0.15) parameter(cs0=0.4,csmf=0.5) parameter(rchck=1.5,ndt=20) + !The following variables are for SA-3D-TKE + parameter(cpl1=0.280,cpl2=0.870,cpl3=0.913) + parameter(cpl4=0.153,cpl5=0.278,cpl6=0.720) + parameter(cpnl1=0.243,cpnl2=0.936,cpnl3=1.11) + parameter(cpnl4=0.312,cpnl5=0.329,cpnl6=0.757) + parameter(cptke1=0.07,cptke2=0.142,cptke3=0.071) + parameter(aa1=0.92,aa2=0.74,bb1=16.6,bb2=10.1,cc1=0.08) + parameter(kmaxles=300.0,esmax=500.0,dddmp=0.1) + parameter(inv3=0.33333333) +! parameter(aa1=0.92,aa2=0.649,bb1=17.7,bb2=9.5,cc1=0.08) +!PCC_CANOPY------------------------------------ + if (do_canopy) then + if(.not.allocated(EDDYVESTX)) + & allocate( EDDYVESTX ( MAXCAN ) ) + if(.not.allocated(ZCANX)) + & allocate( ZCANX ( MAXCAN ) ) + endif +!---------------------------------------------- if (tc_pbl == 0) then ck0 = 0.4 ch0 = 0.4 @@ -434,6 +531,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & hpbl(i) = 0. kpblx(i) = 1 hpblx(i) = 0. + pfl(i)=1.0 + pfnl(i)=1.0 + pftke(i)=1.0 pblflg(i)= .true. sfcflg(i)= .true. if(rbsoil(i) > 0.) sfcflg(i) = .false. @@ -462,20 +562,55 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & enddo ! !> - Compute \f$\theta\f$(theta), and \f$q_l\f$(qlx), \f$\theta_e\f$(thetae), -!! \f$\theta_v\f$(thvx),\f$\theta_{l,v}\f$ (thlvx) including ice water - do k=1,km +!! \f$\theta_v\f$(thvx),\f$\theta_{l,v}\f$ (thlvx) including ice water +!The following is for SA-3D-TKE + if(sa3dtke) then + do k=1,km + do i=1,im + pix(i,k) = psk(i) / prslk(i,k) + theta(i,k) = t1(i,k) * pix(i,k) + if(ntiw > 0) then + tem = max(q1(i,k,ntcw),qlmin) + tem1 = max(q1(i,k,ntiw)+q1(i,k,5)+q1(i,k,6),qlmin) + qlx(i,k) = tem + tem1 + ptem = hvap*tem + (hvap+hfus)*tem1 + slx(i,k) = cp * t1(i,k) + phil(i,k) - ptem + else + qlx(i,k) = max(q1(i,k,ntcw),qlmin) + slx(i,k) = cp * t1(i,k) + phil(i,k) - hvap*qlx(i,k) + endif + tem2 = 1.+fv*max(q1(i,k,1),qmin)-qlx(i,k) + thvx(i,k) = theta(i,k) * tem2 + tvx(i,k) = t1(i,k) * tem2 + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) + thlx(i,k) = theta(i,k) - pix(i,k)*elocp*qlx(i,k) + thlvx(i,k) = thlx(i,k) * (1. + fv * qtx(i,k)) + svx(i,k) = cp * tvx(i,k) + ptem1 = elocp * pix(i,k) * max(q1(i,k,1),qmin) + thetae(i,k)= theta(i,k) + ptem1 +! gotvx(i,k) = g / tvx(i,k) + gotvx(i,k) = g / thvx(i,k) + enddo + enddo + else + do k=1,km do i=1,im pix(i,k) = psk(i) / prslk(i,k) theta(i,k) = t1(i,k) * pix(i,k) + qice(i,k) = 0.0 + qliq(i,k) = 0.0 if(ntiw > 0) then tem = max(q1(i,k,ntcw),qlmin) tem1 = max(q1(i,k,ntiw),qlmin) + qice(i,k) = tem1 + qliq(i,k) = tem qlx(i,k) = tem + tem1 ptem = hvap*tem + (hvap+hfus)*tem1 slx(i,k) = cp * t1(i,k) + phil(i,k) - ptem else qlx(i,k) = max(q1(i,k,ntcw),qlmin) slx(i,k) = cp * t1(i,k) + phil(i,k) - hvap*qlx(i,k) + qliq(i,k) = qlx(i,k) endif tem2 = 1.+fv*max(q1(i,k,1),qmin)-qlx(i,k) thvx(i,k) = theta(i,k) * tem2 @@ -489,7 +624,8 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ! gotvx(i,k) = g / tvx(i,k) gotvx(i,k) = g / thvx(i,k) enddo - enddo + enddo + endif !sa3dtke !> - Compute an empirical cloud fraction based on !! Xu and Randall (1996) \cite xu_and_randall_1996 @@ -1016,14 +1152,18 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & call mfpbltq(im,im,km,kmpbl,ntcw,ntrac1,dt2, & pcnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, & gdx,hpbl,kpbl,vpert,buou,wush,tkemean,vez0fun,xmf, - & tcko,qcko,ucko,vcko,xlamue,bl_upfr) + & tcko,qcko,ucko,vcko,xlamue,bl_upfr, +!The following flag is for SA-3D-TKE (kyf) + & sa3dtke) !> - Call mfscuq(), which is a new mass-flux parameterization for !! stratocumulus-top-induced turbulence mixing. For details of the mfscuq subroutine, step into its documentation ::mfscuq call mfscuq(im,im,km,kmscu,ntcw,ntrac1,dt2, & scuflg,zl,zm,q1,t1,u1,v1,plyr,pix, & thlx,thvx,thlvx,gdx,thetae, & krad,mrad,radmin,buod,wush,tkemean,vez0fun,xmfd, - & tcdo,qcdo,ucdo,vcdo,xlamde,bl_dnfr) + & tcdo,qcdo,ucdo,vcdo,xlamde,bl_dnfr, +!The following flag is for SA-3D-TKE (kyf) + & sa3dtke) if (tc_pbl == 1) then !> - unify mass fluxes with Cu @@ -1170,7 +1310,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !! l_2=min(l_{up},l_{down}) !!\f] !! and dissipation length scale \f$l_d\f$ is given by: -!!\f[ +!!\f[ !! l_d=(l_{up}l_{down})^{1/2} !!\f] !! where \f$l_{up}\f$ and \f$l_{down}\f$ are the distances that a parcel @@ -1192,6 +1332,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ! enddo enddo + !> - Compute the surface layer length scale (\f$l_1\f$) following !! Nakanishi (2001) \cite Nakanish_2001 (eqn 9 of Han et al.(2019) \cite Han_2019) do k = 1, km1 @@ -1244,7 +1385,59 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !> ## Compute eddy diffusivities !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - do k = 1, km1 + if(sa3dtke) then + do k = 1, km1 + do i = 1, im + tem = 0.5 * (elm(i,k) + elm(i,k+1)) + tem = tem * sqrt(tkeh(i,k)) + ri = max(bf(i,k)/(def_1(i,k)+def_2(i,k)),rimin) + if(k < kpbl(i)) then + if(pcnvflg(i)) then + dku(i,k) = ckz(i,k) * tem + dkt(i,k) = dku(i,k) / prn(i,k) + else + if(ri < 0.) then ! unstable regime + dku(i,k) = ckz(i,k) * tem + dkt(i,k) = dku(i,k) / prn(i,k) + else ! stable regime + dkt(i,k) = chz(i,k) * tem + dku(i,k) = dkt(i,k) * prn(i,k) + endif + endif + else + if(ri < 0.) then ! unstable regime + dku(i,k) = ck1 * tem + dkt(i,k) = rchck * dku(i,k) + else ! stable regime + dkt(i,k) = ch1 * tem + prnum = 1.0 + 2.1 * ri + prnum = min(prnum,prmax) + dku(i,k) = dkt(i,k) * prnum + endif + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + tem1 = ckz(i,k) * tem + ptem1 = tem1 / prscu + dku(i,k) = max(dku(i,k), tem1) + dkt(i,k) = max(dkt(i,k), ptem1) + endif + endif +! + dkq(i,k) = prtke * dkt(i,k) +! + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dkq(i,k) = min(dkq(i,k),dkmax) + dkq(i,k) = max(dkq(i,k),xkzo(i,k)) + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) +! + enddo + enddo + else + do k = 1, km1 do i = 1, im tem = 0.5 * (elm(i,k) + elm(i,k+1)) tem = tem * sqrt(tkeh(i,k)) @@ -1293,7 +1486,322 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & dku(i,k) = max(dku(i,k),xkzmo(i,k)) ! enddo + enddo + endif !sa3dtke + +!The following is for SA-3D-TKE + if(sa3dtke) then +! 1. compute LES component of km, kh, and kq (Deardorff 1980) +! calculate thetal + do k=1,km + do i=1,im + pix(i,k) = psk(i) / prslk(i,k) + theta(i,k) = t1(i,k) * pix(i,k) + tem=theta(i,k)/t1(i,k) + if(ntiw > 0) then + tem1=max(q1(i,k,ntcw),qlmin)+ + & max(q1(i,k,ntiw)+q1(i,k,5)+q1(i,k,6),qlmin) + thetal(i,k)=theta(i,k)-(hvap+hfus)/cp*tem*tem1 + else + tem1=max(q1(i,k,ntcw),qlmin) + thetal(i,k)=theta(i,k)-hvap/cp*tem*tem1 + endif + enddo + enddo + + do k=1,km + do i=1,im + dku_les(i,k) = 0. + dkt_les(i,k) = 0. + dkq_les(i,k) = 0. + enddo + enddo + + do k = 1, km1 + do i = 1, im + dz = zl(i,k+1) - zl(i,k) + tem=gotvx(i,1)*(thetal(i,k+1)-thetal(i,k))*rdzt(i,k) + tem1=(garea(i)*dz)**(inv3) +! calculate LES mixing length + if(tem > 0.0) then + elm_les(i,k)=0.76*sqrt(tkeh(i,k))*tem**(-0.5) + elm_les(i,k)=min(elm_les(i,k),tem1) + else + elm_les(i,k)=tem1 + endif + ele_les(i,k)=elm_les(i,k) +! calculate km, kh, and kq for LES + dku_les(i,k)=0.1*elm_les(i,k)*sqrt(tkeh(i,k)) + dkt_les(i,k)=(1.0+2.0*elm_les(i,k)/tem1)*dku_les(i,k) + dkq_les(i,k)=dkt_les(i,k) + dku_les(i,k) = min(dku_les(i,k),kmaxles) + dkt_les(i,k) = min(dkt_les(i,k),kmaxles) + dkq_les(i,k) = min(dkq_les(i,k),kmaxles) + enddo + enddo + +! 2. compute MS horizontal km + do k = 1, km1 + do i = 1, im + tem1=sqrt(garea(i)) + dku_h(i,k)=dddmp*tem1*sqrt(tkeh(i,k)) + enddo + dku_h(i,km)=dku_h(i,km1) + enddo + +! calculate blending coefficients for km, kt, kq, and nonlocal mixing + do i = 1, im +! finding scale of large eddies from TKE +! d/zi + scl=1000. + l_tkemax=10 + kscl=10 + tkemax=0.0 + do k=1,km1 + tkemax=max(tkemax,tkeh(i,k)) + enddo + do k=1,km1 + if (abs(tkeh(i,k)-tkemax)/tkemax < 1.0e-9) then + l_tkemax=k + endif + enddo + do k=l_tkemax,km1 + if (tkeh(i,k)-0.5*tkemax > 0.0) then + kscl=k + endif + enddo + kscl=min(kscl,km1-10) + scl=zi(i,kscl+1) + scl=max(scl,esmax) + tem=gdx(i)/max(hpbl(i),scl) +! tem=gdx(i)/max(hpbl(i),esmax) + +! partition function for local fluxes + pfl(i)=cpl1*(tem**2+cpl2*tem**0.5-cpl3)/ + & (tem**2+cpl4*tem**0.5+cpl5)+cpl6 + pfl(i)=min(max(pfl(i),0.0),1.0) +! partition function for nonlocal fluxes + pfnl(i)=cpnl1*(tem**2+cpnl2*tem**(7./8.)-cpnl3)/ + & (tem**2+cpnl4*tem**(7./8.)+cpnl5)+cpnl6 + pfnl(i)=min(max(pfnl(i),0.0),1.0) +! partition function for TKE + pftke(i)=(tem**2+cptke1*tem**(2./3.))/ + & (tem**2+cptke2*tem**(2./3.)+cptke3) + pftke(i)=min(max(pftke(i),0.0),1.0) + enddo + +! blending LES and MS components of km,kt, and kq from in the +! vertical and horizontal direction + do k = 1,km + do i=1,im + dkq(i,k)=(1.0-pfl(i))*dkq_les(i,k)+pfl(i)*dkq(i,k) + dkt(i,k)=(1.0-pfl(i))*dkt_les(i,k)+pfl(i)*dkt(i,k) + dku(i,k)=(1.0-pfl(i))*dku_les(i,k)+pfl(i)*dku(i,k) + ri = max(bf(i,k)/(def_1(i,k)+def_2(i,k)),rimin) + if(ri < 0.) then ! unstable regime + prnum=1./rchck + else + prnum=1.0 + 2.1 * ri + endif + dkq_h(i,k)=(1.0-pfl(i))*dkq_les(i,k)+ + & pfl(i)*dku_h(i,k)/prnum + dku_h(i,k)=(1.0-pfl(i))*dku_les(i,k)+pfl(i)*dku_h(i,k) + enddo enddo + +! perform scale-aware for non-local transport + do k = 1, kmpbl + do i = 1, im + if (pcnvflg(i) .and. k < kpbl(i)) then + xmf(i,k) = pfnl(i) * xmf(i,k) + endif + enddo + enddo + + do k = kmscu, 1, -1 + do i = 1, im + if(scuflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + xmfd(i,k) = pfnl(i) * xmfd(i,k) + endif + enddo + enddo + + endif !sa3dtke + +!PCC_CANOPY------------------------------------ + kount=0 !IVAI + if (do_canopy .and. cplaqm) then + +!IVAI +! print*, 'SATMEDMFVDIFQ_RUN: CLAIE = ', claie(:) +! print*, 'SATMEDMFVDIFQ_RUN: CFCH = ' , cfch (:) +! print*, 'SATMEDMFVDIFQ_RUN: CFRT = ' , cfrt (:) +! print*, 'SATMEDMFVDIFQ_RUN: CCLU = ' , cclu (:) +! print*, 'SATMEDMFVDIFQ_RUN: CPOPU= ' , cpopu(:) +! 2D aux arrays: canopy data in diffusion +! aux2d(:,1) = cfch (:) +! aux2d(:,2) = claie(:) +! aux2d(:,3) = cfrt(:) + +! 3D aux arrays: before canopy correction +! aux3d(:,:,1) = dkq(:,:) +! aux3d(:,:,2) = dkt(:,:) +! aux3d(:,:,3) = dku(:,:) +!IVAI + do k = 1, km1-1 + do i = 1, im + +!IVAI: AQM canopy Inputs +! FCH = fch_table(vegtype(i)) !top of canopy from look-up table + FCH = cfch(i) !top of canopy from AQM canopy inputs + IF (k .EQ. 1) THEN !use model layer interfaces + KCAN = 1 + ELSE + IF ( cfch(i) .GT. zi(i,k) + & .AND. cfch(i) .LE. zi(i,k+1) ) THEN + KCAN = 1 + ELSE + KCAN = 0 + END IF + END IF + + IF (KCAN .EQ. 1) THEN !canopy inside model layer +! Check for other Contiguous Canopy Grid Cell Conditions + +! Not a contigous canopy cell + IF ( claie(i) .LT. 0.1 + & .OR. cfch (i) .LT. 0.5 +!IVAI: modified contiguous canopy condition +! & .OR. MAX(0.0, 1.0 - cfrt(i)) .GT. 0.5 + & .OR. MAX(0.0, 1.0 - cfrt(i)) .GT. 0.75 +!IVAI + & .OR. cpopu(i) .GT. 10000.0 + & .OR. (EXP(-0.5*claie(i)*cclu(i)) .GT. 0.45 + & .AND. cfch(i) .LT. 18.) ) THEN + + +!TODO: Canopy Inputs +! IF ( XCANOPYLAI .LT. 0.1 !from canopy inputs +! IF ( lai(i) .LT. 0.1 !from LSM +! & .OR. FCH .LT. 0.5 ) THEN +! & .OR. MAX(0.0, 1.0 - XCANOPYFRT) .GT. 0.5 +! & .OR. POPU .GT. 10000.0 +! & .OR. EXP(-0.5*XCANOPYLAI*XCANOPYCLU).GT. 0.45 +! & .AND. FCH .LT. 18.0 ) THEN + + dkt(i,k)= dkt(i,k) + dkq(i,k)= dkq(i,k) + dku(i,k)= dku(i,k) + + ELSE ! There is a contiguous forest canopy, apply correction over canopy layers + +! Output contiguous canopy mask +! if (kount .EQ. 0 ) aux2d(i,5) = aux2d(i,5) + 1 + +!Raupauch M. R. A Practical Lagrangian method for relating scalar +!concentrations to +! source distributions in vegetation canopies. Q. J. R. Meteor. Soc. +! (1989), 115, pp 609-632 + MOL = zol(i)/zl(i,k) !Monin-Obukhov Length in layer + HOL = FCH/MOL !local canopy stability parameter (hc/MOL) + ZCAN = zi(i,k+1) ! Initialize each model layer top that contains canopy (m) + ! Integrate across total model interface + ZFL = ZCAN ! Set ZFL = ZCAN + COUNTCAN = 0 ! Initialize canopy layers + + IF (k .EQ. 1) THEN !Find bottom in each model layer + BOTCAN = 0.5 + ELSE + BOTCAN = zi(i,k) + END IF + + DO WHILE (ZCAN.GE.BOTCAN) + ! TLCAN = Lagrangian timescale + TLCAN = (FCH/ustar(i)) * ( + & (0.256 * (ZCAN-(0.75*FCH))/FCH ) + + & (0.492*EXP((-0.256*ZCAN/FCH)/0.492)) ) + IF ( HOL .LT. -0.1 ) THEN !STRONG UNSTABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN !SIGMACAN = Eulerian vertical velocity variance + SIGMACAN = 1.25*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 + & .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = ustar(i) * ( 0.75 + + & (0.5 * COS((PI/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. -0.1 .AND. HOL .LT. 0.1 ) THEN !WEAKLY UNSTABLE to NEUTRAL + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 1.0*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 + & .AND. ZCAN/FCH .LE. 1.25 ) THEN + SIGMACAN = ustar(i) * ( 0.625 + + & (0.375* COS((PI/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. 0.1 .AND. HOL .LT. 0.9 ) THEN !STABLE + IF ( ZCAN/FCH .GT. 1.25 ) THEN + SIGMACAN = 0.25*(4.375 - (3.75*HOL))*ustar(i) + END IF + IF ( ZCAN/FCH .GE. 0.175 + & .AND. ZCAN/FCH .LE. 1.25 ) THEN + RRCAN=4.375-(3.75*HOL) + AACAN=(0.125*RRCAN) + 0.125 + BBCAN=(0.125*RRCAN) - 0.125 + SIGMACAN = ustar(i) * ( AACAN + + & (BBCAN * COS((PI/1.06818) * + & (1.25 - (ZCAN/FCH)))) ) + END IF + IF ( ZCAN/FCH .LT. 0.175 ) THEN + SIGMACAN = 0.25*ustar(i) + END IF + END IF + IF ( HOL .GE. 0.9 ) THEN !VERY STABLE + SIGMACAN = 0.25*ustar(i) + END IF + IF ( ZCAN .EQ. ZFL ) THEN ! Each model layer that includes canopy + EDDYVEST1 = (SIGMACAN*SIGMACAN)*TLCAN + ELSE IF ( ZCAN .LE. FCH ) THEN !in-canopy layers and set arrays + COUNTCAN = COUNTCAN + 1 + ZCANX (COUNTCAN) = ZCAN + EDDYVESTX (COUNTCAN) = (SIGMACAN*SIGMACAN)*TLCAN + END IF + ZCAN = ZCAN-0.5 !step down in-canopy resolution of 0.5m + END DO !end loop on canopy layers + EDDYVEST_INT = IntegrateTrapezoid((ZCANX(COUNTCAN:1:-1) + & ),EDDYVESTX(COUNTCAN:1:-1)) / ZFL + dkt(i,k)= (dkt(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkt to resolved eddy diffusivity + dkq(i,k)= (dkq(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dkq to resolved eddy diffusivity + dku(i,k)= (dku(i,k)/EDDYVEST1) * EDDYVEST_INT !Scale dku to resolved eddy diffusivity + +!IVAI: Output contiguos canopy correction bottom layer and 3D +! if ( kount .EQ. 0) +! & aux2d(i,4) = 1./EDDYVEST1 * EDDYVEST_INT +! aux3d(i,k,4) = 1./EDDYVEST1 * EDDYVEST_INT +!IVAI + + END IF ! contigous canopy conditions + + END IF ! (KCAN .EQ. 1) model layer(s) containing canopy + + enddo !i + + kount = kount + 1 !IVAI + + enddo !k + + endif !do_canopy .and. cplaqm + !> ## Compute TKE. !! - Compute a minimum TKE deduced from background diffusivity for momentum. ! @@ -1317,7 +1825,129 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !> - Compute buoyancy and shear productions of TKE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! - do k = 1, km1 + if(sa3dtke) then + do k = 1, km1 + do i = 1, im + if (k == 1) then + tem = -dkt(i,1) * bf(i,1) +! if(pcnvflg(i)) then +! ptem1 = xmf(i,1) * buou(i,1) +! else + ptem1 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem2 = xmfd(i,1) * buod(i,1) + else + ptem2 = 0. + endif + tem = tem + ptem1 + ptem2 + buop = 0.5 * (gotvx(i,1) * sflux(i) + tem) +! + tem1 = dku(i,1)*def_1(i,1)+dku_h(i,1)*def_2(i,1) +! + tem = (u1(i,2)-u1(i,1))*rdzt(i,1) +! if(pcnvflg(i)) then +! ptem = xmf(i,1) * tem +! ptem1 = 0.5 * ptem * (u1(i,2)-ucko(i,2)) +! else + ptem1 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem = ucdo(i,1)+ucdo(i,2)-u1(i,1)-u1(i,2) + ptem = 0.5 * tem * xmfd(i,1) * ptem + else + ptem = 0. + endif + ptem1 = ptem1 + ptem +! + tem = (v1(i,2)-v1(i,1))*rdzt(i,1) +! if(pcnvflg(i)) then +! ptem = xmf(i,1) * tem +! ptem2 = 0.5 * ptem * (v1(i,2)-vcko(i,2)) +! else + ptem2 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem = vcdo(i,1)+vcdo(i,2)-v1(i,1)-v1(i,2) + ptem = 0.5 * tem * xmfd(i,1) * ptem + else + ptem = 0. + endif + ptem2 = ptem2 + ptem +! + tem2 = stress(i)*ustar(i)*phims(i)/(vk*zl(i,1)) + shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2) + else + tem1 = -dkt(i,k-1) * bf(i,k-1) + tem2 = -dkt(i,k) * bf(i,k) + tem = 0.5 * (tem1 + tem2) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = 0.5 * (xmf(i,k-1) + xmf(i,k)) + ptem1 = ptem * buou(i,k) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = 0.5 * (xmfd(i,k-1) + xmfd(i,k)) + ptem2 = ptem0 * buod(i,k) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + buop = tem + ptem1 + ptem2 +! +! obtaining 3d shear production from dycore + tem1 = dku(i,k-1)*def_1(i,k-1)+dku_h(i,k-1)*def_2(i,k-1) + tem2 = dku(i,k)*def_1(i,k)+dku_h(i,k)*def_2(i,k) + tem = 0.5*(tem1+tem2) + tem1 = (u1(i,k+1)-u1(i,k))*rdzt(i,k) + tem2 = (u1(i,k)-u1(i,k-1))*rdzt(i,k-1) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = xmf(i,k) * tem1 + xmf(i,k-1) * tem2 + ptem1 = 0.5 * ptem * (u1(i,k)-ucko(i,k)) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = xmfd(i,k) * tem1 + xmfd(i,k-1) * tem2 + ptem2 = 0.5 * ptem0 * (ucdo(i,k)-u1(i,k)) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + shrp = tem + ptem1 + ptem2 + tem1 = (v1(i,k+1)-v1(i,k))*rdzt(i,k) + tem2 = (v1(i,k)-v1(i,k-1))*rdzt(i,k-1) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = xmf(i,k) * tem1 + xmf(i,k-1) * tem2 + ptem1 = 0.5 * ptem * (v1(i,k)-vcko(i,k)) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = xmfd(i,k) * tem1 + xmfd(i,k-1) * tem2 + ptem2 = 0.5 * ptem0 * (vcdo(i,k)-v1(i,k)) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + shrp = shrp + ptem1 + ptem2 + endif +! + prod(i,k) = buop + shrp + enddo + enddo + else + do k = 1, km1 do i = 1, im if (k == 1) then tem = -dkt(i,1) * bf(i,1) @@ -1434,14 +2064,41 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & endif prod(i,k) = buop + shrp enddo - enddo + enddo + endif !sa3dtke ! !---------------------------------------------------------------------- !> - First predict tke due to tke production & dissipation(diss) ! - dtn = dt2 / float(ndt) - do n = 1, ndt - do k = 1,km1 + if(sa3dtke) then +!The following is for SA-3D-TKE + dtn = dt2 / float(ndt) + do n = 1, ndt + do k = 1,km1 + do i=1,im + tem = sqrt(tke(i,k)) +! calculating 3D TKE transport and pressure correlation + dz = zl(i,k+1) - zl(i,k) + ptem1 = ce0 / ele(i,k) + tem1=(garea(i)*dz)**(inv3) + tem2=0.19+0.51*ele_les(i,k)/tem1 + ptem2= tem2 / ele_les(i,k) + ptem=(1.0-pftke(i))*ptem2+pftke(i)*ptem1 + diss(i,k) = ptem * tke(i,k) * tem + tem1 = prod(i,k) + tke(i,k) / dtn + diss(i,k)=max(min(diss(i,k), tem1), 0.) + tem=2.0*def_3(i,k) + tem=min(tem,1.0) + tke(i,k) = tke(i,k) + dtn * (prod(i,k)-diss(i,k)+tem) +! tke(i,k) = max(tke(i,k), tkmin) + tke(i,k) = max(tke(i,k), tkmnz(i,k)) + enddo + enddo + enddo + else + dtn = dt2 / float(ndt) + do n = 1, ndt + do k = 1,km1 do i=1,im tem = sqrt(tke(i,k)) ptem = ce0 / ele(i,k) @@ -1452,8 +2109,9 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ! tke(i,k) = max(tke(i,k), tkmin) tke(i,k) = max(tke(i,k), tkmnz(i,k)) enddo - enddo - enddo + enddo + enddo + endif !sa3dtke ! !> - Compute updraft & downdraft properties for TKE ! @@ -1565,6 +2223,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & tkei(i,k) = 0.5 * (tke(i,k)+tke(i,k+1)) enddo enddo + do k=1,kps do i=1,im e_diff(i,k) = tke(i,k) - tke(i,k+1) @@ -1667,6 +2326,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & ! enddo enddo + c !> - Call tridit() to solve tridiagonal problem for TKE c @@ -1818,6 +2478,10 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & rdz = rdzt(i,k) tem1 = dsig * dkt(i,k) * rdz dsdzt = tem1 * gocp + if (use_lpt > 0) then + dsdzt = dsdzt-tem1*elocp*(qliq(i,k+1)-qliq(i,k))*rdz + & -(1+0.33/2.5)*tem1*elocp*(qice(i,k+1)-qice(i,k))*rdz + endif dsdz2 = tem1 * rdz au(i,k) = -dtodsd*dsdz2 al(i,k) = -dtodsu*dsdz2 @@ -2416,10 +3080,23 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntrw, & !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> ## Save PBL height for diagnostic purpose ! - do i = 1, im - hpbl(i) = hpblx(i) - kpbl(i) = kpblx(i) - enddo + if(sa3dtke) then + do i = 1, im + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + enddo + do k = 1, km + do i = 1, im + dku3d_h(i,k) = dku_h(i,k) ! pass dku3d_h to dyn_core + dku3d_e(i,k) = dkq_h(i,k) ! pass dku3d_e to dyn_core + enddo + enddo + else + do i = 1, im + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + enddo + endif !sa3dtke ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! return diff --git a/physics/PBL/SATMEDMF/satmedmfvdifq.meta b/physics/PBL/SATMEDMF/satmedmfvdifq.meta index 13c66399e..e213d65e7 100644 --- a/physics/PBL/SATMEDMF/satmedmfvdifq.meta +++ b/physics/PBL/SATMEDMF/satmedmfvdifq.meta @@ -1,7 +1,7 @@ [ccpp-table-properties] name = satmedmfvdifq type = scheme - dependencies = ../../tools/funcphys.f90,../../hooks/machine.F,../mfpbltq.f,mfscuq.f,../tridi.f + dependencies = ../../tools/funcphys.f90,../../tools/canopy_utils_mod.f,../../hooks/machine.F,../mfpbltq.f,mfscuq.f,../tridi.f ######################################################################## [ccpp-arg-table] @@ -105,6 +105,14 @@ type = real kind = kind_phys intent = in +[pi] + standard_name = pi + long_name = ratio of a circle's circumference to its diameter + units = none + dimensions = () + type = real + kind = kind_phys + intent = in [rd] standard_name = gas_constant_of_dry_air long_name = ideal gas constant for dry air @@ -256,6 +264,30 @@ type = real kind = kind_phys intent = in +[def_1] + standard_name = square_of_vertical_shear_due_to_dynamics + long_name = square of vertical shear calculated from dynamics + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[def_2] + standard_name = square_of_horizontal_shear_due_to_dynamics + long_name = square of horizontal shear calculated from dynamics + units = m2 s-2 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in +[def_3] + standard_name = horizontal_transfer_rate_of_tke_due_to_dynamics + long_name = rate of horizontal TKE transfer and pressure correlation calculated from dynamics + units = m2 s-3 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = in [swh] standard_name = tendency_of_air_temperature_due_to_shortwave_heating_on_radiation_timestep long_name = total sky shortwave heating rate @@ -470,6 +502,13 @@ dimensions = () type = logical intent = in +[sa3dtke] + standard_name = do_scale_aware_3d_tke + long_name = flag for scale-aware 3d tke scheme + units = flag + dimensions = () + type = logical + intent = in [dusfc] standard_name = instantaneous_surface_x_momentum_flux long_name = x momentum flux @@ -534,6 +573,22 @@ type = real kind = kind_phys intent = out +[dku3d_h] + standard_name = horizontal_atmosphere_momentum_diffusivity_for_dynamics + long_name = horizontal atmospheric momentum diffusivity for dynamics + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out +[dku3d_e] + standard_name = horizontal_atmosphere_tke_diffusivity_for_dynamics + long_name = horizontal atmospheric tke diffusivity for dynamics + units = m2 s-1 + dimensions = (horizontal_loop_extent,vertical_layer_dimension) + type = real + kind = kind_phys + intent = out [kinver] standard_name = index_of_highest_temperature_inversion long_name = index of highest temperature inversion @@ -605,6 +660,65 @@ type = real kind = kind_phys intent = in +[do_canopy] + standard_name = flag_for_canopy_option + long_name = flag for in-canopy eddy diffusivity adjustment option + units = flag + dimensions = () + type = logical + intent = in +[cplaqm] + standard_name = flag_for_air_quality_coupling + long_name = flag controlling cplaqm collection (default off) + units = flag + dimensions = () + type = logical + intent = in +[claie] + standard_name = canopy_leaf_area_index + long_name = canopy leaf area index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[cfch] + standard_name = canopy_forest_height + long_name = canopy forest height + units = m + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[cfrt] + standard_name = canopy_forest_fraction + long_name = canopy forest fraction + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[cclu] + standard_name = canopy_clumping_index + long_name = canopy clumping index + units = none + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True +[cpopu] + standard_name = canopy_population_density + long_name = population density used for canopy correction + units = km-2 + dimensions = (horizontal_loop_extent) + type = real + kind = kind_phys + intent = in + optional = True [sfc_rlm] standard_name = choice_of_near_surface_mixing_length_in_boundary_layer_mass_flux_scheme long_name = choice of near surface mixing length in boundary layer mass flux scheme @@ -619,6 +733,13 @@ dimensions = () type = integer intent = in +[use_lpt] + standard_name = control_for_using_LPT_for_TC_applications_in_the_PBL_scheme + long_name = control for using LPT in TC applications in the PBL scheme + units = none + dimensions = () + type = integer + intent = in [ntqv] standard_name = index_of_specific_humidity_in_tracer_concentration_array long_name = tracer index for water vapor (specific humidity) @@ -698,4 +819,4 @@ units = 1 dimensions = () type = integer - intent = out + intent = out \ No newline at end of file diff --git a/physics/PBL/mfpbltq.f b/physics/PBL/mfpbltq.f index 2812a7eab..52cca19ef 100644 --- a/physics/PBL/mfpbltq.f +++ b/physics/PBL/mfpbltq.f @@ -16,7 +16,9 @@ module mfpbltq_mod subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, & gdx,hpbl,kpbl,vpert,buo,wush,tkemean,vez0fun,xmf, - & tcko,qcko,ucko,vcko,xlamueq,a1) + & tcko,qcko,ucko,vcko,xlamueq,a1, +!The following flag is for SA-3D-TKE (kyf) + & sa3dtke) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -31,6 +33,7 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, ! &, me integer kpbl(im) logical cnvflg(im) + logical sa3dtke !flag for SA-3D-TKE scheme (kyf) real(kind=kind_phys) delt real(kind=kind_phys) q1(ix,km,ntrac1), & t1(ix,km), u1(ix,km), v1(ix,km), @@ -359,6 +362,16 @@ subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, endif enddo ! +!> - Set updraft fraction to 0 when using SA-3D-TKE scheme (kyf) +!! Scale-aware capability is done with pfnl in satmedmfvdifq.F +!! Zhu et al. (2025) +! + if (sa3dtke) then + do i = 1, im + sigma(i) = 0. + enddo + endif +! !> - Compute scale-aware function based on !! Arakawa and Wu (2013) \cite arakawa_and_wu_2013 ! diff --git a/physics/Radiation/mersenne_twister.f b/physics/Radiation/mersenne_twister.f index bdd0da080..f9f9668f1 100644 --- a/physics/Radiation/mersenne_twister.f +++ b/physics/Radiation/mersenne_twister.f @@ -182,7 +182,7 @@ module mersenne_twister integer,parameter:: tmaskc=-272236544 !< tempering parameter integer,parameter:: mag01(0:1)=(/0,mata/) integer,parameter:: iseed=4357 - integer,parameter:: nrest=n+6 + integer,parameter:: nrest=n+4 ! Defined types type random_stat !< Generator state private diff --git a/physics/Radiation/radiation_aerosols.f b/physics/Radiation/radiation_aerosols.f index 983d592c1..af39ae212 100644 --- a/physics/Radiation/radiation_aerosols.f +++ b/physics/Radiation/radiation_aerosols.f @@ -637,7 +637,7 @@ subroutine aer_init & ! --- outputs: & errflg, errmsg) - elseif ( iaermdl==1 .or. iaermdl==2 ) then ! gocart clim/prog scheme + elseif ( iaermdl==1 .or. iaermdl==2 .or. iaermdl==6) then ! gocart clim/prog scheme call gocart_aerinit & ! --- inputs: @@ -726,7 +726,10 @@ subroutine wrt_aerlog(iaermdl, iaerflg, lalw1bd, errflg, errmsg) print *,' - Using OPAC-seasonal climatology for tropospheric', & & ' aerosol effect' elseif ( iaermdl == 1 ) then - print *,' - Using GOCART-climatology for tropospheric', & + print *,' - Using MERRA2-climatology for tropospheric', & + & ' aerosol effect' + elseif ( iaermdl == 6 ) then + print *,' - Using MERRA2 3 hourly aerosol for tropospheric', & & ' aerosol effect' elseif ( iaermdl == 2 ) then print *,' - Using GOCART-prognostic aerosols for tropospheric', & @@ -2405,7 +2408,7 @@ subroutine setaer & & ) ! - elseif ( iaermdl==1 .or. iaermdl==2) then ! use gocart aerosols + elseif ( iaermdl==1 .or. iaermdl==2 .or. iaermdl==6) then ! use gocart aerosols call aer_property_gocart & ! --- inputs: @@ -2901,7 +2904,7 @@ subroutine aer_property & ! --- map grid in longitude direction, lon from 0 to 355 deg resolution ! print *,' Seeking lon index for point i =',i - i3 = i1 + i3 = 1 lab_do_IMXAE : do while ( i3 <= IMXAE ) tmp1 = dltg * (i3 - 1) dtmp = alon(i) - tmp1 @@ -2942,7 +2945,7 @@ subroutine aer_property & ! --- map grid in latitude direction, lat from 90n to 90s in 5 deg resolution ! print *,' Seeking lat index for point i =',i - j3 = j1 + j3 = 1 lab_do_JMXAE : do while ( j3 <= JMXAE ) tmp2 = 90.0 - dltg * (j3 - 1) dtmp = tmp2 - alat(i) diff --git a/physics/Radiation/radiation_clouds.f b/physics/Radiation/radiation_clouds.f index 11f0a1204..d177cc951 100644 --- a/physics/Radiation/radiation_clouds.f +++ b/physics/Radiation/radiation_clouds.f @@ -310,6 +310,8 @@ subroutine cld_init & print *,' --- GFDL Lin cloud microphysics' elseif (imp_physics == 8) then print *,' --- Thompson cloud microphysics' + elseif (imp_physics == 88) then + print *,' --- TEMPO cloud microphysics' elseif (imp_physics == 6) then print *,' --- WSM6 cloud microphysics' elseif (imp_physics == 10) then @@ -344,6 +346,7 @@ subroutine radiation_clouds_prop & & ntrac, ntcw, ntiw, ntrw, ntsw, ntgl, ntclamt, & & imp_physics, imp_physics_nssl, imp_physics_fer_hires, & & imp_physics_gfdl, imp_physics_thompson, imp_physics_wsm6, & + & imp_physics_tempo, & & imp_physics_zhao_carr, imp_physics_zhao_carr_pdf, & & imp_physics_mg, iovr, iovr_rand, iovr_maxrand, iovr_max, & & iovr_dcorr, iovr_exp, iovr_exprand, idcor, idcor_con, & @@ -519,6 +522,7 @@ subroutine radiation_clouds_prop & & imp_physics_fer_hires, ! Flag for fer-hires scheme & imp_physics_gfdl, ! Flag for gfdl scheme & imp_physics_thompson, ! Flag for thompsonscheme + & imp_physics_tempo, ! Flag for TEMPO scheme & imp_physics_wsm6, ! Flag for wsm6 scheme & imp_physics_zhao_carr, ! Flag for zhao-carr scheme & imp_physics_zhao_carr_pdf, ! Flag for zhao-carr+PDF scheme @@ -741,7 +745,8 @@ subroutine radiation_clouds_prop & & cld_resnow) endif ! MYNN PBL or GF - elseif(imp_physics == imp_physics_thompson) then ! Thompson MP + elseif(imp_physics == imp_physics_thompson & + & .or. imp_physics == imp_physics_tempo) then ! Thompson/TEMPO MP if(do_mynnedmf .or. imfdeepcnv == imfdeepcnv_gf & & .or. imfdeepcnv == imfdeepcnv_c3) then ! MYNN PBL or GF conv diff --git a/physics/SFC_Models/Lake/CLM/clm_lake.f90 b/physics/SFC_Models/Lake/CLM/clm_lake.f90 index 6dd973c8d..f02ed9249 100644 --- a/physics/SFC_Models/Lake/CLM/clm_lake.f90 +++ b/physics/SFC_Models/Lake/CLM/clm_lake.f90 @@ -607,7 +607,7 @@ SUBROUTINE clm_lake_run( & enddo do k = -nlevsnow+1,nlevsoil t_soisno(c,k) = t_soisno3d(i,k) - h2osoi_ice(c,k) = h2osoi_ice3d(i,k) + h2osoi_ice(c,k) = h2osoi_ice3d(i,k) h2osoi_liq(c,k) = h2osoi_liq3d(i,k) h2osoi_vol(c,k) = h2osoi_vol3d(i,k) z(c,k) = z3d(i,k) @@ -678,20 +678,20 @@ SUBROUTINE clm_lake_run( & savedtke12d(i) = savedtke1(c) snowdp2d(i) = snowdp(c) h2osno2d(i) = h2osno(c) - snl2d(i) = snl(c) + snl2d(i) = snl(c) t_grnd2d(i) = t_grnd(c) do k = 1,nlevlake t_lake3d(i,k) = t_lake(c,k) - lake_icefrac3d(i,k) = lake_icefrac(c,k) + lake_icefrac3d(i,k) = lake_icefrac(c,k) enddo - do k = -nlevsnow+1,nlevsoil - z3d(i,k) = z(c,k) - dz3d(i,k) = dz(c,k) - t_soisno3d(i,k) = t_soisno(c,k) - h2osoi_liq3d(i,k) = h2osoi_liq(c,k) - h2osoi_ice3d(i,k) = h2osoi_ice(c,k) + do k = -nlevsnow+1,nlevsoil + z3d(i,k) = z(c,k) + dz3d(i,k) = dz(c,k) + t_soisno3d(i,k) = t_soisno(c,k) + h2osoi_liq3d(i,k) = h2osoi_liq(c,k) + h2osoi_ice3d(i,k) = h2osoi_ice(c,k) h2osoi_vol3d(i,k) = h2osoi_vol(c,k) - enddo + enddo do k = -nlevsnow+0,nlevsoil zi3d(i,k) = zi(c,k) enddo @@ -2305,7 +2305,7 @@ SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi, & ! ! unlike eflx_gnet if(abs(errsoi(c)) > .001_kind_lake) then ! 1.e-5_kind_lake) then WRITE( message,* )'Primary soil energy conservation error in shlake & - column during Tridiagonal Solution,', 'error (W/m^2):', c, errsoi(c) + &column during Tridiagonal Solution,', 'error (W/m^2):', c, errsoi(c) errmsg=trim(message) errflg=1 return @@ -5626,7 +5626,7 @@ SUBROUTINE lakeini(kdt, ISLTYP, gt0, snowd, ! initial t_soisno3d ! in snow if(snowdp2d(i) > 0.) then - do k = snl2d(i)+1, 0 + do k = nint(snl2d(i))+1, 0 t_soisno3d(i,k) =min(tfrz,tsfc(i)) enddo endif diff --git a/physics/SFC_Models/Land/Noah/set_soilveg.f b/physics/SFC_Models/Land/Noah/set_soilveg.f index 35f4ace37..8f9c4e782 100644 --- a/physics/SFC_Models/Land/Noah/set_soilveg.f +++ b/physics/SFC_Models/Land/Noah/set_soilveg.f @@ -52,35 +52,35 @@ subroutine set_soilveg(me,isot,ivet,nlunit,errmsg,errflg) !using umd veg table slope_data =(/0.1, 0.6, 1.0, 0.35, 0.55, 0.8, - & 0.63, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0/) + & 0.63, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0/) rsmtbl =(/300.0, 175.0, 175.0, 300.0, 300.0, 70.0, - & 20.0, 225.0, 225.0, 225.0, 400.0, 20.0, - & 150.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + & 20.0, 225.0, 225.0, 225.0, 400.0, 20.0, + & 150.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) c----------------------------- rgltbl =(/30.0, 30.0, 30.0, 30.0, 30.0, 65.0, - & 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, - & 100.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + & 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, + & 100.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) hstbl =(/41.69, 54.53, 51.93, 47.35, 47.35, 54.53, - & 36.35, 42.00, 42.00, 42.00, 42.00, 36.35, - & 42.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) + & 36.35, 42.00, 42.00, 42.00, 42.00, 36.35, + & 42.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) ! changed for version 2.6 on june 2nd 2003 ! data snupx /0.080, 0.080, 0.080, 0.080, 0.080, 0.080, ! & 0.040, 0.040, 0.040, 0.040, 0.025, 0.040, ! & 0.025, 0.000, 0.000, 0.000, 0.000, 0.000, snupx =(/0.040, 0.040, 0.040, 0.040, 0.040, 0.040, - * 0.020, 0.020, 0.020, 0.020, 0.013, 0.020, - * 0.013, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) + * 0.020, 0.020, 0.020, 0.020, 0.013, 0.020, + * 0.013, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) bare =11 diff --git a/physics/SFC_Models/Land/Noah/sflx.f b/physics/SFC_Models/Land/Noah/sflx.f index 5f0c6c747..c6822c0eb 100644 --- a/physics/SFC_Models/Land/Noah/sflx.f +++ b/physics/SFC_Models/Land/Noah/sflx.f @@ -2662,7 +2662,7 @@ subroutine snopac ! t1 = tfreez * sncovr**snoexp + t12 * (1.0 - sncovr**snoexp) t1 = tfreez * max(0.01,sncovr**snoexp) + & - & t12 * (1.0 - max(0.01,sncovr**snoexp)) + & t12 * (1.0 - max(0.01,sncovr**snoexp)) beta = 1.0 ssoil = df1 * (t1 - stc(1)) / dtot diff --git a/physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 b/physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 index 5b7aa584d..912516cf5 100644 --- a/physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 +++ b/physics/SFC_Models/Land/Noahmp/module_sf_noahmp_glacier.F90 @@ -1,4 +1,6 @@ +#ifndef CCPP #define CCPP +#endif !> \file module_sf_noahmp_glacier.F90 !! This file contains the NoahMP Glacier scheme. @@ -326,7 +328,7 @@ subroutine noahmp_glacier (& isnow ,snowh ,sneqv ,snice ,snliq ,stc , & !inout dzsnso ,sh2o ,sice ,ponding ,zsnso ,fsh , & !inout runsrf ,runsub ,qsnow ,ponding1 ,ponding2 ,qsnbot , & !out - fpice ,esnow) !out + fpice ,esnow) !out if(opt_gla == 2) then edir = qvap - qdew @@ -638,7 +640,7 @@ subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair call tsnosoi_glacier (nsoil ,nsnow ,isnow ,dt ,tbot , & !in ssoil ,snowh ,zbot ,zsnso ,df , & !in - hcpct , & !in + hcpct , & !in stc ) !inout ! adjusting snow surface temperature @@ -1340,11 +1342,11 @@ subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso end if csh = rhoair*cpair/rahb - if(snowh > 0.0 .or. opt_gla == 1) then + if(snowh > 0.0 .or. opt_gla == 1) then cev = rhoair*cpair/gamma/(rsurf+rawb) - else - cev = 0.0 ! don't allow any sublimation of glacier in opt_gla=2 - end if + else + cev = 0.0 ! don't allow any sublimation of glacier in opt_gla=2 + end if ! surface fluxes and dtg @@ -1730,7 +1732,7 @@ end subroutine sfcdif1_glacier !>\ingroup NoahMP_LSM subroutine tsnosoi_glacier (nsoil ,nsnow ,isnow ,dt ,tbot , & !in ssoil ,snowh ,zbot ,zsnso ,df , & !in - hcpct , & !in + hcpct , & !in stc ) !inout ! -------------------------------------------------------------------------------------------------- !> compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures @@ -2222,11 +2224,11 @@ subroutine phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & if (heatr(1) > 0.) then xm(1) = heatr(1)*dt/hfus hm(1) = heatr(1) - imelt(1) = 1 + imelt(1) = 1 else xm(1) = 0. hm(1) = 0. - imelt(1) = 0 + imelt(1) = 0 endif qmelt = max(0.,(temp1-sneqv))/dt xmf = hfus*qmelt @@ -2273,21 +2275,21 @@ subroutine phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & if (any(stc(1:4) > tfrz) .and. any(stc(1:4) < tfrz)) then do j = 1,nsoil if ( stc(j) > tfrz ) then - heatr(j) = (stc(j)-tfrz)/fact(j) + heatr(j) = (stc(j)-tfrz)/fact(j) do k = 1,nsoil - if (j .ne. k .and. stc(k) < tfrz .and. heatr(j) > 0.1) then - heatr(k) = (stc(k)-tfrz)/fact(k) - if (abs(heatr(k)) > heatr(j)) then ! layer absorbs all - heatr(k) = heatr(k) + heatr(j) - stc(k) = tfrz + heatr(k)*fact(k) - heatr(j) = 0.0 + if (j .ne. k .and. stc(k) < tfrz .and. heatr(j) > 0.1) then + heatr(k) = (stc(k)-tfrz)/fact(k) + if (abs(heatr(k)) > heatr(j)) then ! layer absorbs all + heatr(k) = heatr(k) + heatr(j) + stc(k) = tfrz + heatr(k)*fact(k) + heatr(j) = 0.0 else - heatr(j) = heatr(j) + heatr(k) - heatr(k) = 0.0 - stc(k) = tfrz + heatr(j) = heatr(j) + heatr(k) + heatr(k) = 0.0 + stc(k) = tfrz end if - end if - end do + end if + end do stc(j) = tfrz + heatr(j)*fact(j) end if end do @@ -2298,21 +2300,21 @@ subroutine phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & if (any(stc(1:4) > tfrz) .and. any(stc(1:4) < tfrz)) then do j = 1,nsoil if ( stc(j) < tfrz ) then - heatr(j) = (stc(j)-tfrz)/fact(j) + heatr(j) = (stc(j)-tfrz)/fact(j) do k = 1,nsoil - if (j .ne. k .and. stc(k) > tfrz .and. heatr(j) < -0.1) then - heatr(k) = (stc(k)-tfrz)/fact(k) - if (heatr(k) > abs(heatr(j))) then ! layer absorbs all - heatr(k) = heatr(k) + heatr(j) - stc(k) = tfrz + heatr(k)*fact(k) - heatr(j) = 0.0 + if (j .ne. k .and. stc(k) > tfrz .and. heatr(j) < -0.1) then + heatr(k) = (stc(k)-tfrz)/fact(k) + if (heatr(k) > abs(heatr(j))) then ! layer absorbs all + heatr(k) = heatr(k) + heatr(j) + stc(k) = tfrz + heatr(k)*fact(k) + heatr(j) = 0.0 else - heatr(j) = heatr(j) + heatr(k) - heatr(k) = 0.0 - stc(k) = tfrz + heatr(j) = heatr(j) + heatr(k) + heatr(k) = 0.0 + stc(k) = tfrz end if - end if - end do + end if + end do stc(j) = tfrz + heatr(j)*fact(j) end if end do @@ -2323,25 +2325,25 @@ subroutine phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & if (any(stc(1:4) > tfrz) .and. any(mice(1:4) > 0.)) then do j = 1,nsoil if ( stc(j) > tfrz ) then - heatr(j) = (stc(j)-tfrz)/fact(j) + heatr(j) = (stc(j)-tfrz)/fact(j) xm(j) = heatr(j)*dt/hfus do k = 1,nsoil - if (j .ne. k .and. mice(k) > 0. .and. xm(j) > 0.1) then - if (mice(k) > xm(j)) then ! layer absorbs all - mice(k) = mice(k) - xm(j) - xmf = xmf + hfus * xm(j)/dt - stc(k) = tfrz - xm(j) = 0.0 + if (j .ne. k .and. mice(k) > 0. .and. xm(j) > 0.1) then + if (mice(k) > xm(j)) then ! layer absorbs all + mice(k) = mice(k) - xm(j) + xmf = xmf + hfus * xm(j)/dt + stc(k) = tfrz + xm(j) = 0.0 else - xm(j) = xm(j) - mice(k) - xmf = xmf + hfus * mice(k)/dt - mice(k) = 0.0 - stc(k) = tfrz + xm(j) = xm(j) - mice(k) + xmf = xmf + hfus * mice(k)/dt + mice(k) = 0.0 + stc(k) = tfrz end if mliq(k) = max(0.,wmass0(k)-mice(k)) - end if - end do - heatr(j) = xm(j)*hfus/dt + end if + end do + heatr(j) = xm(j)*hfus/dt stc(j) = tfrz + heatr(j)*fact(j) end if end do @@ -2352,25 +2354,25 @@ subroutine phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & if (any(stc(1:4) < tfrz) .and. any(mliq(1:4) > 0.)) then do j = 1,nsoil if ( stc(j) < tfrz ) then - heatr(j) = (stc(j)-tfrz)/fact(j) + heatr(j) = (stc(j)-tfrz)/fact(j) xm(j) = heatr(j)*dt/hfus do k = 1,nsoil - if (j .ne. k .and. mliq(k) > 0. .and. xm(j) < -0.1) then - if (mliq(k) > abs(xm(j))) then ! layer absorbs all - mice(k) = mice(k) - xm(j) - xmf = xmf + hfus * xm(j)/dt - stc(k) = tfrz - xm(j) = 0.0 + if (j .ne. k .and. mliq(k) > 0. .and. xm(j) < -0.1) then + if (mliq(k) > abs(xm(j))) then ! layer absorbs all + mice(k) = mice(k) - xm(j) + xmf = xmf + hfus * xm(j)/dt + stc(k) = tfrz + xm(j) = 0.0 else - xm(j) = xm(j) + mliq(k) - xmf = xmf - hfus * mliq(k)/dt - mice(k) = wmass0(k) - stc(k) = tfrz + xm(j) = xm(j) + mliq(k) + xmf = xmf - hfus * mliq(k)/dt + mice(k) = wmass0(k) + stc(k) = tfrz end if mliq(k) = max(0.,wmass0(k)-mice(k)) - end if - end do - heatr(j) = xm(j)*hfus/dt + end if + end do + heatr(j) = xm(j)*hfus/dt stc(j) = tfrz + heatr(j)*fact(j) end if end do @@ -2402,7 +2404,7 @@ subroutine water_glacier (nsnow ,nsoil ,imelt ,dt ,prcp ,sfctmp , isnow ,snowh ,sneqv ,snice ,snliq ,stc , & !inout dzsnso ,sh2o ,sice ,ponding ,zsnso ,fsh , & !inout runsrf ,runsub ,qsnow ,ponding1 ,ponding2 ,qsnbot , & !out - fpice ,esnow) !out + fpice ,esnow) !out ! ---------------------------------------------------------------------- ! code history: ! initial code: guo-yue niu, oct. 2007 @@ -2573,7 +2575,7 @@ subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in ficeold ,zsoil , & !in isnow ,snowh ,sneqv ,snice ,snliq , & !inout sh2o ,sice ,stc ,dzsnso ,zsnso , & !inout - fsh , & !inout + fsh , & !inout qsnbot ,snoflow ,ponding1 ,ponding2) !out ! ---------------------------------------------------------------------- implicit none diff --git a/physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 b/physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 index 3f27636ff..13decd0be 100644 --- a/physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 +++ b/physics/SFC_Models/Land/Noahmp/module_sf_noahmplsm.F90 @@ -1,4 +1,6 @@ +#ifndef CCPP #define CCPP +#endif !> \file module_sf_noahmplsm.F90 !! This file contains the NoahMP land surface model. @@ -424,7 +426,7 @@ subroutine noahmp_sflx (parameters, & sfctmp , sfcprs , psfc , uu , vv , q2, garea1 , & ! in : forcing qc , soldn , lwdn,thsfc_loc, prslkix,prsik1x,prslk1x,& ! in : forcing pblhx , iz0tlnd , itime ,psi_opt ,& - prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing + prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing ep_1 , ep_2 , epsm1 , cp , & ! in : constants albold , sneqvo , & ! in/out : @@ -436,7 +438,7 @@ subroutine noahmp_sflx (parameters, & cm , ch , tauss , & ! in/out : grain , gdd , pgs , & ! in/out smcwtd ,deeprech , rech , ustarx , & ! in/out : - z0wrf , z0hwrf , ts , & ! out : + z0wrf , z0hwrf , ts , & ! out : fsa , fsr , fira , fsh , ssoil , fcev , & ! out : fgev , fctr , ecan , etran , edir , trad , & ! out : tgb , tgv , t2mv , t2mb , q2v , q2b , & ! out : @@ -445,9 +447,9 @@ subroutine noahmp_sflx (parameters, & qsnbot , ponding , ponding1, ponding2, rssun , rssha , & ! out : albd , albi , albsnd , albsni , & ! out : bgap , wgap , chv , chb , emissi , & ! out : - shg , shc , shb , evg , evb , ghv , & ! out : - ghb , irg , irc , irb , tr , evc , & ! out : - chleaf , chuc , chv2 , chb2 , fpice , pahv , & + shg , shc , shb , evg , evb , ghv , & ! out : + ghb , irg , irc , irb , tr , evc , & ! out : + chleaf , chuc , chv2 , chb2 , fpice , pahv , & pahg , pahb , pah , esnow , canhs , laisun , & laisha , rb , qsfcveg , qsfcbare & #ifdef CCPP @@ -819,7 +821,7 @@ subroutine noahmp_sflx (parameters, & canliq ,canice ,tv ,sfctmp ,tg , & !in qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out - fwet ,cmc ) !out + fwet ,cmc ) !out ! compute energy budget (momentum & energy fluxes and phase changes) @@ -833,7 +835,7 @@ subroutine noahmp_sflx (parameters, & qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in pblhx ,iz0tlnd, itime ,psi_opt, ep_1, ep_2, epsm1,cp, & - z0wrf ,z0hwrf , & !out + z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out @@ -854,7 +856,7 @@ subroutine noahmp_sflx (parameters, & fsrg ,rssun ,rssha ,albd ,albi ,albsnd,albsni, bgap ,wgap, tgv,tgb,& q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out emissi ,pah ,canhs, & - shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out qsfcveg = eah*ep_2/(sfcprs + epsm1*eah) qsfcbare = qsfc @@ -877,7 +879,7 @@ subroutine noahmp_sflx (parameters, & esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in ficeold,ponding,tg ,ist ,fveg ,iloc,jloc , smceq , & !in bdfall ,fp ,rain ,snow , & !in mb/an: v3.7 - qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb + qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout @@ -911,9 +913,9 @@ subroutine noahmp_sflx (parameters, & if (opt_crop == 1 .and. crop_active) then call carbon_crop (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil ,julian , & !in dzsnso ,stc ,smc ,tv ,psn ,foln ,btran , & !in - soldn ,t2m , & !in + soldn ,t2m , & !in lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp ,grain , & !inout - lai ,sai ,gdd , & !inout + lai ,sai ,gdd , & !inout gpp ,npp ,nee ,autors ,heters ,totsc ,totlb, pgs ) !out end if @@ -964,7 +966,7 @@ subroutine atm (parameters,ep_2,epsm1,sfcprs ,sfctmp ,q2 , & prcpconv,prcpnonc ,prcpshcv,prcpsnow,prcpgrpl,prcphail , & soldn ,cosz ,thair ,qair , & eair ,rhoair ,qprecc ,qprecl ,solad , solai , & - swdown ,bdfall ,rain ,snow ,fp , fpice ,prcp ) + swdown ,bdfall ,rain ,snow ,fp , fpice ,prcp ) ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing ! ---------------------------------------------------------------------- @@ -1037,7 +1039,7 @@ subroutine atm (parameters,ep_2,epsm1,sfcprs ,sfctmp ,q2 , & if(opt_snf == 4) then qprecc = prcpconv + prcpshcv - qprecl = prcpnonc + qprecl = prcpnonc else qprecc = 0.10 * prcp ! should be from the atmospheric model qprecl = 0.90 * prcp ! should be from the atmospheric model @@ -1090,13 +1092,13 @@ subroutine atm (parameters,ep_2,epsm1,sfcprs ,sfctmp ,q2 , & if(opt_snf == 4 .or. opt_snf == 5) then prcp_frozen = prcpsnow + prcpgrpl + prcphail if(prcpnonc > 0. .and. prcp_frozen > 0.) then - fpice = min(1.0,prcp_frozen/prcpnonc) - fpice = max(0.0,fpice) + fpice = min(1.0,prcp_frozen/prcpnonc) + fpice = max(0.0,fpice) if(opt_snf==4) bdfall = bdfall*(prcpsnow/prcp_frozen) + rho_grpl*(prcpgrpl/prcp_frozen) + & rho_hail*(prcphail/prcp_frozen) if(opt_snf==5) bdfall = parameters%prcpiceden - else - fpice = 0.0 + else + fpice = 0.0 endif endif @@ -1233,8 +1235,8 @@ subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv bdfall ,rain ,snow ,fp , & !in canliq ,canice ,tv ,sfctmp ,tg , & !in qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out - pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out - fwet ,cmc ) !out + pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out + fwet ,cmc ) !out ! ------------------------ code history ------------------------------ ! michael barlage: oct 2013 - split canwater to calculate precip movement for @@ -1336,10 +1338,10 @@ subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv qintr = 0. qdripr = 0. qthror = rain - if(canliq > 0.) then ! for case of canopy getting buried - qdripr = qdripr + canliq/dt - canliq = 0.0 - end if + if(canliq > 0.) then ! for case of canopy getting buried + qdripr = qdripr + canliq/dt + canliq = 0.0 + end if end if ! heat transported by liquid water @@ -1363,7 +1365,7 @@ subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv ft = max(0.0,(tv - 270.15) / 1.87e5) fv = sqrt(uu*uu + vv*vv) / 1.56e5 ! mb: changed below to reflect the rain assumption that all precip gets intercepted - icedrip = max(0.,canice) * (fv+ft) !mb: removed /dt + icedrip = max(0.,canice) * (fv+ft) !mb: removed /dt qdrips = (fveg * snow - qints) + icedrip qthros = (1.0-fveg) * snow canice= max(0.,canice + (qints - icedrip)*dt) @@ -1371,10 +1373,10 @@ subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv qints = 0. qdrips = 0. qthros = snow - if(canice > 0.) then ! for case of canopy getting buried - qdrips = qdrips + canice/dt - canice = 0.0 - end if + if(canice > 0.) then ! for case of canopy getting buried + qdrips = qdrips + canice/dt + canice = 0.0 + end if endif ! print*, "precip_heat canopy through:",3600.0*(fveg * snow - qints) ! print*, "precip_heat canopy drip:",3600.0*max(0.,canice) * (fv+ft) @@ -1404,13 +1406,13 @@ subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv if (fveg > 0.0 .and. fveg < 1.0) then pahg = pahg / fveg ! these will be multiplied by fraction later - pahb = pahb / (1.0-fveg) + pahb = pahb / (1.0-fveg) elseif (fveg <= 0.0) then pahb = pahg + pahb ! for case of canopy getting buried pahg = 0.0 - pahv = 0.0 + pahv = 0.0 elseif (fveg >= 1.0) then - pahb = 0.0 + pahb = 0.0 end if pahv = max(pahv,-20.0) ! put some artificial limits here for stability @@ -1677,7 +1679,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in thsfc_loc, prslkix,prsik1x,prslk1x,garea1, & !in pblhx , iz0tlnd, itime,psi_opt,ep_1, ep_2, epsm1, cp, & - z0wrf ,z0hwrf , & !out + z0wrf ,z0hwrf , & !out imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out @@ -1697,7 +1699,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in t2mv ,t2mb ,fsrv , & fsrg ,rssun ,rssha ,albd ,albi,albsnd ,albsni,bgap ,wgap,tgv,tgb,& q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah,canhs,& - shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out !jref:end ! -------------------------------------------------------------------------------------------------- @@ -2211,19 +2213,19 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in if (tv .gt. tfrz) then ! barlage: add distinction between ground and latheav = hvap ! vegetation in v3.6 - frozen_canopy = .false. + frozen_canopy = .false. else latheav = hsub - frozen_canopy = .true. + frozen_canopy = .true. end if gammav = cpair*sfcprs/(ep_2*latheav) if (tg .gt. tfrz) then latheag = hvap - frozen_ground = .false. + frozen_ground = .false. else latheag = hsub - frozen_ground = .true. + frozen_ground = .true. end if gammag = cpair*sfcprs/(ep_2*latheag) @@ -2334,7 +2336,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in ssoil = fveg * ghv + (1.0 - fveg) * ghb fcev = evc fctr = tr - pah = fveg * pahg + (1.0 - fveg) * pahb + pahv + pah = fveg * pahg + (1.0 - fveg) * pahb + pahv tg = fveg * tgv + (1.0 - fveg) * tgb t2m = fveg * t2mv + (1.0 - fveg) * t2mb ts = fveg * tah + (1.0 - fveg) * tgb @@ -2364,7 +2366,7 @@ subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in t2m = t2mb fcev = 0. fctr = 0. - pah = pahb + pah = pahb ts = tg cm = cmb ch = chb @@ -3551,7 +3553,7 @@ subroutine twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & ! kopen = 1.0 else if(opt_rad == 1) then - denfveg = -log(max(1.0-fveg,0.01))/(pai*parameters%rc**2) + denfveg = -log(max(1.0-fveg,0.01))/(pai*parameters%rc**2) hd = parameters%hvt - parameters%hvb bb = 0.5 * hd thetap = atan(bb/parameters%rc * tan(acos(max(0.01,cosz))) ) @@ -4263,11 +4265,11 @@ subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & shc = fveg*rhoair*cpair*cvh * ( tv-tah) evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav - if (tv > tfrz) then + if (tv > tfrz) then evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 - else + else evc = min(canice*latheav/dt,evc) - end if + end if ! canopy heat capacity hcv = fveg*(parameters%cbiom*vaie*cwat + canliq*cwat/denh2o + canice*cice/denice) !j/m2/k @@ -7034,7 +7036,7 @@ subroutine water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in ficeold,ponding,tg ,ist ,fveg ,iloc ,jloc ,smceq , & !in bdfall ,fp ,rain ,snow, & !in mb/an: v3.7 - qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb + qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout @@ -7663,19 +7665,19 @@ subroutine combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in snice(j-1) = snice(j-1) + snice(j) dzsnso(j-1) = dzsnso(j-1) + dzsnso(j) else - if(snice(j) >= 0.) then + if(snice(j) >= 0.) then ponding1 = snliq(j) ! isnow will get set to zero below; ponding1 will get sneqv = snice(j) ! added to ponding from phasechange ponding should be snowh = dzsnso(j) ! zero here because it was calculated for thin snow - else ! snice over-sublimated earlier - ponding1 = snliq(j) + snice(j) - if(ponding1 < 0.) then ! if snice and snliq sublimates remove from soil - sice(1) = max(0.0,sice(1)+ponding1/(dzsnso(1)*1000.)) + else ! snice over-sublimated earlier + ponding1 = snliq(j) + snice(j) + if(ponding1 < 0.) then ! if snice and snliq sublimates remove from soil + sice(1) = max(0.0,sice(1)+ponding1/(dzsnso(1)*1000.)) ponding1 = 0.0 - end if + end if sneqv = 0.0 snowh = 0.0 - end if + end if snliq(j) = 0.0 snice(j) = 0.0 dzsnso(j) = 0.0 @@ -9762,7 +9764,7 @@ subroutine carbon_crop (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil ,julia dzsnso ,stc ,smc ,tv ,psn ,foln ,btran , & !in soldn ,t2m , & !in lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp ,grain , & !inout - xlai ,xsai ,gdd , & !inout + xlai ,xsai ,gdd , & !inout gpp ,npp ,nee ,autors ,heters ,totsc ,totlb, pgs ) !out ! ------------------------------------------------------------------------------------------ ! initial crop version created by xing liu @@ -10441,7 +10443,7 @@ end subroutine psn_crop !! subroutine noahmp_options(idveg , iopt_crs , iopt_btr , iopt_run , iopt_sfc , iopt_frz , & iopt_inf, iopt_rad , iopt_alb , iopt_snf , iopt_tbot, iopt_stc , & - iopt_rsf, iopt_soil, iopt_pedo, iopt_crop, iopt_trs , iopt_diag, & + iopt_rsf, iopt_soil, iopt_pedo, iopt_crop, iopt_trs , iopt_diag, & iopt_z0m ) implicit none diff --git a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 index a36b7a60a..baa0171de 100644 --- a/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 +++ b/physics/SFC_Models/Land/Noahmp/noahmpdrv.F90 @@ -1,4 +1,6 @@ +#ifndef CCPP #define CCPP +#endif !> \file noahmpdrv.F90 !! This file contains the NoahMP land surface scheme driver. @@ -1152,7 +1154,7 @@ subroutine noahmpdrv_run & call noahmp_options(idveg ,iopt_crs, iopt_btr , iopt_run, iopt_sfc, & iopt_frz, iopt_inf , iopt_rad, iopt_alb, & iopt_snf, iopt_tbot, iopt_stc, iopt_rsf, & - iopt_soil,iopt_pedo, iopt_crop,iopt_trs, & + iopt_soil,iopt_pedo, iopt_crop,iopt_trs, & iopt_diag,iopt_z0m) if ( vegetation_category == isice_table ) then @@ -1177,7 +1179,7 @@ subroutine noahmpdrv_run & temperature_soil_bot ,forcing_height ,snow_ice_frac_old ,zsoil , & thsfc_loc ,prslkix ,prsik1x ,prslk1x , & air_pressure_surface ,pblhx ,iz0tlnd ,itime , & - vegetation_frac ,area_grid ,psi_opt , & + vegetation_frac ,area_grid ,psi_opt , & con_fvirt ,con_eps ,con_epsm1 ,con_cp , & snowfall ,snow_water_equiv_old ,snow_albedo_old , & cm_noahmp ,ch_noahmp ,snow_levels ,snow_water_equiv , & @@ -1659,7 +1661,7 @@ subroutine transfer_mp_parameters (vegtype,soiltype,slopetype, & parameters%den = den_table(vegtype) !tree density (no. of trunks per m2) parameters%rc = rc_table(vegtype) !tree crown radius (m) parameters%mfsno = mfsno_table(vegtype) !snowmelt m parameter () - parameters%scffac = scffac_table(vegtype) !snow cover factor + parameters%scffac = scffac_table(vegtype) !snow cover factor parameters%cbiom = cbiom_table(vegtype) !canopy biomass heat capacity parameter (m) parameters%saim = saim_table(vegtype,:) !monthly stem area index, one-sided parameters%laim = laim_table(vegtype,:) !monthly leaf area index, one-sided diff --git a/physics/SFC_Models/Land/RUC/set_soilveg_ruc.F90 b/physics/SFC_Models/Land/RUC/set_soilveg_ruc.F90 index 012c81323..8e2f3f54a 100644 --- a/physics/SFC_Models/Land/RUC/set_soilveg_ruc.F90 +++ b/physics/SFC_Models/Land/RUC/set_soilveg_ruc.F90 @@ -45,36 +45,36 @@ subroutine set_soilveg_ruc(me,isot,ivet,nlunit,errmsg,errflg) if(ivet.eq.2) then ! Using umd veg classification slope_data =(/0.1, 0.6, 1.0, 0.35, 0.55, 0.8, & - & 0.63, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0/) + & 0.63, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0/) ! ---------------------------------------------------------------------- ! vegetation class-related arrays ! ---------------------------------------------------------------------- rstbl =(/300.0, 175.0, 175.0, 300.0, 300.0, 70.0, & - & 20.0, 225.0, 225.0, 225.0, 400.0, 20.0, & - & 150.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + & 20.0, 225.0, 225.0, 225.0, 400.0, 20.0, & + & 150.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) rgltbl =(/30.0, 30.0, 30.0, 30.0, 30.0, 65.0, & - & 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, & - & 100.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & - & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + & 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, & + & 100.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, & + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) hstbl =(/41.69, 54.53, 51.93, 47.35, 47.35, 54.53, & - & 36.35, 42.00, 42.00, 42.00, 42.00, 36.35, & - & 42.00, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & - & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) + & 36.35, 42.00, 42.00, 42.00, 42.00, 36.35, & + & 42.00, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, & + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) snuptbl =(/0.040, 0.040, 0.040, 0.040, 0.040, 0.040, & & 0.020, 0.020, 0.020, 0.020, 0.013, 0.020, & & 0.013, 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & - & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) bare =11 diff --git a/physics/SFC_Models/SeaIce/CICE/sfc_sice.f b/physics/SFC_Models/SeaIce/CICE/sfc_sice.f index a5904d67c..e5f2deae9 100644 --- a/physics/SFC_Models/SeaIce/CICE/sfc_sice.f +++ b/physics/SFC_Models/SeaIce/CICE/sfc_sice.f @@ -137,7 +137,8 @@ subroutine sfc_sice_run & ! ! - Define constant parameters integer, parameter :: kmi = 2 !< 2-layer of ice - real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys real(kind=kind_phys), parameter :: himax = 8.0_kind_phys !< maximum ice thickness allowed real(kind=kind_phys), parameter :: himin = 0.1_kind_phys !< minimum ice thickness required real(kind=kind_phys), parameter :: hsmax = 2.0_kind_phys !< maximum snow depth allowed @@ -541,8 +542,8 @@ subroutine ice3lay real (kind=kind_phys), parameter :: dili = di*li real (kind=kind_phys), parameter :: dsli = ds*li real (kind=kind_phys), parameter :: ki4 = ki*4.0_kind_phys - real (kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys - + real (kind=kind_phys), parameter :: zero = 0.0_kind_phys + real (kind=kind_phys), parameter :: one = 1.0_kind_phys ! --- inputs: integer, intent(in) :: im, kmi, ipr logical :: lprnt diff --git a/physics/docs/ccpp_doxyfile b/physics/docs/ccpp_doxyfile index 7e40361ae..4f62402e6 100644 --- a/physics/docs/ccpp_doxyfile +++ b/physics/docs/ccpp_doxyfile @@ -1066,7 +1066,6 @@ EXCLUDE = ../Radiation/RRTMGP/rte-rrtmgp \ ../MP/Ferrier_Aligo \ ../MP/Zhao_Carr \ ../PBL/MYJ \ - ../MP/GFDL/GFDL_parse_tracers.F90 \ ../PBL/HEDMF \ ../PBL/SHOC \ ../PBL/saYSU \ diff --git a/physics/docs/pdftxt/suite_input.nml.txt b/physics/docs/pdftxt/suite_input.nml.txt index cc529c4fb..462137f45 100644 --- a/physics/docs/pdftxt/suite_input.nml.txt +++ b/physics/docs/pdftxt/suite_input.nml.txt @@ -10,7 +10,7 @@ records \b &gfs_physics_nml. Some schemes have their own namelist records as des parameterizations. Its variables are defined in file GFS_typedefs.F90 in the host model. - Namelist \b &gfdl_cloud_microphysics_nml is only relevant when the GFDL microphysics is used, and its variables are defined in -module_gfdl_cloud_microphys.F90. +gfdl_cloud_microphys_mod.F90. - Namelist \b &cires_ugwp_nml specifies options for the use of CIRES Unified Gravity Wave Physics Version 0. diff --git a/physics/hooks/physcons.F90 b/physics/hooks/physcons.F90 index 4d86301e2..b368f1e6d 100644 --- a/physics/hooks/physcons.F90 +++ b/physics/hooks/physcons.F90 @@ -117,6 +117,7 @@ module physcons real(kind=kind_phys),parameter:: con_amn2o =44.013_kind_phys !< molecular wght of n2o (\f$g/mol\f$) real(kind=kind_phys),parameter:: con_thgni =-38.15_kind_phys !< temperature the H.G.Nuc. ice starts real(kind=kind_phys),parameter:: karman =0.4_kind_phys !< Von Karman constant + real(kind=kind_phys),parameter:: con_runiver=con_avgd*con_boltz !> minimum ice concentration real(kind=kind_phys),parameter:: cimin =0.15 !< minimum ice concentration @@ -141,10 +142,29 @@ module physcons real(kind=kind_phys),parameter:: rhosnow = 100._kind_phys !< density of snow (kg/m^3) real(kind=kind_phys),parameter:: rhoair = 1.28_kind_phys !< density of air near surface (kg/m^3) real(kind=kind_phys),parameter:: rholakeice = 0.917e3_kind_phys !< density of ice on lake (kg/m^3) + real(kind=kind_phys),parameter:: rhoair_IFS = 1._kind_phys !< reference air density (kg/m^3), ref: IFS ! Decorrelation length constant (km) for iovr = 4 or 5 and idcor = 0 real(kind=kind_phys),parameter:: decorr_con = 2.50_kind_phys +! for gfdlmp v3 + real(kind=kind_phys), parameter :: visd = 1.717e-5 ! dynamics viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (kg/m/s) + real(kind=kind_phys), parameter :: visk = 1.35e-5 ! kinematic viscosity of air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) + real(kind=kind_phys), parameter :: vdifu = 2.25e-5 ! diffusivity of water vapor in air at 0 deg C and 1000 hPa (Mason, 1971) (m^2/s) + real(kind=kind_phys), parameter :: tcond = 2.40e-2 ! thermal conductivity of air at 0 deg C and 1000 hPa (Mason, 1971) (J/m/s/K) + real(kind=kind_phys), parameter :: cdg = 3.15121 ! drag coefficient of graupel (Locatelli and Hobbs, 1974) + real(kind=kind_phys), parameter :: cdh = 0.5 ! drag coefficient of hail (Heymsfield and Wright, 2014) + real(kind=kind_phys), parameter :: rhocw = 1.0e3 ! density of cloud water (kg/m^3) + real(kind=kind_phys), parameter :: rhoci = 9.17e2 ! density of cloud ice (kg/m^3) + real(kind=kind_phys), parameter :: rhocr = 1.0e3 ! density of rain (Lin et al. 1983) (kg/m^3) + real(kind=kind_phys), parameter :: rhocg = 4.0e2 ! density of graupel (Rutledge and Hobbs 1984) (kg/m^3) + real(kind=kind_phys), parameter :: rhoch = 9.17e2 ! density of hail (Lin et al. 1983) (kg/m^3) + real(kind=kind_phys), parameter :: qcmin = 1.0e-15 ! min value for cloud condensates (kg/kg) + real(kind=kind_phys), parameter :: qfmin = 1.0e-8 ! min value for sedimentation (kg/kg) + real(kind=kind_phys), parameter :: con_one = 1_kind_phys + real(kind=kind_phys), parameter :: con_p001 = 0.001_kind_phys + real(kind=kind_phys), parameter :: con_secinday = 86400._kind_phys + !........................................! end module physcons ! !========================================! diff --git a/physics/photochem/module_h2ophys.F90 b/physics/photochem/module_h2ophys.F90 index 61a01d7b4..953232eb3 100644 --- a/physics/photochem/module_h2ophys.F90 +++ b/physics/photochem/module_h2ophys.F90 @@ -149,7 +149,7 @@ end subroutine update ! ######################################################################################### ! Procedure (type-bound) for NRL stratospheric h2o photochemistry physics. ! ######################################################################################### - subroutine run(this, dt, p, h2opltc, h2o) + subroutine run(this, dt, p, h2opltc, h2o, dqv_dt_prd, dqv_dt_qv) class(ty_h2ophys), intent(in) :: this real(kind_phys), intent(in) :: & dt ! Model timestep (sec) @@ -159,6 +159,9 @@ subroutine run(this, dt, p, h2opltc, h2o) h2opltc ! h2o forcing data real(kind_phys), intent(inout), dimension(:,:) :: & h2o ! h2o concentration (updated) + real(kind_phys), intent(inout), dimension(:, :), optional :: & + dqv_dt_prd, & ! Net production/loss effect + dqv_dt_qv ! water vapor effect integer :: nCol, nLev, iCol, iLev, iCf, kmax, kmin, k logical, dimension(size(p,1)) :: flg @@ -226,6 +229,15 @@ subroutine run(this, dt, p, h2opltc, h2o) h2o(iCol,iLev) = (h2oib(iCol) + (pltc(iCol,1)+pltc(iCol,3)*temp)*dt) / (1.0 + temp*dt) endif enddo + + if (present(dqv_dt_prd)) dqv_dt_prd(:, iLev) = pltc(:, 1) * dt + if (present(dqv_dt_qv)) then + where (pltc(:, 2) .ne. 0) + dqv_dt_qv(:, iLev) = (h2o(:, iLev) - pltc(:, 3)) * dt / pltc(:, 2) + elsewhere + dqv_dt_qv(:, iLev) = 0 + end where + end if enddo diff --git a/physics/tools/canopy_utils_mod.f b/physics/tools/canopy_utils_mod.f new file mode 100644 index 000000000..5630adf5d --- /dev/null +++ b/physics/tools/canopy_utils_mod.f @@ -0,0 +1,27 @@ + module canopy_utils_mod + + implicit none + + + contains + +!-------------------------------------------------------------------------- + + function IntegrateTrapezoid(x, y) + !! Calculates the integral of an array y with respect to x + !using the trapezoid + !! approximation. Note that the mesh spacing of x does not + !have to be uniform. + real, intent(in) :: x(:) !! Variable x + real, intent(in) :: y(size(x)) !! Function y(x) + real :: IntegrateTrapezoid !! Integral of y(x)dx + ! Integrate using the trapezoidal rule + associate(n => size(x)) + IntegrateTrapezoid = sum((y(1+1:n-0) + y(1+0:n-1))* + & (x(1+1:n-0) - x(1+0:n-1)))/2 + end associate + end function + +! --------------------------------------------------------------------------- + + end module canopy_utils_mod