diff --git a/.gitmodules b/.gitmodules index 8421166ca..5bcc65869 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,4 +1,4 @@ [submodule "physics/rte-rrtmgp"] path = physics/rte-rrtmgp - url = https://github.com/RobertPincus/rte-rrtmgp + url = https://github.com/earth-system-radiation/rte-rrtmgp branch = dtc/ccpp diff --git a/CMakeLists.txt b/CMakeLists.txt index 5e0175d0c..a18f0b0f3 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -17,6 +17,11 @@ if(POLICY CMP0042) cmake_policy(SET CMP0042 NEW) endif(POLICY CMP0042) +# CMP0057: Support new IN_LIST if() operator +if(POLICY CMP0057) + cmake_policy(SET CMP0057 NEW) +endif(POLICY CMP0057) + #------------------------------------------------------------------------------ set(PACKAGE "ccpp-physics") set(AUTHORS "Grant Firl" "Dom Heinzeller" "Man Zhang" "Laurie Carson") @@ -131,6 +136,7 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") # Set 32-bit floating point precision flags for certain files # that are executed in the dynamics (fast physics part) if (DYN32) + if (${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 IN_LIST SCHEMES) # Reduce floating point precision from 64-bit to 32-bit, if necessary set(CMAKE_Fortran_FLAGS_PREC32 ${CMAKE_Fortran_FLAGS_DEFAULT_PREC}) string(REPLACE "-fdefault-real-8" "" @@ -141,7 +147,8 @@ if (${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PREC32} ") # Add all of the above files to the list of schemes with special floating point precision flags list(APPEND SCHEMES_SFX_PREC ${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) - endif (DYN32) + endif() + endif() # Remove files with special floating point precision flags from list # of files with standard floating point precision flags flags @@ -179,29 +186,35 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_BL_MYJPBL.F90 PROPERTIES COMPILE_FLAGS "-r8 -ftz") - # Reduce optimization for module_sf_mynn.F90 (to avoid an apparent compiler bug with Intel 18 on Hera) - SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT} -O1") - list(APPEND SCHEMES_SFX_OPT ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90) + if (${CMAKE_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 IN_LIST SCHEMES) + # Reduce optimization for module_sf_mynn.F90 (to avoid an apparent compiler bug with Intel 18 on Hera) + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90 + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT} -O1") + list(APPEND SCHEMES_SFX_OPT ${CMAKE_CURRENT_SOURCE_DIR}/physics/module_sf_mynn.F90) + endif() - # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files - set(CMAKE_Fortran_FLAGS_LOPT1 ${CMAKE_Fortran_FLAGS_OPT}) - string(REPLACE "-xHOST" "-xCORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT1 - "${CMAKE_Fortran_FLAGS_LOPT1}") - string(REPLACE "-xCORE-AVX2" "-xCORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT1 - "${CMAKE_Fortran_FLAGS_LOPT1}") - string(REPLACE "-axSSE4.2,AVX,CORE-AVX2,CORE-AVX512" "-axSSE4.2,AVX,CORE-AVX-I" - CMAKE_Fortran_FLAGS_LOPT1 - "${CMAKE_Fortran_FLAGS_LOPT1}") - SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f - PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT1}") - # Add all of the above files to the list of schemes with special compiler flags - list(APPEND SCHEMES_SFX_OPT ${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f) + if (${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f IN_LIST SCHEMES) + # Replace -xHost or -xCORE-AVX2 with -xCORE-AVX-I for certain files + set(CMAKE_Fortran_FLAGS_LOPT1 ${CMAKE_Fortran_FLAGS_OPT}) + string(REPLACE "-xHOST" "-xCORE-AVX-I" + CMAKE_Fortran_FLAGS_LOPT1 + "${CMAKE_Fortran_FLAGS_LOPT1}") + string(REPLACE "-xCORE-AVX2" "-xCORE-AVX-I" + CMAKE_Fortran_FLAGS_LOPT1 + "${CMAKE_Fortran_FLAGS_LOPT1}") + string(REPLACE "-axSSE4.2,AVX,CORE-AVX2,CORE-AVX512" "-axSSE4.2,AVX,CORE-AVX-I" + CMAKE_Fortran_FLAGS_LOPT1 + "${CMAKE_Fortran_FLAGS_LOPT1}") + SET_SOURCE_FILES_PROPERTIES(${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f + PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_LOPT1}") + # Add all of the above files to the list of schemes with special compiler flags + list(APPEND SCHEMES_SFX_OPT ${CMAKE_CURRENT_SOURCE_DIR}/physics/radiation_aerosols.f) + endif() # Remove files with special compiler flags from list of files with standard compiler flags - list(REMOVE_ITEM SCHEMES ${SCHEMES_SFX_OPT}) + if (SCHEMES_SFX_OPT) + list(REMOVE_ITEM SCHEMES ${SCHEMES_SFX_OPT}) + endif(SCHEMES_SFX_OPT) # Assign standard compiler flags to all remaining schemes and caps SET_SOURCE_FILES_PROPERTIES(${SCHEMES} ${CAPS} PROPERTIES COMPILE_FLAGS "${CMAKE_Fortran_FLAGS_OPT}") @@ -209,6 +222,7 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") # Set 32-bit floating point precision flags for certain files # that are executed in the dynamics (fast physics part) if (DYN32) + if (${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90 IN_LIST SCHEMES) # Reduce floating point precision from 64-bit to 32-bit, if necessary set(CMAKE_Fortran_FLAGS_PREC32 ${CMAKE_Fortran_FLAGS_DEFAULT_PREC}) string(REPLACE "-real-size 64" "-real-size 32" @@ -217,7 +231,8 @@ elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") APPEND_STRING PROPERTY COMPILE_FLAGS " ${CMAKE_Fortran_FLAGS_PREC32} ") # Add all of the above files to the list of schemes with special floating point precision flags list(APPEND SCHEMES_SFX_PREC ${CMAKE_CURRENT_SOURCE_DIR}/physics/gfdl_fv_sat_adj.F90) - endif (DYN32) + endif() + endif() # Remove files with special floating point precision flags from list # of files with standard floating point precision flags flags diff --git a/physics/GFS_DCNV_generic.meta b/physics/GFS_DCNV_generic.meta index 85a7cfa74..507643661 100644 --- a/physics/GFS_DCNV_generic.meta +++ b/physics/GFS_DCNV_generic.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_DCNV_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = GFS_DCNV_generic_pre_run type = scheme @@ -148,6 +154,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_DCNV_generic_post + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_DCNV_generic_post_run diff --git a/physics/GFS_GWD_generic.meta b/physics/GFS_GWD_generic.meta index 614184975..ed7cd9629 100644 --- a/physics/GFS_GWD_generic.meta +++ b/physics/GFS_GWD_generic.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = GFS_GWD_generic_pre_init +[ccpp-table-properties] + name = GFS_GWD_generic_pre type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -244,10 +245,11 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = GFS_GWD_generic_pre_finalize +[ccpp-table-properties] + name = GFS_GWD_generic_post type = scheme - + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_GWD_generic_post_run diff --git a/physics/GFS_MP_generic.F90 b/physics/GFS_MP_generic.F90 index 73b26c7a3..8810cc7cf 100644 --- a/physics/GFS_MP_generic.F90 +++ b/physics/GFS_MP_generic.F90 @@ -109,8 +109,8 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, logical, intent(in) :: cal_pre, lssav, ldiag3d, qdiag3d, cplflx, cplchm real(kind=kind_phys), intent(in) :: dtf, frain, con_g - real(kind=kind_phys), dimension(im), intent(in) :: rainc, rain1, xlat, xlon, tsfc - real(kind=kind_phys), dimension(im), intent(inout) :: ice, snow, graupel + real(kind=kind_phys), dimension(im), intent(in) :: rain1, xlat, xlon, tsfc + real(kind=kind_phys), dimension(im), intent(inout) :: ice, snow, graupel, rainc real(kind=kind_phys), dimension(im), intent(in) :: rain0, ice0, snow0, graupel0 real(kind=kind_phys), dimension(im,nrcm), intent(in) :: rann real(kind=kind_phys), dimension(im,levs), intent(in) :: gt0, prsl, save_t, save_qv, del @@ -153,16 +153,16 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, integer, intent(out) :: errflg ! DH* TODO: CLEANUP, all of these should be coming in through the argument list - real(kind=kind_phys), parameter :: con_p001= 0.001d0 - real(kind=kind_phys), parameter :: con_day = 86400.0d0 - real(kind=kind_phys), parameter :: rainmin = 1.0d-13 - real(kind=kind_phys), parameter :: p850 = 85000.0d0 + real(kind=kind_phys), parameter :: con_p001= 0.001_kind_phys + real(kind=kind_phys), parameter :: con_day = 86400.0_kind_phys + real(kind=kind_phys), parameter :: rainmin = 1.0e-13_kind_phys + real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys ! *DH integer :: i, k, ic - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 - real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys) :: crain, csnow, onebg, tem, total_precip, tem1, tem2 real(kind=kind_phys), dimension(im) :: domr, domzr, domip, doms, t850, work1 ! Initialize CCPP error handling variables @@ -170,7 +170,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, errflg = 0 onebg = one/con_g - + do i = 1, im rain(i) = rainc(i) + frain * rain1(i) ! time-step convective plus explicit enddo @@ -184,7 +184,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, ! physics timestep, while Diag%{rain,rainc} and all totprecip etc ! are on the dynamics timestep. Confusing, but works if frain=1. *DH if (imp_physics == imp_physics_gfdl) then - tprcp = max(0., rain) ! clu: rain -> tprcp + tprcp = max(zero, rain) ! clu: rain -> tprcp !graupel = frain*graupel0 !ice = frain*ice0 !snow = frain*snow0 @@ -193,13 +193,13 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, snow = snow0 ! Do it right from the beginning for Thompson else if (imp_physics == imp_physics_thompson) then - tprcp = max (0.,rainc + frain * rain1) ! time-step convective and explicit precip + tprcp = max (zero, rainc + frain * rain1) ! time-step convective and explicit precip graupel = frain*graupel0 ! time-step graupel ice = frain*ice0 ! time-step ice snow = frain*snow0 ! time-step snow else if (imp_physics == imp_physics_fer_hires) then - tprcp = max (0.,rain) ! time-step convective and explicit precip + tprcp = max (zero, rain) ! time-step convective and explicit precip ice = frain*rain1*sr ! time-step ice end if @@ -213,7 +213,7 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, !Note (GJF): Precipitation LWE thicknesses are multiplied by the frain factor, and are thus on the dynamics time step, but the conversion as written ! (with dtp in the denominator) assumes the rate is calculated on the physics time step. This only works as expected when dtf=dtp (i.e. when frain=1). if (lsm == lsm_noahmp) then - tem = 1.0 / (dtp*con_p001) !GJF: This conversion was taken from GFS_physics_driver.F90, but should denominator also have the frain factor? + tem = one / (dtp*con_p001) !GJF: This conversion was taken from GFS_physics_driver.F90, but should denominator also have the frain factor? draincprv(:) = tem * raincprv(:) drainncprv(:) = tem * rainncprv(:) dsnowprv(:) = tem * snowprv(:) @@ -234,11 +234,11 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, if (imp_physics /= imp_physics_gfdl .and. imp_physics /= imp_physics_thompson) then do i=1,im - tprcp(i) = max(0.0, rain(i) ) - if(doms(i) > 0.0 .or. domip(i) > 0.0) then - srflag(i) = 1. + tprcp(i) = max(zero, rain(i) ) + if(doms(i) > zero .or. domip(i) > zero) then + srflag(i) = one else - srflag(i) = 0. + srflag(i) = zero end if enddo endif @@ -253,40 +253,6 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, endif - if (lssav) then -! if (Model%me == 0) print *,'in phys drive, kdt=',Model%kdt, & -! 'totprcpb=', Diag%totprcpb(1),'totprcp=',Diag%totprcp(1), & -! 'rain=',Diag%rain(1) - do i=1,im - cnvprcp (i) = cnvprcp (i) + rainc(i) - totprcp (i) = totprcp (i) + rain(i) - totice (i) = totice (i) + ice(i) - totsnw (i) = totsnw (i) + snow(i) - totgrp (i) = totgrp (i) + graupel(i) - - cnvprcpb(i) = cnvprcpb(i) + rainc(i) - totprcpb(i) = totprcpb(i) + rain(i) - toticeb (i) = toticeb (i) + ice(i) - totsnwb (i) = totsnwb (i) + snow(i) - totgrpb (i) = totgrpb (i) + graupel(i) - enddo - - if (ldiag3d) then - do k=1,levs - do i=1,im - dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain - enddo - enddo - if (qdiag3d) then - do k=1,levs - do i=1,im - dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain - enddo - enddo - endif - endif - endif - t850(1:im) = gt0(1:im,1) do k = 1, levs-1 @@ -306,19 +272,21 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, !! and determine explicit rain/snow by snow/ice/graupel coming out directly from MP !! and convective rainfall from the cumulus scheme if the surface temperature is below !! \f$0^oC\f$. + if (imp_physics == imp_physics_gfdl .or. imp_physics == imp_physics_thompson) then + ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP if (lsm /= lsm_ruc) then do i = 1, im !tprcp(i) = max(0.0, rain(i) )! clu: rain -> tprcp ! DH now lines 245-250 - srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) - if (tsfc(i) >= 273.15) then + srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) + if (tsfc(i) >= 273.15_kind_phys) then crain = rainc(i) - csnow = 0.0 + csnow = zero else - crain = 0.0 + crain = zero csnow = rainc(i) endif ! if (snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow > rain0(i,1)+crain) then @@ -338,30 +306,68 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, endif ! lsm==lsm_ruc elseif( .not. cal_pre) then if (imp_physics == imp_physics_mg) then ! MG microphysics - tem = con_day / (dtp * con_p001) ! mm / day do i=1,im - tprcp(i) = max(0.0, rain(i) ) ! clu: rain -> tprcp - if (rain(i)*tem > rainmin) then - srflag(i) = max(zero, min(one, (rain(i)-rainc(i))*sr(i)/rain(i))) + if (rain(i) > rainmin) then + tem1 = max(zero, (rain(i)-rainc(i))) * sr(i) + tem2 = one / rain(i) + if (t850(i) > 273.16_kind_phys) then + srflag(i) = max(zero, min(one, tem1*tem2)) + else + srflag(i) = max(zero, min(one, (tem1+rainc(i))*tem2)) + endif else - srflag(i) = 0.0 + srflag(i) = zero + rain(i) = zero + rainc(i) = zero endif + tprcp(i) = max(zero, rain(i)) enddo - else + else ! not GFDL or MG or Thompson microphysics do i = 1, im - tprcp(i) = max(0.0, rain(i) ) ! clu: rain -> tprcp - srflag(i) = 0.0 ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16) then - srflag(i) = 1.0 ! clu: set srflag to 'snow' (i.e. 1) - endif + tprcp(i) = max(zero, rain(i)) + srflag(i) = sr(i) enddo endif endif + if (lssav) then +! if (Model%me == 0) print *,'in phys drive, kdt=',Model%kdt, & +! 'totprcpb=', Diag%totprcpb(1),'totprcp=',Diag%totprcp(1), & +! 'rain=',Diag%rain(1) + do i=1,im + cnvprcp (i) = cnvprcp (i) + rainc(i) + totprcp (i) = totprcp (i) + rain(i) + totice (i) = totice (i) + ice(i) + totsnw (i) = totsnw (i) + snow(i) + totgrp (i) = totgrp (i) + graupel(i) + + cnvprcpb(i) = cnvprcpb(i) + rainc(i) + totprcpb(i) = totprcpb(i) + rain(i) + toticeb (i) = toticeb (i) + ice(i) + totsnwb (i) = totsnwb (i) + snow(i) + totgrpb (i) = totgrpb (i) + graupel(i) + enddo + + if (ldiag3d) then + do k=1,levs + do i=1,im + dt3dt(i,k) = dt3dt(i,k) + (gt0(i,k)-save_t(i,k)) * frain + enddo + enddo + if (qdiag3d) then + do k=1,levs + do i=1,im + dq3dt(i,k) = dq3dt(i,k) + (gq0(i,k,1)-save_qv(i,k)) * frain + enddo + enddo + endif + endif + endif + if (cplflx .or. cplchm) then do i = 1, im - drain_cpl(i) = rain(i) * (one-srflag(i)) - dsnow_cpl(i) = rain(i) * srflag(i) + dsnow_cpl(i)= max(zero, rain(i) * srflag(i)) + drain_cpl(i)= max(zero, rain(i) - dsnow_cpl(i)) rain_cpl(i) = rain_cpl(i) + drain_cpl(i) snow_cpl(i) = snow_cpl(i) + dsnow_cpl(i) enddo @@ -373,10 +379,10 @@ subroutine GFS_MP_generic_post_run(im, levs, kdt, nrcm, ncld, nncl, ntcw, ntrac, enddo endif - pwat(:) = 0.0 + pwat(:) = zero do k = 1, levs do i=1, im - work1(i) = 0.0 + work1(i) = zero enddo if (ncld > 0) then do ic = ntcw, ntcw+nncl-1 diff --git a/physics/GFS_MP_generic.meta b/physics/GFS_MP_generic.meta index 727f735ee..1850a6759 100644 --- a/physics/GFS_MP_generic.meta +++ b/physics/GFS_MP_generic.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = GFS_MP_generic_pre_init +[ccpp-table-properties] + name = GFS_MP_generic_pre type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -134,14 +135,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = GFS_MP_generic_pre_finalize - type = scheme - -######################################################################## -[ccpp-arg-table] - name = GFS_MP_generic_post_init +[ccpp-table-properties] + name = GFS_MP_generic_post type = scheme + dependencies = calpreciptype.f90,machine.F ######################################################################## [ccpp-arg-table] @@ -732,8 +729,8 @@ intent = inout optional = F [do_sppt] - standard_name = flag_for_stochastic_surface_physics_perturbations - long_name = flag for stochastic surface physics perturbations + standard_name = flag_for_stochastic_physics_perturbations + long_name = flag for stochastic physics perturbations units = flag dimensions = () type = logical @@ -924,7 +921,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = GFS_MP_generic_post_finalize - type = scheme diff --git a/physics/GFS_PBL_generic.F90 b/physics/GFS_PBL_generic.F90 index 77be662fa..357309b2a 100644 --- a/physics/GFS_PBL_generic.F90 +++ b/physics/GFS_PBL_generic.F90 @@ -92,6 +92,7 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, implicit none + integer, parameter :: kp = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc integer, intent(in) :: ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef,ntchs, ntchm @@ -110,6 +111,8 @@ subroutine GFS_PBL_generic_pre_run (im, levs, nvdiff, ntrac, character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg + real (kind=kind_phys), parameter :: zero = 0.0_kp, one=1.0_kp + ! Local variables integer :: i, k, kk, k1, n @@ -322,6 +325,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, implicit none + integer, parameter :: kp = kind_phys integer, intent(in) :: im, levs, nvdiff, ntrac, ntchs, ntchm integer, intent(in) :: ntqv, ntcw, ntiw, ntrw, ntsw, ntlnc, ntinc, ntrnc, ntsnc, ntgnc, ntwa, ntia, ntgl, ntoz, ntke, ntkev, nqrimef logical, intent(in) :: trans_aero @@ -356,14 +360,14 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ! use assumed-shape arrays. Note that Intel 18 and GNU 6.2.0-8.1.0 tolerate explicit-shape arrays ! as long as these do not get used when not allocated. real(kind=kind_phys), dimension(:,:), intent(inout) :: dt3dt, du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, dq3dt, dq3dt_ozone - real(kind=kind_phys), dimension(:), intent(inout) :: dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, & + real(kind=kind_phys), dimension(:), intent(inout) :: dusfc_cpl, dvsfc_cpl, dtsfc_cpl, dqsfc_cpl, dusfci_cpl, dvsfci_cpl, & dtsfci_cpl, dqsfci_cpl, dusfc_diag, dvsfc_diag, dtsfc_diag, dqsfc_diag, dusfci_diag, dvsfci_diag, dtsfci_diag, dqsfci_diag logical, dimension(:),intent(in) :: wet, dry, icy real(kind=kind_phys), dimension(:), intent(out) :: ushfsfci real(kind=kind_phys), dimension(:,:), intent(inout) :: dkt_cpl - real(kind=kind_phys), dimension(:,:), intent(in) :: dkt + real(kind=kind_phys), dimension(:,:), intent(in) :: dkt ! From canopy heat storage - reduction factors in latent/sensible heat flux due to surface roughness real(kind=kind_phys), dimension(im), intent(in) :: hffac, hefac @@ -371,11 +375,11 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - real(kind=kind_phys), parameter :: zero = 0.0d0 - real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_kp, one = 1.0_kp real(kind=kind_phys), parameter :: huge = 9.9692099683868690E36 ! NetCDF float FillValue, same as in GFS_typedefs.F90 + real(kind=kind_phys), parameter :: qmin = 1.0e-8_kp integer :: i, k, kk, k1, n - real(kind=kind_phys) :: tem, tem1, rho + real(kind=kind_phys) :: tem, rho ! Initialize CCPP error handling variables errmsg = '' @@ -428,12 +432,12 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, ! Ferrier-Aligo do k=1,levs do i=1,im - dqdt(i,k,ntqv) = dvdftra(i,k,1) - dqdt(i,k,ntcw) = dvdftra(i,k,2) - dqdt(i,k,ntiw) = dvdftra(i,k,3) - dqdt(i,k,ntrw) = dvdftra(i,k,4) + dqdt(i,k,ntqv) = dvdftra(i,k,1) + dqdt(i,k,ntcw) = dvdftra(i,k,2) + dqdt(i,k,ntiw) = dvdftra(i,k,3) + dqdt(i,k,ntrw) = dvdftra(i,k,4) dqdt(i,k,nqrimef) = dvdftra(i,k,5) - dqdt(i,k,ntoz) = dvdftra(i,k,6) + dqdt(i,k,ntoz) = dvdftra(i,k,6) enddo enddo @@ -531,8 +535,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, if (cplchm) then do i = 1, im - tem1 = max(q1(i), 1.e-8) - tem = prsl(i,1) / (rd*t1(i)*(one+fvirt*tem1)) + tem = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) ushfsfci(i) = -cp * tem * hflx(i) ! upward sensible heat flux enddo ! dkt_cpl has dimensions (1:im,1:levs), but dkt has (1:im,1:levs-1) @@ -558,8 +561,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, dqsfci_cpl(i) = dqsfc1(i) end if elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point - tem1 = max(q1(i), 1.e-8) - rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*tem1)) + rho = prsl(i,1) / (rd*t1(i)*(one+fvirt*max(q1(i), qmin))) if (wind(i) > zero) then tem = - rho * stress_wat(i) / wind(i) dusfci_cpl(i) = tem * ugrs1(i) ! U-momentum flux @@ -595,14 +597,14 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, !-------------------------------------------------------lssav if loop ---------- if (lssav) then do i=1,im - dusfc_diag (i) = dusfc_diag(i) + dusfc1(i)*dtf - dvsfc_diag (i) = dvsfc_diag(i) + dvsfc1(i)*dtf - dtsfc_diag (i) = dtsfc_diag(i) + dtsfc1(i)*hffac(i)*dtf - dqsfc_diag (i) = dqsfc_diag(i) + dqsfc1(i)*hefac(i)*dtf + dusfc_diag (i) = dusfc_diag(i) + dusfc1(i) * dtf + dvsfc_diag (i) = dvsfc_diag(i) + dvsfc1(i) * dtf dusfci_diag(i) = dusfc1(i) dvsfci_diag(i) = dvsfc1(i) dtsfci_diag(i) = dtsfc1(i)*hffac(i) dqsfci_diag(i) = dqsfc1(i)*hefac(i) + dtsfc_diag (i) = dtsfc_diag(i) + dtsfci_diag(i) * dtf + dqsfc_diag (i) = dqsfc_diag(i) + dqsfci_diag(i) * dtf enddo if (ldiag3d .and. flag_for_pbl_generic_tend .and. lssav) then @@ -624,7 +626,7 @@ subroutine GFS_PBL_generic_post_run (im, levs, nvdiff, ntrac, if(qdiag3d) then do k=1,levs do i=1,im - dq3dt(i,k) = dq3dt(i,k) + (qgrs(i,k,ntqv)-save_q(i,k,ntqv)) + dq3dt (i,k) = dq3dt (i,k) + (qgrs(i,k,ntqv)-save_q(i,k,ntqv)) dq3dt_ozone(i,k) = dq3dt_ozone(i,k) + (qgrs(i,k,ntoz)-save_q(i,k,ntoz)) enddo enddo diff --git a/physics/GFS_PBL_generic.meta b/physics/GFS_PBL_generic.meta index 51962c37b..972af4859 100644 --- a/physics/GFS_PBL_generic.meta +++ b/physics/GFS_PBL_generic.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_PBL_generic_pre + type = scheme + dependencies = GFS_PBL_generic.F90,machine.F + +######################################################################## [ccpp-arg-table] name = GFS_PBL_generic_pre_run type = scheme @@ -412,6 +418,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_PBL_generic_post + type = scheme + dependencies = GFS_PBL_generic.F90,machine.F + ######################################################################## [ccpp-arg-table] name = GFS_PBL_generic_post_run diff --git a/physics/GFS_SCNV_generic.meta b/physics/GFS_SCNV_generic.meta index e11e3fbc3..47fd151af 100644 --- a/physics/GFS_SCNV_generic.meta +++ b/physics/GFS_SCNV_generic.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_SCNV_generic_pre + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = GFS_SCNV_generic_pre_run type = scheme @@ -131,6 +137,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_SCNV_generic_post + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_SCNV_generic_post_run diff --git a/physics/GFS_cloud_diagnostics.meta b/physics/GFS_cloud_diagnostics.meta index f78a76490..3778d6036 100644 --- a/physics/GFS_cloud_diagnostics.meta +++ b/physics/GFS_cloud_diagnostics.meta @@ -1,3 +1,7 @@ +[ccpp-table-properties] + name = GFS_cloud_diagnostics + type = scheme + ######################################################################## [ccpp-arg-table] name = GFS_cloud_diagnostics_run diff --git a/physics/GFS_debug.F90 b/physics/GFS_debug.F90 index d1e42f162..35b44ca0e 100644 --- a/physics/GFS_debug.F90 +++ b/physics/GFS_debug.F90 @@ -1,37 +1,313 @@ !> \file GFS_debug.F90 - module GFS_diagtoscreen - - private - public GFS_diagtoscreen_init, GFS_diagtoscreen_run, GFS_diagtoscreen_finalize - - public print_my_stuff, chksum_int, chksum_real, print_var +!! +!! This is the place to switch between different debug outputs. +!! - The default behavior for Intel (or any compiler other than GNU) +!! is to print mininmum, maximum and 32-bit Adler checksum for arrays. +!! - The default behavior for GNU is to mininmum, maximum and +!! mean value of arrays, because calculating the checksum leads +!! to segmentation faults with gfortran (bug in malloc?). +!! - If none of the #define preprocessor statements is used, +!! arrays are printed in full (this is often unpractical). +!! - All output to stdout/stderr from these routines are prefixed +!! with 'XXX: ' so that they can be easily removed from the log files +!! using "grep -ve 'XXX: ' ..." if needed. +!! - Only one #define statement can be active at any time +!! +!! Available options for debug output: +!! +!! #define PRINT_SUM: print mininmum, maximum and mean value of arrays +!! +!! #define PRINT_CHKSUM: mininmum, maximum and 32-bit Adler checksum for arrays +!! -! Calculating the checksum leads to segmentation faults with gfortran (bug in malloc?), -! thus print the sum of the array instead of the checksum. #ifdef __GFORTRAN__ #define PRINT_SUM #else #define PRINT_CHKSUM #endif +!! +!! +!! + + module print_var_chksum + + use machine, only: kind_phys + + implicit none + + private + + public chksum_int, chksum_real, print_var + interface print_var module procedure print_logic_0d module procedure print_logic_1d module procedure print_int_0d module procedure print_int_1d + module procedure print_int_2d module procedure print_real_0d module procedure print_real_1d module procedure print_real_2d module procedure print_real_3d + module procedure print_real_4d end interface - integer, parameter :: ISTART = 1 - integer, parameter :: IEND = 9999999 + contains + + subroutine print_logic_0d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + logical, intent(in) :: var + + write(0,'(2a,3i6,1x,l)') 'XXX: ', trim(name), mpirank, omprank, blkno, var + + end subroutine print_logic_0d + + subroutine print_logic_1d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + logical, intent(in) :: var(:) + + integer :: i + +#ifdef PRINT_SUM + write(0,'(2a,3i6,2i8)') 'XXX: ', trim(name), mpirank, omprank, blkno, size(var), count(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,2i8)') 'XXX: ', trim(name), mpirank, omprank, blkno, size(var), count(var) +#else + do i=lbound(var,1),ubound(var,1) + write(0,'(2a,3i6,i6,2e16.7,1x,l)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, lat_d(i), lon_d(i), var(i) + end do +#endif + + end subroutine print_logic_1d + + subroutine print_int_0d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + integer, intent(in) :: var + + write(0,'(2a,3i6,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, var + + end subroutine print_int_0d + + subroutine print_int_1d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + integer, intent(in) :: var(:) + + integer :: i + +#ifdef PRINT_SUM + write(0,'(2a,3i6,3i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_int(size(var),var), minval(var), maxval(var) +#else + do i=lbound(var,1),ubound(var,1) + write(0,'(2a,3i6,i6,2e16.7,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, lat_d(i), lon_d(i), var(i) + end do +#endif + + end subroutine print_int_1d + + subroutine print_int_2d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + integer, intent(in) :: var(:,:) + + integer :: i, k + +#ifdef PRINT_SUM + write(0,'(2a,3i6,3i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_int(size(var),var), minval(var), maxval(var) +#else + do i=lbound(var,1),ubound(var,1) + do k=lbound(var,2),ubound(var,2) + write(0,'(2a,3i6,2i6,2e16.7,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, lat_d(i), lon_d(i), var(i,k) + end do + end do +#endif + + end subroutine print_int_2d + + subroutine print_real_0d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + real(kind_phys), intent(in) :: var + + write(0,'(2a,3i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, var + + end subroutine print_real_0d + + subroutine print_real_1d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + real(kind_phys), intent(in) :: var(:) + + integer :: i + +#ifdef PRINT_SUM + write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),var), minval(var), maxval(var) +#else + do i=lbound(var,1),ubound(var,1) + write(0,'(2a,3i6,i6,2e16.7,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, lat_d(i), lon_d(i), var(i) + end do +#endif + + end subroutine print_real_1d + + subroutine print_real_2d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + real(kind_phys), intent(in) :: var(:,:) + + integer :: k, i + +#ifdef PRINT_SUM + write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) +#else + do i=lbound(var,1),ubound(var,1) + do k=lbound(var,2),ubound(var,2) + write(0,'(2a,3i6,2i6,2e16.7,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, lat_d(i), lon_d(i), var(i,k) + end do + end do +#endif + + end subroutine print_real_2d + + subroutine print_real_3d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + real(kind_phys), intent(in) :: var(:,:,:) + + integer :: k, i, l + +#ifdef PRINT_SUM + write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) +#else + do i=lbound(var,1),ubound(var,1) + do k=lbound(var,2),ubound(var,2) + do l=lbound(var,3),ubound(var,3) + write(0,'(2a,3i6,3i6,2e16.7,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, l, lat_d(i), lon_d(i), var(i,k,l) + end do + end do + end do +#endif + + end subroutine print_real_3d + + subroutine print_real_4d(mpirank, omprank, blkno, lat_d, lon_d, name, var) + + integer, intent(in) :: mpirank, omprank, blkno + real(kind_phys), intent(in) :: lat_d(:), lon_d(:) + character(len=*), intent(in) :: name + real(kind_phys), intent(in) :: var(:,:,:,:) + + integer :: k, i, l, m + +#ifdef PRINT_SUM + write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) +#elif defined(PRINT_CHKSUM) + write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) +#else + do i=lbound(var,1),ubound(var,1) + do k=lbound(var,2),ubound(var,2) + do l=lbound(var,3),ubound(var,3) + do m=lbound(var,4),ubound(var,4) + write(0,'(2a,3i6,4i6,2e16.7,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, l, m, lat_d(i), lon_d(i), var(i,k,l,m) + end do + end do + end do + end do +#endif + + end subroutine print_real_4d + + function chksum_int(N, var) result(hash) + + integer, intent(in) :: N + integer, dimension(1:N), intent(in) :: var + integer*8, dimension(1:N) :: int_var + integer*8 :: a, b, i, hash + integer*8, parameter :: mod_adler=65521 + + a=1 + b=0 + i=1 + hash = 0 + int_var = TRANSFER(var, a, N) + + do i= 1, N + a = MOD(a + int_var(i), mod_adler) + b = MOD(b+a, mod_adler) + end do + + hash = ior(b * 65536, a) + + end function chksum_int + + function chksum_real(N, var) result(hash) + + integer, intent(in) :: N + real(kind_phys), dimension(1:N), intent(in) :: var + integer*8, dimension(1:N) :: int_var + integer*8 :: a, b, i, hash + integer*8, parameter :: mod_adler=65521 + + a=1 + b=0 + i=1 + hash = 0 + int_var = TRANSFER(var, a, N) + + do i= 1, N + a = MOD(a + int_var(i), mod_adler) + b = MOD(b+a, mod_adler) + end do + + hash = ior(b * 65536, a) + + end function chksum_real + + end module print_var_chksum + + module GFS_diagtoscreen + + use print_var_chksum, only: print_var - integer, parameter :: KSTART = 1 - integer, parameter :: KEND = 9999999 + implicit none + + private + + public GFS_diagtoscreen_init, GFS_diagtoscreen_run, GFS_diagtoscreen_finalize contains @@ -117,405 +393,407 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, do impi=0,mpisize-1 do iomp=0,ompsize-1 if (mpirank==impi .and. omprank==iomp) then - call print_var(mpirank,omprank, blkno, 'Model%kdt' , Model%kdt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Model%kdt' , Model%kdt) ! Sfcprop - call print_var(mpirank,omprank, blkno, 'Sfcprop%slmsk' , Sfcprop%slmsk) - call print_var(mpirank,omprank, blkno, 'Sfcprop%oceanfrac', Sfcprop%oceanfrac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%landfrac' , Sfcprop%landfrac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%lakefrac' , Sfcprop%lakefrac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tsfc' , Sfcprop%tsfc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tsfco' , Sfcprop%tsfco) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tsfcl' , Sfcprop%tsfcl) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tisfc' , Sfcprop%tisfc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%snowd' , Sfcprop%snowd) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zorl' , Sfcprop%zorl) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zorlo' , Sfcprop%zorlo) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zorll' , Sfcprop%zorll) - call print_var(mpirank,omprank, blkno, 'Sfcprop%fice' , Sfcprop%fice) - call print_var(mpirank,omprank, blkno, 'Sfcprop%hprime' , Sfcprop%hprime) - call print_var(mpirank,omprank, blkno, 'Sfcprop%sncovr' , Sfcprop%sncovr) - call print_var(mpirank,omprank, blkno, 'Sfcprop%snoalb' , Sfcprop%snoalb) - call print_var(mpirank,omprank, blkno, 'Sfcprop%alvsf' , Sfcprop%alvsf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%alnsf' , Sfcprop%alnsf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%alvwf' , Sfcprop%alvwf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%alnwf' , Sfcprop%alnwf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%facsf' , Sfcprop%facsf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%facwf' , Sfcprop%facwf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%slope' , Sfcprop%slope) - call print_var(mpirank,omprank, blkno, 'Sfcprop%shdmin' , Sfcprop%shdmin) - call print_var(mpirank,omprank, blkno, 'Sfcprop%shdmax' , Sfcprop%shdmax) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tg3' , Sfcprop%tg3) - call print_var(mpirank,omprank, blkno, 'Sfcprop%vfrac' , Sfcprop%vfrac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%vtype' , Sfcprop%vtype) - call print_var(mpirank,omprank, blkno, 'Sfcprop%stype' , Sfcprop%stype) - call print_var(mpirank,omprank, blkno, 'Sfcprop%uustar' , Sfcprop%uustar) - call print_var(mpirank,omprank, blkno, 'Sfcprop%oro' , Sfcprop%oro) - call print_var(mpirank,omprank, blkno, 'Sfcprop%oro_uf' , Sfcprop%oro_uf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%hice' , Sfcprop%hice) - call print_var(mpirank,omprank, blkno, 'Sfcprop%weasd' , Sfcprop%weasd) - call print_var(mpirank,omprank, blkno, 'Sfcprop%canopy' , Sfcprop%canopy) - call print_var(mpirank,omprank, blkno, 'Sfcprop%ffmm' , Sfcprop%ffmm) - call print_var(mpirank,omprank, blkno, 'Sfcprop%ffhh' , Sfcprop%ffhh) - call print_var(mpirank,omprank, blkno, 'Sfcprop%f10m' , Sfcprop%f10m) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tprcp' , Sfcprop%tprcp) - call print_var(mpirank,omprank, blkno, 'Sfcprop%srflag' , Sfcprop%srflag) - call print_var(mpirank,omprank, blkno, 'Sfcprop%slc' , Sfcprop%slc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%smc' , Sfcprop%smc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%stc' , Sfcprop%stc) - call print_var(mpirank,omprank, blkno, 'Sfcprop%t2m' , Sfcprop%t2m) - call print_var(mpirank,omprank, blkno, 'Sfcprop%q2m' , Sfcprop%q2m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slmsk' , Sfcprop%slmsk) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oceanfrac', Sfcprop%oceanfrac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%landfrac' , Sfcprop%landfrac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%lakefrac' , Sfcprop%lakefrac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfc' , Sfcprop%tsfc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfco' , Sfcprop%tsfco) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsfcl' , Sfcprop%tsfcl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tisfc' , Sfcprop%tisfc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%snowd' , Sfcprop%snowd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorl' , Sfcprop%zorl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorlo' , Sfcprop%zorlo) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zorll' , Sfcprop%zorll) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%fice' , Sfcprop%fice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%hprime' , Sfcprop%hprime) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%sncovr' , Sfcprop%sncovr) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%snoalb' , Sfcprop%snoalb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alvsf' , Sfcprop%alvsf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alnsf' , Sfcprop%alnsf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alvwf' , Sfcprop%alvwf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%alnwf' , Sfcprop%alnwf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%facsf' , Sfcprop%facsf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%facwf' , Sfcprop%facwf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slope' , Sfcprop%slope) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%shdmin' , Sfcprop%shdmin) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%shdmax' , Sfcprop%shdmax) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tg3' , Sfcprop%tg3) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%vfrac' , Sfcprop%vfrac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%vtype' , Sfcprop%vtype) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stype' , Sfcprop%stype) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%uustar' , Sfcprop%uustar) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro' , Sfcprop%oro) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%oro_uf' , Sfcprop%oro_uf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%hice' , Sfcprop%hice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%weasd' , Sfcprop%weasd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%canopy' , Sfcprop%canopy) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffmm' , Sfcprop%ffmm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ffhh' , Sfcprop%ffhh) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%f10m' , Sfcprop%f10m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tprcp' , Sfcprop%tprcp) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%srflag' , Sfcprop%srflag) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%slc' , Sfcprop%slc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%smc' , Sfcprop%smc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%stc' , Sfcprop%stc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%t2m' , Sfcprop%t2m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%q2m' , Sfcprop%q2m) if (Model%nstf_name(1)>0) then - call print_var(mpirank,omprank, blkno, 'Sfcprop%tref ', Sfcprop%tref) - call print_var(mpirank,omprank, blkno, 'Sfcprop%z_c ', Sfcprop%z_c) - call print_var(mpirank,omprank, blkno, 'Sfcprop%c_0 ', Sfcprop%c_0) - call print_var(mpirank,omprank, blkno, 'Sfcprop%c_d ', Sfcprop%c_d) - call print_var(mpirank,omprank, blkno, 'Sfcprop%w_0 ', Sfcprop%w_0) - call print_var(mpirank,omprank, blkno, 'Sfcprop%w_d ', Sfcprop%w_d) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xt ', Sfcprop%xt) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xs ', Sfcprop%xs) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xu ', Sfcprop%xu) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xv ', Sfcprop%xv) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xz ', Sfcprop%xz) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zm ', Sfcprop%zm) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xtts ', Sfcprop%xtts) - call print_var(mpirank,omprank, blkno, 'Sfcprop%xzts ', Sfcprop%xzts) - call print_var(mpirank,omprank, blkno, 'Sfcprop%d_conv ', Sfcprop%d_conv) - call print_var(mpirank,omprank, blkno, 'Sfcprop%ifd ', Sfcprop%ifd) - call print_var(mpirank,omprank, blkno, 'Sfcprop%dt_cool ', Sfcprop%dt_cool) - call print_var(mpirank,omprank, blkno, 'Sfcprop%qrain ', Sfcprop%qrain) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tref ', Sfcprop%tref) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%z_c ', Sfcprop%z_c) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%c_0 ', Sfcprop%c_0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%c_d ', Sfcprop%c_d) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%w_0 ', Sfcprop%w_0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%w_d ', Sfcprop%w_d) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%xt ', Sfcprop%xt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%xs ', Sfcprop%xs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%xu ', Sfcprop%xu) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%xv ', Sfcprop%xv) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%xz ', Sfcprop%xz) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zm ', Sfcprop%zm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%xtts ', Sfcprop%xtts) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%xzts ', Sfcprop%xzts) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%d_conv ', Sfcprop%d_conv) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%ifd ', Sfcprop%ifd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%dt_cool ', Sfcprop%dt_cool) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%qrain ', Sfcprop%qrain) end if ! CCPP/RUC only if (Model%lsm == Model%lsm_ruc) then - call print_var(mpirank,omprank, blkno, 'Sfcprop%sh2o', Sfcprop%sh2o) - call print_var(mpirank,omprank, blkno, 'Sfcprop%smois', Sfcprop%smois) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tslb', Sfcprop%tslb) - call print_var(mpirank,omprank, blkno, 'Sfcprop%zs', Sfcprop%zs) - call print_var(mpirank,omprank, blkno, 'Sfcprop%clw_surf', Sfcprop%clw_surf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%qwv_surf', Sfcprop%qwv_surf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%cndm_surf', Sfcprop%cndm_surf) - call print_var(mpirank,omprank, blkno, 'Sfcprop%flag_frsoil', Sfcprop%flag_frsoil) - call print_var(mpirank,omprank, blkno, 'Sfcprop%rhofr', Sfcprop%rhofr) - call print_var(mpirank,omprank, blkno, 'Sfcprop%tsnow', Sfcprop%tsnow) - call print_var(mpirank,omprank, blkno, 'Sfcprop%snowfallac ', Sfcprop%snowfallac) - call print_var(mpirank,omprank, blkno, 'Sfcprop%acsnow ', Sfcprop%acsnow) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%sh2o', Sfcprop%sh2o) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%smois', Sfcprop%smois) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tslb', Sfcprop%tslb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%zs', Sfcprop%zs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%clw_surf', Sfcprop%clw_surf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%qwv_surf', Sfcprop%qwv_surf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%cndm_surf', Sfcprop%cndm_surf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%flag_frsoil', Sfcprop%flag_frsoil) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%rhofr', Sfcprop%rhofr) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%tsnow', Sfcprop%tsnow) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%snowfallac ', Sfcprop%snowfallac) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Sfcprop%acsnow ', Sfcprop%acsnow) end if ! Radtend - call print_var(mpirank,omprank, blkno, 'Radtend%sfcfsw%upfxc', Radtend%sfcfsw(:)%upfxc) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcfsw%dnfxc', Radtend%sfcfsw(:)%dnfxc) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcfsw%upfx0', Radtend%sfcfsw(:)%upfx0) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcfsw%dnfx0', Radtend%sfcfsw(:)%dnfx0) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcflw%upfxc', Radtend%sfcflw(:)%upfxc) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcflw%upfx0', Radtend%sfcflw(:)%upfx0) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcflw%dnfxc', Radtend%sfcflw(:)%dnfxc) - call print_var(mpirank,omprank, blkno, 'Radtend%sfcflw%dnfx0', Radtend%sfcflw(:)%dnfx0) - call print_var(mpirank,omprank, blkno, 'Radtend%htrsw', Radtend%htrsw) - call print_var(mpirank,omprank, blkno, 'Radtend%htrlw', Radtend%htrlw) - call print_var(mpirank,omprank, blkno, 'Radtend%sfalb', Radtend%sfalb) - call print_var(mpirank,omprank, blkno, 'Radtend%coszen', Radtend%coszen) - call print_var(mpirank,omprank, blkno, 'Radtend%tsflw', Radtend%tsflw) - call print_var(mpirank,omprank, blkno, 'Radtend%semis', Radtend%semis) - call print_var(mpirank,omprank, blkno, 'Radtend%coszdg', Radtend%coszdg) - call print_var(mpirank,omprank, blkno, 'Radtend%swhc', Radtend%swhc) - call print_var(mpirank,omprank, blkno, 'Radtend%lwhc', Radtend%lwhc) - call print_var(mpirank,omprank, blkno, 'Radtend%lwhd', Radtend%lwhd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfcfsw%upfxc', Radtend%sfcfsw(:)%upfxc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfcfsw%dnfxc', Radtend%sfcfsw(:)%dnfxc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfcfsw%upfx0', Radtend%sfcfsw(:)%upfx0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfcfsw%dnfx0', Radtend%sfcfsw(:)%dnfx0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfcflw%upfxc', Radtend%sfcflw(:)%upfxc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfcflw%upfx0', Radtend%sfcflw(:)%upfx0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfcflw%dnfxc', Radtend%sfcflw(:)%dnfxc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfcflw%dnfx0', Radtend%sfcflw(:)%dnfx0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%htrsw', Radtend%htrsw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%htrlw', Radtend%htrlw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%sfalb', Radtend%sfalb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%coszen', Radtend%coszen) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%tsflw', Radtend%tsflw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%semis', Radtend%semis) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%coszdg', Radtend%coszdg) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%swhc', Radtend%swhc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%lwhc', Radtend%lwhc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Radtend%lwhd', Radtend%lwhd) ! Tbd - call print_var(mpirank,omprank, blkno, 'Tbd%icsdsw' , Tbd%icsdsw) - call print_var(mpirank,omprank, blkno, 'Tbd%icsdlw' , Tbd%icsdlw) - call print_var(mpirank,omprank, blkno, 'Tbd%ozpl' , Tbd%ozpl) - call print_var(mpirank,omprank, blkno, 'Tbd%h2opl' , Tbd%h2opl) - call print_var(mpirank,omprank, blkno, 'Tbd%rann' , Tbd%rann) - call print_var(mpirank,omprank, blkno, 'Tbd%acv' , Tbd%acv) - call print_var(mpirank,omprank, blkno, 'Tbd%acvb' , Tbd%acvb) - call print_var(mpirank,omprank, blkno, 'Tbd%acvt' , Tbd%acvt) - call print_var(mpirank,omprank, blkno, 'Tbd%hpbl' , Tbd%hpbl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%icsdsw' , Tbd%icsdsw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%icsdlw' , Tbd%icsdlw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ozpl' , Tbd%ozpl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%h2opl' , Tbd%h2opl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%rann' , Tbd%rann) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acv' , Tbd%acv) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvb' , Tbd%acvb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%acvt' , Tbd%acvt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%hpbl' , Tbd%hpbl) if (Model%do_sppt) then - call print_var(mpirank,omprank, blkno, 'Tbd%dtdtr' , Tbd%dtdtr) - call print_var(mpirank,omprank, blkno, 'Tbd%dtotprcp' , Tbd%dtotprcp) - call print_var(mpirank,omprank, blkno, 'Tbd%dcnvprcp' , Tbd%dcnvprcp) - call print_var(mpirank,omprank, blkno, 'Tbd%drain_cpl' , Tbd%drain_cpl) - call print_var(mpirank,omprank, blkno, 'Tbd%dsnow_cpl' , Tbd%dsnow_cpl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtdtr' , Tbd%dtdtr) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dtotprcp' , Tbd%dtotprcp) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dcnvprcp' , Tbd%dcnvprcp) + end if + if (Model%cplflx .or. Model%cplchm) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%drain_cpl' , Tbd%drain_cpl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%dsnow_cpl' , Tbd%dsnow_cpl) end if if (Model%nctp > 0 .and. Model%cscnv) then - call print_var(mpirank,omprank, blkno, 'Tbd%phy_fctd' , Tbd%phy_fctd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%phy_fctd' , Tbd%phy_fctd) end if - call print_var(mpirank,omprank, blkno, 'Tbd%phy_f2d' , Tbd%phy_f2d) - call print_var(mpirank,omprank, blkno, 'Tbd%phy_f3d' , Tbd%phy_f3d) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%phy_f2d' , Tbd%phy_f2d) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%phy_f3d' , Tbd%phy_f3d) do n=1,size(Tbd%phy_f3d(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Tbd%phy_f3d_n' , Tbd%phy_f3d(:,:,n)) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%phy_f3d_n' , Tbd%phy_f3d(:,:,n)) end do - call print_var(mpirank,omprank, blkno, 'Tbd%in_nm' , Tbd%in_nm) - call print_var(mpirank,omprank, blkno, 'Tbd%ccn_nm' , Tbd%ccn_nm) - call print_var(mpirank,omprank, blkno, 'Tbd%aer_nm' , Tbd%aer_nm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%in_nm' , Tbd%in_nm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%ccn_nm' , Tbd%ccn_nm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Tbd%aer_nm' , Tbd%aer_nm) ! Diag - !call print_var(mpirank,omprank, blkno, 'Diag%fluxr ', Diag%fluxr) + !call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%fluxr ', Diag%fluxr) !do n=1,size(Diag%fluxr(1,:)) - ! call print_var(mpirank,omprank, blkno, 'Diag%fluxr_n ', Diag%fluxr(:,n)) + ! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%fluxr_n ', Diag%fluxr(:,n)) !end do - call print_var(mpirank,omprank, blkno, 'Diag%srunoff ', Diag%srunoff) - call print_var(mpirank,omprank, blkno, 'Diag%evbsa ', Diag%evbsa) - call print_var(mpirank,omprank, blkno, 'Diag%evcwa ', Diag%evcwa) - call print_var(mpirank,omprank, blkno, 'Diag%snohfa ', Diag%snohfa) - call print_var(mpirank,omprank, blkno, 'Diag%transa ', Diag%transa) - call print_var(mpirank,omprank, blkno, 'Diag%sbsnoa ', Diag%sbsnoa) - call print_var(mpirank,omprank, blkno, 'Diag%snowca ', Diag%snowca) - call print_var(mpirank,omprank, blkno, 'Diag%soilm ', Diag%soilm) - call print_var(mpirank,omprank, blkno, 'Diag%tmpmin ', Diag%tmpmin) - call print_var(mpirank,omprank, blkno, 'Diag%tmpmax ', Diag%tmpmax) - call print_var(mpirank,omprank, blkno, 'Diag%dusfc ', Diag%dusfc) - call print_var(mpirank,omprank, blkno, 'Diag%dvsfc ', Diag%dvsfc) - call print_var(mpirank,omprank, blkno, 'Diag%dtsfc ', Diag%dtsfc) - call print_var(mpirank,omprank, blkno, 'Diag%dqsfc ', Diag%dqsfc) - call print_var(mpirank,omprank, blkno, 'Diag%totprcp ', Diag%totprcp) - call print_var(mpirank,omprank, blkno, 'Diag%totice ', Diag%totice) - call print_var(mpirank,omprank, blkno, 'Diag%totsnw ', Diag%totsnw) - call print_var(mpirank,omprank, blkno, 'Diag%totgrp ', Diag%totgrp) - call print_var(mpirank,omprank, blkno, 'Diag%totprcpb ', Diag%totprcpb) - call print_var(mpirank,omprank, blkno, 'Diag%toticeb ', Diag%toticeb) - call print_var(mpirank,omprank, blkno, 'Diag%totsnwb ', Diag%totsnwb) - call print_var(mpirank,omprank, blkno, 'Diag%totgrpb ', Diag%totgrpb) - call print_var(mpirank,omprank, blkno, 'Diag%suntim ', Diag%suntim) - call print_var(mpirank,omprank, blkno, 'Diag%runoff ', Diag%runoff) - call print_var(mpirank,omprank, blkno, 'Diag%ep ', Diag%ep) - call print_var(mpirank,omprank, blkno, 'Diag%cldwrk ', Diag%cldwrk) - call print_var(mpirank,omprank, blkno, 'Diag%dugwd ', Diag%dugwd) - call print_var(mpirank,omprank, blkno, 'Diag%dvgwd ', Diag%dvgwd) - call print_var(mpirank,omprank, blkno, 'Diag%psmean ', Diag%psmean) - call print_var(mpirank,omprank, blkno, 'Diag%cnvprcp ', Diag%cnvprcp) - call print_var(mpirank,omprank, blkno, 'Diag%cnvprcpb ', Diag%cnvprcpb) - call print_var(mpirank,omprank, blkno, 'Diag%spfhmin ', Diag%spfhmin) - call print_var(mpirank,omprank, blkno, 'Diag%spfhmax ', Diag%spfhmax) - call print_var(mpirank,omprank, blkno, 'Diag%u10mmax ', Diag%u10mmax) - call print_var(mpirank,omprank, blkno, 'Diag%v10mmax ', Diag%v10mmax) - call print_var(mpirank,omprank, blkno, 'Diag%wind10mmax ', Diag%wind10mmax) - call print_var(mpirank,omprank, blkno, 'Diag%rain ', Diag%rain) - call print_var(mpirank,omprank, blkno, 'Diag%rainc ', Diag%rainc) - call print_var(mpirank,omprank, blkno, 'Diag%ice ', Diag%ice) - call print_var(mpirank,omprank, blkno, 'Diag%snow ', Diag%snow) - call print_var(mpirank,omprank, blkno, 'Diag%graupel ', Diag%graupel) - call print_var(mpirank,omprank, blkno, 'Diag%u10m ', Diag%u10m) - call print_var(mpirank,omprank, blkno, 'Diag%v10m ', Diag%v10m) - call print_var(mpirank,omprank, blkno, 'Diag%dpt2m ', Diag%dpt2m) - call print_var(mpirank,omprank, blkno, 'Diag%zlvl ', Diag%zlvl) - call print_var(mpirank,omprank, blkno, 'Diag%psurf ', Diag%psurf) - call print_var(mpirank,omprank, blkno, 'Diag%pwat ', Diag%pwat) - call print_var(mpirank,omprank, blkno, 'Diag%t1 ', Diag%t1) - call print_var(mpirank,omprank, blkno, 'Diag%q1 ', Diag%q1) - call print_var(mpirank,omprank, blkno, 'Diag%u1 ', Diag%u1) - call print_var(mpirank,omprank, blkno, 'Diag%v1 ', Diag%v1) - call print_var(mpirank,omprank, blkno, 'Diag%chh ', Diag%chh) - call print_var(mpirank,omprank, blkno, 'Diag%cmm ', Diag%cmm) - call print_var(mpirank,omprank, blkno, 'Diag%epi ', Diag%epi) - call print_var(mpirank,omprank, blkno, 'Diag%smcwlt2 ', Diag%smcwlt2) - call print_var(mpirank,omprank, blkno, 'Diag%smcref2 ', Diag%smcref2) - call print_var(mpirank,omprank, blkno, 'Diag%sr ', Diag%sr) - call print_var(mpirank,omprank, blkno, 'Diag%tdomr ', Diag%tdomr) - call print_var(mpirank,omprank, blkno, 'Diag%tdomzr ', Diag%tdomzr) - call print_var(mpirank,omprank, blkno, 'Diag%tdomip ', Diag%tdomip) - call print_var(mpirank,omprank, blkno, 'Diag%tdoms ', Diag%tdoms) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%srunoff ', Diag%srunoff) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evbsa ', Diag%evbsa) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%evcwa ', Diag%evcwa) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%snohfa ', Diag%snohfa) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%transa ', Diag%transa) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sbsnoa ', Diag%sbsnoa) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%snowca ', Diag%snowca) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%soilm ', Diag%soilm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tmpmin ', Diag%tmpmin) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tmpmax ', Diag%tmpmax) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dusfc ', Diag%dusfc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvsfc ', Diag%dvsfc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dtsfc ', Diag%dtsfc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dqsfc ', Diag%dqsfc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%totprcp ', Diag%totprcp) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%totice ', Diag%totice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%totsnw ', Diag%totsnw) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%totgrp ', Diag%totgrp) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%totprcpb ', Diag%totprcpb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%toticeb ', Diag%toticeb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%totsnwb ', Diag%totsnwb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%totgrpb ', Diag%totgrpb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%suntim ', Diag%suntim) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%runoff ', Diag%runoff) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ep ', Diag%ep) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%cldwrk ', Diag%cldwrk) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dugwd ', Diag%dugwd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dvgwd ', Diag%dvgwd) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%psmean ', Diag%psmean) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%cnvprcp ', Diag%cnvprcp) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%cnvprcpb ', Diag%cnvprcpb) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%spfhmin ', Diag%spfhmin) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%spfhmax ', Diag%spfhmax) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%u10mmax ', Diag%u10mmax) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%v10mmax ', Diag%v10mmax) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%wind10mmax ', Diag%wind10mmax) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%rain ', Diag%rain) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%rainc ', Diag%rainc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ice ', Diag%ice) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%snow ', Diag%snow) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%graupel ', Diag%graupel) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%u10m ', Diag%u10m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%v10m ', Diag%v10m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dpt2m ', Diag%dpt2m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%zlvl ', Diag%zlvl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%psurf ', Diag%psurf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%pwat ', Diag%pwat) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%t1 ', Diag%t1) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%q1 ', Diag%q1) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%u1 ', Diag%u1) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%v1 ', Diag%v1) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%chh ', Diag%chh) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%cmm ', Diag%cmm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%epi ', Diag%epi) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%smcwlt2 ', Diag%smcwlt2) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%smcref2 ', Diag%smcref2) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sr ', Diag%sr) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdomr ', Diag%tdomr) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdomzr ', Diag%tdomzr) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdomip ', Diag%tdomip) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%tdoms ', Diag%tdoms) ! CCPP/RUC only if (Model%lsm == Model%lsm_ruc) then - call print_var(mpirank,omprank, blkno, 'Diag%wet1 ', Sfcprop%wetness) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%wet1 ', Sfcprop%wetness) else - call print_var(mpirank,omprank, blkno, 'Diag%wet1 ', Diag%wet1) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%wet1 ', Diag%wet1) end if - call print_var(mpirank,omprank, blkno, 'Diag%skebu_wts ', Diag%skebu_wts) - call print_var(mpirank,omprank, blkno, 'Diag%skebv_wts ', Diag%skebv_wts) - call print_var(mpirank,omprank, blkno, 'Diag%sppt_wts ', Diag%sppt_wts) - call print_var(mpirank,omprank, blkno, 'Diag%shum_wts ', Diag%shum_wts) - call print_var(mpirank,omprank, blkno, 'Diag%zmtnblck ', Diag%zmtnblck) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%skebu_wts ', Diag%skebu_wts) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%skebv_wts ', Diag%skebv_wts) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sppt_wts ', Diag%sppt_wts) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%shum_wts ', Diag%shum_wts) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%zmtnblck ', Diag%zmtnblck) if (Model%ldiag3d) then - call print_var(mpirank,omprank, blkno, 'Diag%du3dt ', Diag%du3dt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du3dt ', Diag%du3dt) do n=1,size(Diag%du3dt(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Diag%du3dt_n ', Diag%du3dt(:,:,n)) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%du3dt_n ', Diag%du3dt(:,:,n)) end do - call print_var(mpirank,omprank, blkno, 'Diag%dv3dt ', Diag%dv3dt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv3dt ', Diag%dv3dt) do n=1,size(Diag%dv3dt(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Diag%dv3dt_n ', Diag%dv3dt(:,:,n)) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dv3dt_n ', Diag%dv3dt(:,:,n)) end do - call print_var(mpirank,omprank, blkno, 'Diag%dt3dt ', Diag%dt3dt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dt3dt ', Diag%dt3dt) do n=1,size(Diag%dt3dt(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Diag%dt3dt_n ', Diag%dt3dt(:,:,n)) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dt3dt_n ', Diag%dt3dt(:,:,n)) end do - call print_var(mpirank,omprank, blkno, 'Diag%dq3dt ', Diag%dq3dt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dq3dt ', Diag%dq3dt) do n=1,size(Diag%dq3dt(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Diag%dq3dt_n ', Diag%dq3dt(:,:,n)) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dq3dt_n ', Diag%dq3dt(:,:,n)) end do - call print_var(mpirank,omprank, blkno, 'Diag%upd_mf ', Diag%upd_mf) - call print_var(mpirank,omprank, blkno, 'Diag%dwn_mf ', Diag%dwn_mf) - call print_var(mpirank,omprank, blkno, 'Diag%det_mf ', Diag%det_mf) - call print_var(mpirank,omprank, blkno, 'Diag%cldcov ', Diag%cldcov) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%upd_mf ', Diag%upd_mf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%dwn_mf ', Diag%dwn_mf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_mf ', Diag%det_mf) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%cldcov ', Diag%cldcov) end if if(Model%lradar) then - call print_var(mpirank,omprank, blkno, 'Diag%refl_10cm ', Diag%refl_10cm) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%refl_10cm ', Diag%refl_10cm) end if ! CCPP/MYNNPBL only if (Model%do_mynnedmf) then if (Model%bl_mynn_output .ne. 0) then - call print_var(mpirank,omprank, blkno, 'Diag%edmf_a ', Diag%edmf_a) - call print_var(mpirank,omprank, blkno, 'Diag%edmf_w ', Diag%edmf_w) - call print_var(mpirank,omprank, blkno, 'Diag%edmf_qt ', Diag%edmf_qt) - call print_var(mpirank,omprank, blkno, 'Diag%edmf_thl ', Diag%edmf_thl) - call print_var(mpirank,omprank, blkno, 'Diag%edmf_ent ', Diag%edmf_ent) - call print_var(mpirank,omprank, blkno, 'Diag%edmf_qc ', Diag%edmf_qc) - call print_var(mpirank,omprank, blkno, 'Diag%sub_thl ', Diag%sub_thl) - call print_var(mpirank,omprank, blkno, 'Diag%sub_sqv ', Diag%sub_sqv) - call print_var(mpirank,omprank, blkno, 'Diag%det_thl ', Diag%det_thl) - call print_var(mpirank,omprank, blkno, 'Diag%det_sqv ', Diag%det_sqv) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_a ', Diag%edmf_a) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_w ', Diag%edmf_w) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_qt ', Diag%edmf_qt) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_thl ', Diag%edmf_thl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_ent ', Diag%edmf_ent) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%edmf_qc ', Diag%edmf_qc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sub_thl ', Diag%sub_thl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%sub_sqv ', Diag%sub_sqv) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_thl ', Diag%det_thl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%det_sqv ', Diag%det_sqv) end if - call print_var(mpirank,omprank, blkno, 'Diag%nupdraft ', Diag%nupdraft) - call print_var(mpirank,omprank, blkno, 'Diag%maxMF ', Diag%maxMF) - call print_var(mpirank,omprank, blkno, 'Diag%ktop_plume ', Diag%ktop_plume) - call print_var(mpirank,omprank, blkno, 'Diag%exch_h ', Diag%exch_h) - call print_var(mpirank,omprank, blkno, 'Diag%exch_m ', Diag%exch_m) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%nupdraft ', Diag%nupdraft) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%maxMF ', Diag%maxMF) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%ktop_plume ', Diag%ktop_plume) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_h ', Diag%exch_h) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Diag%exch_m ', Diag%exch_m) end if ! Statein - call print_var(mpirank,omprank, blkno, 'Statein%phii' , Statein%phii) - call print_var(mpirank,omprank, blkno, 'Statein%prsi' , Statein%prsi) - call print_var(mpirank,omprank, blkno, 'Statein%prsik' , Statein%prsik) - call print_var(mpirank,omprank, blkno, 'Statein%phil' , Statein%phil) - call print_var(mpirank,omprank, blkno, 'Statein%prsl' , Statein%prsl) - call print_var(mpirank,omprank, blkno, 'Statein%prslk' , Statein%prslk) - call print_var(mpirank,omprank, blkno, 'Statein%pgr' , Statein%pgr) - call print_var(mpirank,omprank, blkno, 'Statein%ugrs' , Statein%ugrs) - call print_var(mpirank,omprank, blkno, 'Statein%vgrs' , Statein%vgrs) - call print_var(mpirank,omprank, blkno, 'Statein%vvl' , Statein%vvl) - call print_var(mpirank,omprank, blkno, 'Statein%tgrs' , Statein%tgrs) - call print_var(mpirank,omprank, blkno, 'Statein%qgrs' , Statein%qgrs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phii' , Statein%phii) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%prsi' , Statein%prsi) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%prsik' , Statein%prsik) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%phil' , Statein%phil) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%prsl' , Statein%prsl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%prslk' , Statein%prslk) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%pgr' , Statein%pgr) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%ugrs' , Statein%ugrs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%vgrs' , Statein%vgrs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%vvl' , Statein%vvl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%tgrs' , Statein%tgrs) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%qgrs' , Statein%qgrs) do n=1,size(Statein%qgrs(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Statein%qgrs_n', Statein%qgrs(:,:,n)) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%qgrs_n', Statein%qgrs(:,:,n)) end do - call print_var(mpirank,omprank, blkno, 'Statein%diss_est', Statein%diss_est) - call print_var(mpirank,omprank, blkno, 'Statein%smc' , Statein%smc) - call print_var(mpirank,omprank, blkno, 'Statein%stc' , Statein%stc) - call print_var(mpirank,omprank, blkno, 'Statein%slc' , Statein%slc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%diss_est', Statein%diss_est) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%smc' , Statein%smc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%stc' , Statein%stc) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Statein%slc' , Statein%slc) ! Stateout - call print_var(mpirank,omprank, blkno, 'Stateout%gu0', Stateout%gu0) - call print_var(mpirank,omprank, blkno, 'Stateout%gv0', Stateout%gv0) - call print_var(mpirank,omprank, blkno, 'Stateout%gt0', Stateout%gt0) - call print_var(mpirank,omprank, blkno, 'Stateout%gq0', Stateout%gq0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Stateout%gu0', Stateout%gu0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Stateout%gv0', Stateout%gv0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Stateout%gt0', Stateout%gt0) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Stateout%gq0', Stateout%gq0) do n=1,size(Stateout%gq0(1,1,:)) - call print_var(mpirank,omprank, blkno, 'Stateout%gq0_n', Stateout%gq0(:,:,n)) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Stateout%gq0_n', Stateout%gq0(:,:,n)) end do ! Coupling - call print_var(mpirank,omprank, blkno, 'Coupling%nirbmdi', Coupling%nirbmdi) - call print_var(mpirank,omprank, blkno, 'Coupling%nirdfdi', Coupling%nirdfdi) - call print_var(mpirank,omprank, blkno, 'Coupling%visbmdi', Coupling%visbmdi) - call print_var(mpirank,omprank, blkno, 'Coupling%visdfdi', Coupling%visdfdi) - call print_var(mpirank,omprank, blkno, 'Coupling%nirbmui', Coupling%nirbmui) - call print_var(mpirank,omprank, blkno, 'Coupling%nirdfui', Coupling%nirdfui) - call print_var(mpirank,omprank, blkno, 'Coupling%visbmui', Coupling%visbmui) - call print_var(mpirank,omprank, blkno, 'Coupling%visdfui', Coupling%visdfui) - call print_var(mpirank,omprank, blkno, 'Coupling%sfcdsw ', Coupling%sfcdsw ) - call print_var(mpirank,omprank, blkno, 'Coupling%sfcnsw ', Coupling%sfcnsw ) - call print_var(mpirank,omprank, blkno, 'Coupling%sfcdlw ', Coupling%sfcdlw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nirbmdi', Coupling%nirbmdi) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nirdfdi', Coupling%nirdfdi) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%visbmdi', Coupling%visbmdi) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%visdfdi', Coupling%visdfdi) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nirbmui', Coupling%nirbmui) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nirdfui', Coupling%nirdfui) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%visbmui', Coupling%visbmui) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%visdfui', Coupling%visdfui) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%sfcdsw ', Coupling%sfcdsw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%sfcnsw ', Coupling%sfcnsw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%sfcdlw ', Coupling%sfcdlw ) if (Model%cplflx .or. Model%do_sppt .or. Model%cplchm) then - call print_var(mpirank,omprank, blkno, 'Coupling%rain_cpl', Coupling%rain_cpl) - call print_var(mpirank,omprank, blkno, 'Coupling%snow_cpl', Coupling%snow_cpl) - end if - if (Model%cplwav2atm) then - call print_var(mpirank,omprank, blkno, 'Coupling%zorlwav_cpl' , Coupling%zorlwav_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%rain_cpl', Coupling%rain_cpl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%snow_cpl', Coupling%snow_cpl) end if +! if (Model%cplwav2atm) then +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%zorlwav_cpl' , Coupling%zorlwav_cpl ) +! end if if (Model%cplflx) then - call print_var(mpirank,omprank, blkno, 'Coupling%oro_cpl' , Coupling%oro_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%slmsk_cpl' , Coupling%slmsk_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%slimskin_cpl', Coupling%slimskin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dusfcin_cpl ', Coupling%dusfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvsfcin_cpl ', Coupling%dvsfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dtsfcin_cpl ', Coupling%dtsfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dqsfcin_cpl ', Coupling%dqsfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%ulwsfcin_cpl', Coupling%ulwsfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%tseain_cpl ', Coupling%tseain_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%tisfcin_cpl ', Coupling%tisfcin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%ficein_cpl ', Coupling%ficein_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%hicein_cpl ', Coupling%hicein_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%hsnoin_cpl ', Coupling%hsnoin_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dusfc_cpl ', Coupling%dusfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvsfc_cpl ', Coupling%dvsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dtsfc_cpl ', Coupling%dtsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dqsfc_cpl ', Coupling%dqsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dlwsfc_cpl ', Coupling%dlwsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dswsfc_cpl ', Coupling%dswsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dnirbm_cpl ', Coupling%dnirbm_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dnirdf_cpl ', Coupling%dnirdf_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvisbm_cpl ', Coupling%dvisbm_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvisdf_cpl ', Coupling%dvisdf_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nlwsfc_cpl ', Coupling%nlwsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nswsfc_cpl ', Coupling%nswsfc_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nnirbm_cpl ', Coupling%nnirbm_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nnirdf_cpl ', Coupling%nnirdf_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nvisbm_cpl ', Coupling%nvisbm_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nvisdf_cpl ', Coupling%nvisdf_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dusfci_cpl ', Coupling%dusfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvsfci_cpl ', Coupling%dvsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dtsfci_cpl ', Coupling%dtsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dqsfci_cpl ', Coupling%dqsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dlwsfci_cpl ', Coupling%dlwsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dswsfci_cpl ', Coupling%dswsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dnirbmi_cpl ', Coupling%dnirbmi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dnirdfi_cpl ', Coupling%dnirdfi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvisbmi_cpl ', Coupling%dvisbmi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%dvisdfi_cpl ', Coupling%dvisdfi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nlwsfci_cpl ', Coupling%nlwsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nswsfci_cpl ', Coupling%nswsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nnirbmi_cpl ', Coupling%nnirbmi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nnirdfi_cpl ', Coupling%nnirdfi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nvisbmi_cpl ', Coupling%nvisbmi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%nvisdfi_cpl ', Coupling%nvisdfi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%t2mi_cpl ', Coupling%t2mi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%q2mi_cpl ', Coupling%q2mi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%u10mi_cpl ', Coupling%u10mi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%v10mi_cpl ', Coupling%v10mi_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%tsfci_cpl ', Coupling%tsfci_cpl ) - call print_var(mpirank,omprank, blkno, 'Coupling%psurfi_cpl ', Coupling%psurfi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%oro_cpl' , Coupling%oro_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%slmsk_cpl' , Coupling%slmsk_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%slimskin_cpl', Coupling%slimskin_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dusfcin_cpl ', Coupling%dusfcin_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dvsfcin_cpl ', Coupling%dvsfcin_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dtsfcin_cpl ', Coupling%dtsfcin_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dqsfcin_cpl ', Coupling%dqsfcin_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ulwsfcin_cpl', Coupling%ulwsfcin_cpl ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%tseain_cpl ', Coupling%tseain_cpl ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%tisfcin_cpl ', Coupling%tisfcin_cpl ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ficein_cpl ', Coupling%ficein_cpl ) +! call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%hicein_cpl ', Coupling%hicein_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%hsnoin_cpl ', Coupling%hsnoin_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dusfc_cpl ', Coupling%dusfc_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dvsfc_cpl ', Coupling%dvsfc_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dtsfc_cpl ', Coupling%dtsfc_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dqsfc_cpl ', Coupling%dqsfc_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dlwsfc_cpl ', Coupling%dlwsfc_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dswsfc_cpl ', Coupling%dswsfc_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dnirbm_cpl ', Coupling%dnirbm_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dnirdf_cpl ', Coupling%dnirdf_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dvisbm_cpl ', Coupling%dvisbm_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dvisdf_cpl ', Coupling%dvisdf_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nlwsfc_cpl ', Coupling%nlwsfc_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nswsfc_cpl ', Coupling%nswsfc_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nnirbm_cpl ', Coupling%nnirbm_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nnirdf_cpl ', Coupling%nnirdf_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nvisbm_cpl ', Coupling%nvisbm_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nvisdf_cpl ', Coupling%nvisdf_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dusfci_cpl ', Coupling%dusfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dvsfci_cpl ', Coupling%dvsfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dtsfci_cpl ', Coupling%dtsfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dqsfci_cpl ', Coupling%dqsfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dlwsfci_cpl ', Coupling%dlwsfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dswsfci_cpl ', Coupling%dswsfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dnirbmi_cpl ', Coupling%dnirbmi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dnirdfi_cpl ', Coupling%dnirdfi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dvisbmi_cpl ', Coupling%dvisbmi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dvisdfi_cpl ', Coupling%dvisdfi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nlwsfci_cpl ', Coupling%nlwsfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nswsfci_cpl ', Coupling%nswsfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nnirbmi_cpl ', Coupling%nnirbmi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nnirdfi_cpl ', Coupling%nnirdfi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nvisbmi_cpl ', Coupling%nvisbmi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nvisdfi_cpl ', Coupling%nvisdfi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%t2mi_cpl ', Coupling%t2mi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%q2mi_cpl ', Coupling%q2mi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%u10mi_cpl ', Coupling%u10mi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%v10mi_cpl ', Coupling%v10mi_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%tsfci_cpl ', Coupling%tsfci_cpl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%psurfi_cpl ', Coupling%psurfi_cpl ) end if if (Model%cplchm) then - call print_var(mpirank,omprank, blkno, 'Coupling%rainc_cpl', Coupling%rainc_cpl) - call print_var(mpirank,omprank, blkno, 'Coupling%ushfsfci ', Coupling%ushfsfci ) - call print_var(mpirank,omprank, blkno, 'Coupling%dkt ', Coupling%dkt ) - call print_var(mpirank,omprank, blkno, 'Coupling%dqdti ', Coupling%dqdti ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%rainc_cpl', Coupling%rainc_cpl) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ushfsfci ', Coupling%ushfsfci ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dkt ', Coupling%dkt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%dqdti ', Coupling%dqdti ) end if if (Model%do_sppt) then - call print_var(mpirank,omprank, blkno, 'Coupling%sppt_wts', Coupling%sppt_wts) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%sppt_wts', Coupling%sppt_wts) end if if (Model%do_shum) then - call print_var(mpirank,omprank, blkno, 'Coupling%shum_wts', Coupling%shum_wts) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%shum_wts', Coupling%shum_wts) end if if (Model%do_skeb) then - call print_var(mpirank,omprank, blkno, 'Coupling%skebu_wts', Coupling%skebu_wts ) - call print_var(mpirank,omprank, blkno, 'Coupling%skebv_wts', Coupling%skebv_wts ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%skebu_wts', Coupling%skebu_wts ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%skebv_wts', Coupling%skebv_wts ) end if - if (Model%do_sfcperts) then - call print_var(mpirank,omprank, blkno, 'Coupling%sfc_wts' , Coupling%sfc_wts ) + if (Model%lndp_type /= 0) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%sfc_wts' , Coupling%sfc_wts ) end if if (Model%do_ca) then - call print_var(mpirank,omprank, blkno, 'Coupling%ca1 ', Coupling%ca1 ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_deep ', Coupling%ca_deep ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_turb ', Coupling%ca_turb ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_shal ', Coupling%ca_shal ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_rad ', Coupling%ca_rad ) - call print_var(mpirank,omprank, blkno, 'Coupling%ca_micro ', Coupling%ca_micro ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ca1 ', Coupling%ca1 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ca_deep ', Coupling%ca_deep ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ca_turb ', Coupling%ca_turb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ca_shal ', Coupling%ca_shal ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ca_rad ', Coupling%ca_rad ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%ca_micro ', Coupling%ca_micro ) end if if(Model%imp_physics == Model%imp_physics_thompson .and. Model%ltaerosol) then - call print_var(mpirank,omprank, blkno, 'Coupling%nwfa2d', Coupling%nwfa2d) - call print_var(mpirank,omprank, blkno, 'Coupling%nifa2d', Coupling%nifa2d) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nwfa2d', Coupling%nwfa2d) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Coupling%nifa2d', Coupling%nifa2d) end if ! Grid - call print_var(mpirank,omprank, blkno, 'Grid%xlon ', Grid%xlon ) - call print_var(mpirank,omprank, blkno, 'Grid%xlat ', Grid%xlat ) - call print_var(mpirank,omprank, blkno, 'Grid%xlat_d', Grid%xlat_d) - call print_var(mpirank,omprank, blkno, 'Grid%sinlat', Grid%sinlat) - call print_var(mpirank,omprank, blkno, 'Grid%coslat', Grid%coslat) - call print_var(mpirank,omprank, blkno, 'Grid%area ', Grid%area ) - call print_var(mpirank,omprank, blkno, 'Grid%dx ', Grid%dx ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%xlon ', Grid%xlon ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%xlat ', Grid%xlat ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%xlat_d', Grid%xlat_d) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%sinlat', Grid%sinlat) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%coslat', Grid%coslat) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%area ', Grid%area ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%dx ', Grid%dx ) if (Model%ntoz > 0) then - call print_var(mpirank,omprank, blkno, 'Grid%ddy_o3 ', Grid%ddy_o3 ) - call print_var(mpirank,omprank, blkno, 'Grid%jindx1_o3', Grid%jindx1_o3) - call print_var(mpirank,omprank, blkno, 'Grid%jindx2_o3', Grid%jindx2_o3) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%ddy_o3 ', Grid%ddy_o3 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx1_o3', Grid%jindx1_o3) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_o3', Grid%jindx2_o3) endif if (Model%h2o_phys) then - call print_var(mpirank,omprank, blkno, 'Grid%ddy_h ', Grid%ddy_h ) - call print_var(mpirank,omprank, blkno, 'Grid%jindx1_h', Grid%jindx1_h) - call print_var(mpirank,omprank, blkno, 'Grid%jindx2_h', Grid%jindx2_h) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%ddy_h ', Grid%ddy_h ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx1_h', Grid%jindx1_h) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Grid%jindx2_h', Grid%jindx2_h) endif ! Model/Control ! not yet @@ -538,251 +816,15 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, end subroutine GFS_diagtoscreen_run - subroutine print_logic_0d(mpirank,omprank,blkno,name,var) - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - logical, intent(in) :: var - - write(0,'(2a,3i6,1x,l)') 'XXX: ', trim(name), mpirank, omprank, blkno, var - - end subroutine print_logic_0d - - subroutine print_int_0d(mpirank,omprank,blkno,name,var) - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - integer, intent(in) :: var - - write(0,'(2a,3i6,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, var - - end subroutine print_int_0d - - subroutine print_logic_1d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - logical, intent(in) :: var(:) - - integer :: i - -#ifdef PRINT_SUM - write(0,'(2a,3i6,2i8)') 'XXX: ', trim(name), mpirank, omprank, blkno, size(var), count(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,2i8)') 'XXX: ', trim(name), mpirank, omprank, blkno, size(var), count(var) -#else - do i=ISTART,min(IEND,size(var(:))) - write(0,'(2a,3i6,i6,1x,l)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) - end do -#endif - - end subroutine print_logic_1d - - subroutine print_int_1d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - integer, intent(in) :: var(:) - - integer :: i - -#ifdef PRINT_SUM - write(0,'(2a,3i6,3i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,i20,2i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_int(size(var),var), minval(var), maxval(var) -#else - do i=ISTART,min(IEND,size(var(:))) - write(0,'(2a,3i6,i6,i15)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) - end do -#endif - - end subroutine print_int_1d - - subroutine print_real_0d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - real(kind_phys), intent(in) :: var - - write(0,'(2a,3i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, var - - end subroutine print_real_0d - - subroutine print_real_1d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - real(kind_phys), intent(in) :: var(:) - - integer :: i - -#ifdef PRINT_SUM - write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),var), minval(var), maxval(var) -#else - do i=ISTART,min(IEND,size(var(:))) - write(0,'(2a,3i6,i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, var(i) - end do -#endif - - end subroutine print_real_1d - - subroutine print_real_2d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - real(kind_phys), intent(in) :: var(:,:) - - integer :: k, i - -#ifdef PRINT_SUM - write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) -#else - do i=ISTART,min(IEND,size(var(:,1))) - do k=KSTART,min(KEND,size(var(1,:))) - write(0,'(2a,3i6,2i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, var(i,k) - end do - end do -#endif - - end subroutine print_real_2d - - subroutine print_real_3d(mpirank,omprank,blkno,name,var) - - use machine, only: kind_phys - - implicit none - - integer, intent(in) :: mpirank, omprank, blkno - character(len=*), intent(in) :: name - real(kind_phys), intent(in) :: var(:,:,:) - - integer :: k, i, l - -#ifdef PRINT_SUM - write(0,'(2a,3i6,3e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, sum(var), minval(var), maxval(var) -#elif defined(PRINT_CHKSUM) - write(0,'(2a,3i6,i20,2e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, chksum_real(size(var),reshape(var,(/size(var)/))), minval(var), maxval(var) -#else - do i=ISTART,min(IEND,size(var(:,1,1))) - do k=KSTART,min(KEND,size(var(1,:,1))) - do l=1,size(var(1,1,:)) - write(0,'(2a,3i6,3i6,e35.25)') 'XXX: ', trim(name), mpirank, omprank, blkno, i, k, l, var(i,k,l) - end do - end do - end do -#endif - - end subroutine print_real_3d - - function chksum_int(N, var) result(hash) - implicit none - integer, intent(in) :: N - integer, dimension(1:N), intent(in) :: var - integer*8, dimension(1:N) :: int_var - integer*8 :: a, b, i, hash - integer*8, parameter :: mod_adler=65521 - - a=1 - b=0 - i=1 - hash = 0 - int_var = TRANSFER(var, a, N) - - do i= 1, N - a = MOD(a + int_var(i), mod_adler) - b = MOD(b+a, mod_adler) - end do - - hash = ior(b * 65536, a) - - end function chksum_int - - function chksum_real(N, var) result(hash) - use machine, only: kind_phys - implicit none - integer, intent(in) :: N - real(kind_phys), dimension(1:N), intent(in) :: var - integer*8, dimension(1:N) :: int_var - integer*8 :: a, b, i, hash - integer*8, parameter :: mod_adler=65521 - - a=1 - b=0 - i=1 - hash = 0 - int_var = TRANSFER(var, a, N) - - do i= 1, N - a = MOD(a + int_var(i), mod_adler) - b = MOD(b+a, mod_adler) - end do - - hash = ior(b * 65536, a) - - end function chksum_real - - function print_my_stuff(mpitoprint,omptoprint) result(flag) -#ifdef MPI - use mpi -#endif -#ifdef OPENMP - use omp_lib -#endif - implicit none - integer, intent(in) :: mpitoprint, omptoprint - logical :: flag - integer :: ompthread, mpirank, ierr -#ifdef MPI - call MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) -#else - mpirank = 0 -#endif -#ifdef OPENMP - ompthread = OMP_GET_THREAD_NUM() -#else - ompthread = 0 -#endif - - if (mpitoprint==mpirank .and. omptoprint==ompthread) then - flag = .true. - else - flag = .false. - end if - end function print_my_stuff - end module GFS_diagtoscreen module GFS_interstitialtoscreen + use print_var_chksum, only: print_var + + implicit none + private public GFS_interstitialtoscreen_init, GFS_interstitialtoscreen_run, GFS_interstitialtoscreen_finalize @@ -839,6 +881,7 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup integer :: impi, iomp, ierr integer :: mpirank, mpisize, mpicomm integer :: omprank, ompsize + integer :: istart, iend, kstart, kend ! Initialize CCPP error handling variables errmsg = '' @@ -871,7 +914,373 @@ subroutine GFS_interstitialtoscreen_run (Model, Statein, Stateout, Sfcprop, Coup do impi=0,mpisize-1 do iomp=0,ompsize-1 if (mpirank==impi .and. omprank==iomp) then - call Interstitial%mprint(Model,mpirank,omprank,blkno) + ! Print static variables + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%h2o_coeff ', Interstitial%h2o_coeff ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%h2o_pres ', Interstitial%h2o_pres ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ipr ', Interstitial%ipr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%itc ', Interstitial%itc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%latidxprnt ', Interstitial%latidxprnt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%levi ', Interstitial%levi ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%levh2o ', Interstitial%levh2o ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%levozp ', Interstitial%levozp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%lmk ', Interstitial%lmk ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%lmp ', Interstitial%lmp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nbdlw ', Interstitial%nbdlw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nbdsw ', Interstitial%nbdsw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nf_aelw ', Interstitial%nf_aelw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nf_aesw ', Interstitial%nf_aesw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nsamftrac ', Interstitial%nsamftrac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nscav ', Interstitial%nscav ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nspc1 ', Interstitial%nspc1 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ntiwx ', Interstitial%ntiwx ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nvdiff ', Interstitial%nvdiff ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oz_coeff ', Interstitial%oz_coeff ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'sum(Interstitial%oz_pres) ', Interstitial%oz_pres ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%phys_hydrostatic ', Interstitial%phys_hydrostatic ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%skip_macro ', Interstitial%skip_macro ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%trans_aero ', Interstitial%trans_aero ) + ! Print all other variables + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjsfculw_land ', Interstitial%adjsfculw_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjsfculw_ice ', Interstitial%adjsfculw_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjsfculw_ocean ', Interstitial%adjsfculw_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjnirbmd ', Interstitial%adjnirbmd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjnirbmu ', Interstitial%adjnirbmu ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjnirdfd ', Interstitial%adjnirdfd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjnirdfu ', Interstitial%adjnirdfu ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjvisbmd ', Interstitial%adjvisbmd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjvisbmu ', Interstitial%adjvisbmu ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjvisdfu ', Interstitial%adjvisdfu ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%adjvisdfd ', Interstitial%adjvisdfd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%aerodp ', Interstitial%aerodp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%alb1d ', Interstitial%alb1d ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%bexp1d ', Interstitial%bexp1d ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cd ', Interstitial%cd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cd_ice ', Interstitial%cd_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cd_land ', Interstitial%cd_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cd_ocean ', Interstitial%cd_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cdq ', Interstitial%cdq ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cdq_ice ', Interstitial%cdq_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cdq_land ', Interstitial%cdq_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cdq_ocean ', Interstitial%cdq_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%chh_ice ', Interstitial%chh_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%chh_land ', Interstitial%chh_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%chh_ocean ', Interstitial%chh_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cldf ', Interstitial%cldf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cldsa ', Interstitial%cldsa ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cldtaulw ', Interstitial%cldtaulw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cldtausw ', Interstitial%cldtausw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld1d ', Interstitial%cld1d ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clw ', Interstitial%clw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clx ', Interstitial%clx ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clouds ', Interstitial%clouds ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cmm_ice ', Interstitial%cmm_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cmm_land ', Interstitial%cmm_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cmm_ocean ', Interstitial%cmm_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cnvc ', Interstitial%cnvc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cnvw ', Interstitial%cnvw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ctei_r ', Interstitial%ctei_r ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ctei_rml ', Interstitial%ctei_rml ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cumabs ', Interstitial%cumabs ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dd_mf ', Interstitial%dd_mf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%de_lgth ', Interstitial%de_lgth ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%del ', Interstitial%del ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%del_gz ', Interstitial%del_gz ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%delr ', Interstitial%delr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dkt ', Interstitial%dkt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dlength ', Interstitial%dlength ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dqdt ', Interstitial%dqdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dqsfc1 ', Interstitial%dqsfc1 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%drain ', Interstitial%drain ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdt ', Interstitial%dtdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtdtc ', Interstitial%dtdtc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtsfc1 ', Interstitial%dtsfc1 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dtzm ', Interstitial%dtzm ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dt_mf ', Interstitial%dt_mf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt ', Interstitial%dudt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dusfcg ', Interstitial%dusfcg ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dusfc1 ', Interstitial%dusfc1 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdftra ', Interstitial%dvdftra ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvdt ', Interstitial%dvdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvsfcg ', Interstitial%dvsfcg ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dvsfc1 ', Interstitial%dvsfc1 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dzlyr ', Interstitial%dzlyr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%elvmax ', Interstitial%elvmax ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d ', Interstitial%ep1d ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_ice ', Interstitial%ep1d_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_land ', Interstitial%ep1d_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ep1d_ocean ', Interstitial%ep1d_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evapq ', Interstitial%evapq ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_ice ', Interstitial%evap_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_land ', Interstitial%evap_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evap_ocean ', Interstitial%evap_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evbs ', Interstitial%evbs ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%evcw ', Interstitial%evcw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faerlw ', Interstitial%faerlw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%faersw ', Interstitial%faersw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ffhh_ice ', Interstitial%ffhh_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ffhh_land ', Interstitial%ffhh_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ffhh_ocean ', Interstitial%ffhh_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fh2 ', Interstitial%fh2 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fh2_ice ', Interstitial%fh2_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fh2_land ', Interstitial%fh2_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fh2_ocean ', Interstitial%fh2_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%flag_cice ', Interstitial%flag_cice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%flag_guess ', Interstitial%flag_guess ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%flag_iter ', Interstitial%flag_iter ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ffmm_ice ', Interstitial%ffmm_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ffmm_land ', Interstitial%ffmm_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ffmm_ocean ', Interstitial%ffmm_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fm10 ', Interstitial%fm10 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fm10_ice ', Interstitial%fm10_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fm10_land ', Interstitial%fm10_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fm10_ocean ', Interstitial%fm10_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%frain ', Interstitial%frain ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%frland ', Interstitial%frland ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fscav ', Interstitial%fscav ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fswtr ', Interstitial%fswtr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gabsbdlw ', Interstitial%gabsbdlw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gabsbdlw_ice ', Interstitial%gabsbdlw_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gabsbdlw_land ', Interstitial%gabsbdlw_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gabsbdlw_ocean ', Interstitial%gabsbdlw_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gamma ', Interstitial%gamma ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gamq ', Interstitial%gamq ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gamt ', Interstitial%gamt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gasvmr ', Interstitial%gasvmr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gflx ', Interstitial%gflx ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gflx_ice ', Interstitial%gflx_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gflx_land ', Interstitial%gflx_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gflx_ocean ', Interstitial%gflx_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gwdcu ', Interstitial%gwdcu ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gwdcv ', Interstitial%gwdcv ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hefac ', Interstitial%hefac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hffac ', Interstitial%hffac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hflxq ', Interstitial%hflxq ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hflx_ice ', Interstitial%hflx_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hflx_land ', Interstitial%hflx_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%hflx_ocean ', Interstitial%hflx_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%htlwc ', Interstitial%htlwc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%htlw0 ', Interstitial%htlw0 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%htswc ', Interstitial%htswc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%htsw0 ', Interstitial%htsw0 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dry ', Interstitial%dry ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%idxday ', Interstitial%idxday ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icy ', Interstitial%icy ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%lake ', Interstitial%lake ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ocean ', Interstitial%ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%islmsk ', Interstitial%islmsk ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%islmsk_cice ', Interstitial%islmsk_cice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wet ', Interstitial%wet ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kb ', Interstitial%kb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kbot ', Interstitial%kbot ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kcnv ', Interstitial%kcnv ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kd ', Interstitial%kd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kinver ', Interstitial%kinver ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kpbl ', Interstitial%kpbl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%kt ', Interstitial%kt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ktop ', Interstitial%ktop ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%mbota ', Interstitial%mbota ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%mtopa ', Interstitial%mtopa ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%nday ', Interstitial%nday ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oa4 ', Interstitial%oa4 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oc ', Interstitial%oc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%olyr ', Interstitial%olyr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%plvl ', Interstitial%plvl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%plyr ', Interstitial%plyr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%prcpmp ', Interstitial%prcpmp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%prnum ', Interstitial%prnum ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qlyr ', Interstitial%qlyr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_ice ', Interstitial%qss_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_land ', Interstitial%qss_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qss_ocean ', Interstitial%qss_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%radar_reset ', Interstitial%radar_reset ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raddt ', Interstitial%raddt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raincd ', Interstitial%raincd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%raincs ', Interstitial%raincs ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rainmcadj ', Interstitial%rainmcadj ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rainp ', Interstitial%rainp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb ', Interstitial%rb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_ice ', Interstitial%rb_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_land ', Interstitial%rb_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rb_ocean ', Interstitial%rb_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%reset ', Interstitial%reset ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rhc ', Interstitial%rhc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%runoff ', Interstitial%runoff ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_q ', Interstitial%save_q ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_t ', Interstitial%save_t ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_tcp ', Interstitial%save_tcp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_u ', Interstitial%save_u ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%save_v ', Interstitial%save_v ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sbsno ', Interstitial%sbsno ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbfc ', Interstitial%scmpsw%uvbfc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%uvbf0 ', Interstitial%scmpsw%uvbf0 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%nirbm ', Interstitial%scmpsw%nirbm ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%nirdf ', Interstitial%scmpsw%nirdf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%visbm ', Interstitial%scmpsw%visbm ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%scmpsw%visdf ', Interstitial%scmpsw%visdf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_ice ', Interstitial%semis_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_land ', Interstitial%semis_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%semis_ocean ', Interstitial%semis_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sfcalb ', Interstitial%sfcalb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigma ', Interstitial%sigma ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmaf ', Interstitial%sigmaf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmafrac ', Interstitial%sigmafrac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%sigmatot ', Interstitial%sigmatot ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%slopetype ', Interstitial%slopetype ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowc ', Interstitial%snowc ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ice ', Interstitial%snowd_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_land ', Interstitial%snowd_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowd_ocean ', Interstitial%snowd_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snohf ', Interstitial%snohf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmt ', Interstitial%snowmt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%soiltype ', Interstitial%soiltype ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress ', Interstitial%stress ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress_ice ', Interstitial%stress_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress_land ', Interstitial%stress_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%stress_ocean ', Interstitial%stress_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%theta ', Interstitial%theta ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tice ', Interstitial%tice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tlvl ', Interstitial%tlvl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tlyr ', Interstitial%tlyr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ice ', Interstitial%tprcp_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_land ', Interstitial%tprcp_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tprcp_ocean ', Interstitial%tprcp_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%trans ', Interstitial%trans ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tseal ', Interstitial%tseal ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfa ', Interstitial%tsfa ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_ice ', Interstitial%tsfc_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_land ', Interstitial%tsfc_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfc_ocean ', Interstitial%tsfc_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsfg ', Interstitial%tsfg ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf ', Interstitial%tsurf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_ice ', Interstitial%tsurf_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_land ', Interstitial%tsurf_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tsurf_ocean ', Interstitial%tsurf_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ud_mf ', Interstitial%ud_mf ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_ice ', Interstitial%uustar_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_land ', Interstitial%uustar_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%uustar_ocean ', Interstitial%uustar_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vdftra ', Interstitial%vdftra ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegf1d ', Interstitial%vegf1d ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%vegtype ', Interstitial%vegtype ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wcbmax ', Interstitial%wcbmax ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ice ', Interstitial%weasd_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_land ', Interstitial%weasd_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%weasd_ocean ', Interstitial%weasd_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%wind ', Interstitial%wind ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work1 ', Interstitial%work1 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work2 ', Interstitial%work2 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%work3 ', Interstitial%work3 ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%xcosz ', Interstitial%xcosz ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%xlai1d ', Interstitial%xlai1d ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%xmu ', Interstitial%xmu ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%z01d ', Interstitial%z01d ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_ice ', Interstitial%zorl_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_land ', Interstitial%zorl_land ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zorl_ocean ', Interstitial%zorl_ocean ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zt1d ', Interstitial%zt1d ) + ! CIRES UGWP v0 + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dudt ', Interstitial%gw_dudt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dvdt ', Interstitial%gw_dvdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_dtdt ', Interstitial%gw_dtdt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%gw_kdis ', Interstitial%gw_kdis ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_mtb ', Interstitial%tau_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ogw ', Interstitial%tau_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_tofd ', Interstitial%tau_tofd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tau_ngw ', Interstitial%tau_ngw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zmtb ', Interstitial%zmtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zlwb ', Interstitial%zlwb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%zogw ', Interstitial%zogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_mtb ', Interstitial%dudt_mtb ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_ogw ', Interstitial%dudt_ogw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%dudt_tms ', Interstitial%dudt_tms ) + !-- GSD drag suite + if (Model%gwd_opt==3 .or. Model%gwd_opt==33) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%varss ', Interstitial%varss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ocss ', Interstitial%ocss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%oa4ss ', Interstitial%oa4ss ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clxss ', Interstitial%clxss ) + end if + ! GFDL and Thompson MP + if (Model%imp_physics == Model%imp_physics_gfdl .or. Model%imp_physics == Model%imp_physics_thompson) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%graupelmp ', Interstitial%graupelmp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icemp ', Interstitial%icemp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%rainmp ', Interstitial%rainmp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%snowmp ', Interstitial%snowmp ) + ! Ferrier-Aligo + else if (Model%imp_physics == Model%imp_physics_fer_hires) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%f_ice ', Interstitial%f_ice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%f_rain ', Interstitial%f_rain ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%f_rimef ', Interstitial%f_rimef ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cwm ', Interstitial%cwm ) + ! Morrison-Gettelman + else if (Model%imp_physics == Model%imp_physics_mg) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ncgl ', Interstitial%ncgl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ncpr ', Interstitial%ncpr ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ncps ', Interstitial%ncps ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qgl ', Interstitial%qgl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qrn ', Interstitial%qrn ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qsnw ', Interstitial%qsnw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qlcn ', Interstitial%qlcn ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qicn ', Interstitial%qicn ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%w_upi ', Interstitial%w_upi ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cf_upi ', Interstitial%cf_upi ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cnv_mfd ', Interstitial%cnv_mfd ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cnv_dqldt ', Interstitial%cnv_dqldt ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%clcn ', Interstitial%clcn ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cnv_fice ', Interstitial%cnv_fice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cnv_ndrop ', Interstitial%cnv_ndrop ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cnv_nice ', Interstitial%cnv_nice ) + end if + ! SHOC + if (Model%do_shoc) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ncgl ', Interstitial%ncgl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qrn ', Interstitial%qrn ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qsnw ', Interstitial%qsnw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qgl ', Interstitial%qgl ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ncpi ', Interstitial%ncpi ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%ncpl ', Interstitial%ncpl ) + end if + ! Noah MP + if (Model%lsm == Model%lsm_noahmp) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%t2mmp ', Interstitial%t2mmp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%q2mp ', Interstitial%q2mp ) + end if + ! RRTMGP + if (Model%do_RRTMGP) then + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%aerosolslw ', Interstitial%aerosolslw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%aerosolssw ', Interstitial%aerosolssw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_frac ', Interstitial%cld_frac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_lwp ', Interstitial%cld_lwp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_reliq ', Interstitial%cld_reliq ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_iwp ', Interstitial%cld_iwp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_reice ', Interstitial%cld_reice ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_swp ', Interstitial%cld_swp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_resnow ', Interstitial%cld_resnow ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_rwp ', Interstitial%cld_rwp ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cld_rerain ', Interstitial%cld_rerain ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%precip_frac ', Interstitial%precip_frac ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icseed_lw ', Interstitial%icseed_lw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%icseed_sw ', Interstitial%icseed_sw ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwUP_allsky ', Interstitial%fluxlwUP_allsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwDOWN_allsky ', Interstitial%fluxlwDOWN_allsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwUP_clrsky ', Interstitial%fluxlwUP_clrsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxlwDOWN_clrsky ', Interstitial%fluxlwDOWN_clrsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxswUP_allsky ', Interstitial%fluxswUP_allsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxswDOWN_allsky ', Interstitial%fluxswDOWN_allsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxswUP_clrsky ', Interstitial%fluxswUP_clrsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%fluxswDOWN_clrsky ', Interstitial%fluxswDOWN_clrsky ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%relhum ', Interstitial%relhum ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%q_lay ', Interstitial%q_lay ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%qs_lay ', Interstitial%qs_lay ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%deltaZ ', Interstitial%deltaZ ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%p_lay ', Interstitial%p_lay ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%p_lev ', Interstitial%p_lev ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%t_lay ', Interstitial%t_lay ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%t_lev ', Interstitial%t_lev ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%tv_lay ', Interstitial%tv_lay ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%cloud_overlap_param ', Interstitial%cloud_overlap_param ) + call print_var(mpirank, omprank, blkno, Grid%xlat_d, Grid%xlon_d, 'Interstitial%precip_overlap_param', Interstitial%precip_overlap_param ) + end if end if #ifdef OPENMP !$OMP BARRIER @@ -927,8 +1336,8 @@ subroutine GFS_abort_run (Model, blkno, errmsg, errflg) errmsg = '' errflg = 0 - if (Model%kdt==1 .and. blkno==4) then - if (Model%me==0) write(0,*) "GFS_abort_run: ABORTING MODEL" + if (Model%kdt==1 .and. blkno==size(Model%blksz)) then + if (Model%me==Model%master) write(0,*) "GFS_abort_run: ABORTING MODEL" call sleep(10) stop end if @@ -939,104 +1348,104 @@ end module GFS_abort module GFS_checkland - private + private - public GFS_checkland_init, GFS_checkland_run, GFS_checkland_finalize + public GFS_checkland_init, GFS_checkland_run, GFS_checkland_finalize - contains + contains - subroutine GFS_checkland_init () - end subroutine GFS_checkland_init + subroutine GFS_checkland_init () + end subroutine GFS_checkland_init - subroutine GFS_checkland_finalize () - end subroutine GFS_checkland_finalize + subroutine GFS_checkland_finalize () + end subroutine GFS_checkland_finalize !> \section arg_table_GFS_checkland_run Argument Table !! \htmlinclude GFS_checkland_run.html !! - subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_guess, & - flag_init, flag_restart, frac_grid, isot, ivegsrc, stype, vtype, slope, & - soiltyp, vegtype, slopetyp, dry, icy, wet, lake, ocean, & - oceanfrac, landfrac, lakefrac, slmsk, islmsk, errmsg, errflg ) - - use machine, only: kind_phys - - implicit none - - ! Interface variables - integer, intent(in ) :: me - integer, intent(in ) :: master - integer, intent(in ) :: blkno - integer, intent(in ) :: im - integer, intent(in ) :: kdt - integer, intent(in ) :: iter - logical, intent(in ) :: flag_iter(im) - logical, intent(in ) :: flag_guess(im) - logical, intent(in ) :: flag_init - logical, intent(in ) :: flag_restart - logical, intent(in ) :: frac_grid - integer, intent(in ) :: isot - integer, intent(in ) :: ivegsrc - real(kind_phys), intent(in ) :: stype(im) - real(kind_phys), intent(in ) :: vtype(im) - real(kind_phys), intent(in ) :: slope(im) - integer, intent(in ) :: soiltyp(im) - integer, intent(in ) :: vegtype(im) - integer, intent(in ) :: slopetyp(im) - logical, intent(in ) :: dry(im) - logical, intent(in ) :: icy(im) - logical, intent(in ) :: wet(im) - logical, intent(in ) :: lake(im) - logical, intent(in ) :: ocean(im) - real(kind_phys), intent(in ) :: oceanfrac(im) - real(kind_phys), intent(in ) :: landfrac(im) - real(kind_phys), intent(in ) :: lakefrac(im) - real(kind_phys), intent(in ) :: slmsk(im) - integer, intent(in ) :: islmsk(im) - character(len=*), intent( out) :: errmsg - integer, intent( out) :: errflg - - ! Local variables - integer :: i - - errflg = 0 - errmsg = '' - - write(0,'(a,i5)') 'YYY: me :', me - write(0,'(a,i5)') 'YYY: master :', master - write(0,'(a,i5)') 'YYY: blkno :', blkno - write(0,'(a,i5)') 'YYY: im :', im - write(0,'(a,i5)') 'YYY: kdt :', kdt - write(0,'(a,i5)') 'YYY: iter :', iter - write(0,'(a,1x,l)') 'YYY: flag_init :', flag_init - write(0,'(a,1x,l)') 'YYY: flag_restart :', flag_restart - write(0,'(a,1x,l)') 'YYY: frac_grid :', frac_grid - write(0,'(a,i5)') 'YYY: isot :', isot - write(0,'(a,i5)') 'YYY: ivegsrc :', ivegsrc - - do i=1,im - !if (vegtype(i)==15) then - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_iter(i) :', i, blkno, flag_iter(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_guess(i) :', i, blkno, flag_guess(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, stype(i) :', i, blkno, stype(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, vtype(i) :', i, blkno, vtype(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slope(i) :', i, blkno, slope(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, soiltyp(i) :', i, blkno, soiltyp(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, vegtype(i) :', i, blkno, vegtype(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, slopetyp(i) :', i, blkno, slopetyp(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, dry(i) :', i, blkno, dry(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, icy(i) :', i, blkno, icy(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, wet(i) :', i, blkno, wet(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, lake(i) :', i, blkno, lake(i) - write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, ocean(i) :', i, blkno, ocean(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, oceanfrac(i) :', i, blkno, oceanfrac(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, landfrac(i) :', i, blkno, landfrac(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, lakefrac(i) :', i, blkno, lakefrac(i) - write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slmsk(i) :', i, blkno, slmsk(i) - write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, islmsk(i) :', i, blkno, islmsk(i) - !end if - end do - - end subroutine GFS_checkland_run + subroutine GFS_checkland_run (me, master, blkno, im, kdt, iter, flag_iter, flag_guess, & + flag_init, flag_restart, frac_grid, isot, ivegsrc, stype, vtype, slope, & + soiltyp, vegtype, slopetyp, dry, icy, wet, lake, ocean, & + oceanfrac, landfrac, lakefrac, slmsk, islmsk, errmsg, errflg ) + + use machine, only: kind_phys + + implicit none + + ! Interface variables + integer, intent(in ) :: me + integer, intent(in ) :: master + integer, intent(in ) :: blkno + integer, intent(in ) :: im + integer, intent(in ) :: kdt + integer, intent(in ) :: iter + logical, intent(in ) :: flag_iter(im) + logical, intent(in ) :: flag_guess(im) + logical, intent(in ) :: flag_init + logical, intent(in ) :: flag_restart + logical, intent(in ) :: frac_grid + integer, intent(in ) :: isot + integer, intent(in ) :: ivegsrc + real(kind_phys), intent(in ) :: stype(im) + real(kind_phys), intent(in ) :: vtype(im) + real(kind_phys), intent(in ) :: slope(im) + integer, intent(in ) :: soiltyp(im) + integer, intent(in ) :: vegtype(im) + integer, intent(in ) :: slopetyp(im) + logical, intent(in ) :: dry(im) + logical, intent(in ) :: icy(im) + logical, intent(in ) :: wet(im) + logical, intent(in ) :: lake(im) + logical, intent(in ) :: ocean(im) + real(kind_phys), intent(in ) :: oceanfrac(im) + real(kind_phys), intent(in ) :: landfrac(im) + real(kind_phys), intent(in ) :: lakefrac(im) + real(kind_phys), intent(in ) :: slmsk(im) + integer, intent(in ) :: islmsk(im) + character(len=*), intent( out) :: errmsg + integer, intent( out) :: errflg + + ! Local variables + integer :: i + + errflg = 0 + errmsg = '' + + write(0,'(a,i5)') 'YYY: me :', me + write(0,'(a,i5)') 'YYY: master :', master + write(0,'(a,i5)') 'YYY: blkno :', blkno + write(0,'(a,i5)') 'YYY: im :', im + write(0,'(a,i5)') 'YYY: kdt :', kdt + write(0,'(a,i5)') 'YYY: iter :', iter + write(0,'(a,1x,l)') 'YYY: flag_init :', flag_init + write(0,'(a,1x,l)') 'YYY: flag_restart :', flag_restart + write(0,'(a,1x,l)') 'YYY: frac_grid :', frac_grid + write(0,'(a,i5)') 'YYY: isot :', isot + write(0,'(a,i5)') 'YYY: ivegsrc :', ivegsrc + + do i=1,im + !if (vegtype(i)==15) then + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_iter(i) :', i, blkno, flag_iter(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, flag_guess(i) :', i, blkno, flag_guess(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, stype(i) :', i, blkno, stype(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, vtype(i) :', i, blkno, vtype(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slope(i) :', i, blkno, slope(i) + write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, soiltyp(i) :', i, blkno, soiltyp(i) + write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, vegtype(i) :', i, blkno, vegtype(i) + write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, slopetyp(i) :', i, blkno, slopetyp(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, dry(i) :', i, blkno, dry(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, icy(i) :', i, blkno, icy(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, wet(i) :', i, blkno, wet(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, lake(i) :', i, blkno, lake(i) + write(0,'(a,2i5,1x,1x,l)') 'YYY: i, blk, ocean(i) :', i, blkno, ocean(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, oceanfrac(i) :', i, blkno, oceanfrac(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, landfrac(i) :', i, blkno, landfrac(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, lakefrac(i) :', i, blkno, lakefrac(i) + write(0,'(a,2i5,1x,e16.7)')'YYY: i, blk, slmsk(i) :', i, blkno, slmsk(i) + write(0,'(a,2i5,1x,i5)') 'YYY: i, blk, islmsk(i) :', i, blkno, islmsk(i) + !end if + end do + + end subroutine GFS_checkland_run end module GFS_checkland diff --git a/physics/GFS_debug.meta b/physics/GFS_debug.meta index 24d26be7e..d93e22328 100644 --- a/physics/GFS_debug.meta +++ b/physics/GFS_debug.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_diagtoscreen + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = GFS_diagtoscreen_run type = scheme @@ -123,6 +129,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_interstitialtoscreen + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_interstitialtoscreen_run @@ -249,6 +261,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_abort + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_abort_run @@ -287,6 +305,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_checkland + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_checkland_run diff --git a/physics/GFS_phys_time_vary.fv3.F90 b/physics/GFS_phys_time_vary.fv3.F90 index bed8e14e1..3c894b777 100644 --- a/physics/GFS_phys_time_vary.fv3.F90 +++ b/physics/GFS_phys_time_vary.fv3.F90 @@ -468,7 +468,7 @@ subroutine GFS_phys_time_vary_run (Data, Model, nthrds, first_time_step, errmsg, !> - Call gcycle() to repopulate specific time-varying surface properties for AMIP/forecast runs if (Model%nscyc > 0) then if (mod(Model%kdt,Model%nscyc) == 1) THEN - call gcycle (nblks, Model, Data(:)%Grid, Data(:)%Sfcprop, Data(:)%Cldprop) + call gcycle (nblks, nthrds, Model, Data(:)%Grid, Data(:)%Sfcprop, Data(:)%Cldprop) endif endif diff --git a/physics/GFS_phys_time_vary.fv3.meta b/physics/GFS_phys_time_vary.fv3.meta index 199cc362c..72a7ce207 100644 --- a/physics/GFS_phys_time_vary.fv3.meta +++ b/physics/GFS_phys_time_vary.fv3.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_phys_time_vary + type = scheme + dependencies = aerclm_def.F,aerinterp.F90,gcycle.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,ozinterp.f90,ozne_def.f,sfcsub.F + +######################################################################## [ccpp-arg-table] name = GFS_phys_time_vary_init type = scheme diff --git a/physics/GFS_phys_time_vary.scm.meta b/physics/GFS_phys_time_vary.scm.meta index 57a82ecb0..556aa80c7 100644 --- a/physics/GFS_phys_time_vary.scm.meta +++ b/physics/GFS_phys_time_vary.scm.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_phys_time_vary + type = scheme + dependencies = aerclm_def.F,aerinterp.F90,h2o_def.f,h2ointerp.f90,iccn_def.F,iccninterp.F90,machine.F,mersenne_twister.f,namelist_soilveg.f,ozinterp.f90,ozne_def.f + +######################################################################## [ccpp-arg-table] name = GFS_phys_time_vary_init type = scheme diff --git a/physics/GFS_rad_time_vary.fv3.meta b/physics/GFS_rad_time_vary.fv3.meta index c86c81f18..8ac28be30 100644 --- a/physics/GFS_rad_time_vary.fv3.meta +++ b/physics/GFS_rad_time_vary.fv3.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = GFS_rad_time_vary_init +[ccpp-table-properties] + name = GFS_rad_time_vary type = scheme + dependencies = machine.F,mersenne_twister.f,physparam.f,radcons.f90 ######################################################################## [ccpp-arg-table] @@ -48,7 +49,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = GFS_rad_time_vary_finalize - type = scheme diff --git a/physics/GFS_rad_time_vary.scm.meta b/physics/GFS_rad_time_vary.scm.meta index 7e87f1f8a..b78be178a 100644 --- a/physics/GFS_rad_time_vary.scm.meta +++ b/physics/GFS_rad_time_vary.scm.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = GFS_rad_time_vary_init +[ccpp-table-properties] + name = GFS_rad_time_vary type = scheme + dependencies = machine.F,mersenne_twister.f,physparam.f,radcons.f90 ######################################################################## [ccpp-arg-table] @@ -48,7 +49,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = GFS_rad_time_vary_finalize - type = scheme diff --git a/physics/GFS_rrtmg_post.F90 b/physics/GFS_rrtmg_post.F90 index c910d2fb1..7f80ca4c3 100644 --- a/physics/GFS_rrtmg_post.F90 +++ b/physics/GFS_rrtmg_post.F90 @@ -44,12 +44,12 @@ subroutine GFS_rrtmg_post_run (Model, Grid, Diag, Radtend, Statein, & integer, intent(in) :: im, lm, ltp, kt, kb, kd, nday real(kind=kind_phys), intent(in) :: raddt - real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(in) :: aerodp - real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(in) :: cldsa - integer, dimension(size(Grid%xlon,1),3), intent(in) :: mbota, mtopa - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: clouds1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: cldtausw - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: cldtaulw + real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(in) :: aerodp + real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(in) :: cldsa + integer, dimension(size(Grid%xlon,1),3), intent(in) :: mbota, mtopa + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: clouds1 + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: cldtausw + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: cldtaulw character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg diff --git a/physics/GFS_rrtmg_post.meta b/physics/GFS_rrtmg_post.meta index 61e89098d..43c25ae2e 100644 --- a/physics/GFS_rrtmg_post.meta +++ b/physics/GFS_rrtmg_post.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = GFS_rrtmg_post_init +[ccpp-table-properties] + name = GFS_rrtmg_post type = scheme + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,radsw_param.f ######################################################################## [ccpp-arg-table] @@ -206,7 +207,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmg_post_finalize - type = scheme diff --git a/physics/GFS_rrtmg_pre.F90 b/physics/GFS_rrtmg_pre.F90 index d0826eb17..9c5b84d5f 100644 --- a/physics/GFS_rrtmg_pre.F90 +++ b/physics/GFS_rrtmg_pre.F90 @@ -32,8 +32,8 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input faersw1, faersw2, faersw3, & faerlw1, faerlw2, faerlw3, aerodp, & clouds1, clouds2, clouds3, clouds4, clouds5, clouds6, & - clouds7, clouds8, clouds9, cldsa, & - mtopa, mbota, de_lgth, alb1d, errmsg, errflg) + clouds7, clouds8, clouds9, cldsa, cldfra, & + mtopa, mbota, de_lgth, alpha, alb1d, errmsg, errflg) use machine, only: kind_phys use GFS_typedefs, only: GFS_statein_type, & @@ -95,90 +95,71 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input integer, intent(out) :: kd, kt, kb ! F-A mp scheme only - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_ice - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_rain - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(in) :: f_rimef - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: cwm - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: flgmin + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(in) :: f_ice, & + f_rain, f_rimef + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: cwm + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: flgmin real(kind=kind_phys), intent(out) :: raddt + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: delp, & + dz, plyr, tlyr, qlyr, olyr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: delp - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: dz - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP), intent(out) :: plvl - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: plyr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP), intent(out) :: tlvl - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: tlyr - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: tsfg - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: tsfa - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: qlyr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: olyr - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_co2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_n2o - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_ch4 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_o2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_co - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_cfc11 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_cfc12 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_cfc22 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_ccl4 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: gasvmr_cfc113 - - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW), intent(out) :: faersw1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW), intent(out) :: faersw2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW), intent(out) :: faersw3 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW), intent(out) :: faerlw1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW), intent(out) :: faerlw2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW), intent(out) :: faerlw3 - - real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(out) :: aerodp - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(inout) :: clouds1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(inout) :: clouds2 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(inout) :: clouds3 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(inout) :: clouds4 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(inout) :: clouds5 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds6 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds7 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds8 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP), intent(out) :: clouds9 - real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(out) :: cldsa - integer, dimension(size(Grid%xlon,1),3), intent(out) :: mbota - integer, dimension(size(Grid%xlon,1),3), intent(out) :: mtopa - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: de_lgth - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: alb1d + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+1+LTP), intent(out) :: plvl, tlvl + + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: tsfg, tsfa + + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: gasvmr_co2, & + gasvmr_n2o, gasvmr_ch4, gasvmr_o2, gasvmr_co, gasvmr_cfc11, & + gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, gasvmr_cfc113 + + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDSW), intent(out) :: faersw1, & + faersw2, faersw3 + + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDLW), intent(out) :: faerlw1, & + faerlw2, faerlw3 + + real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1), intent(out) :: aerodp + + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(inout) :: clouds1, & + clouds2, clouds3, clouds4, clouds5 + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: clouds6, & + clouds7, clouds8, clouds9, cldfra + + real(kind=kind_phys), dimension(size(Grid%xlon,1),5), intent(out) :: cldsa + integer, dimension(size(Grid%xlon,1),3), intent(out) :: mbota, mtopa + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: de_lgth, alb1d + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP), intent(out) :: alpha character(len=*), intent(out) :: errmsg - integer, intent(out) :: errflg + integer, intent(out) :: errflg ! Local variables integer :: me, nfxr, ntrac, ntcw, ntiw, ncld, ntrw, ntsw, ntgl, ncndl, ntlnc, ntinc, ntwa integer :: i, j, k, k1, k2, lsk, lv, n, itop, ibtc, LP1, lla, llb, lya, lyb - real(kind=kind_phys) :: es, qs, delt, tem0d + real(kind=kind_phys) :: es, qs, delt, tem0d, pfac real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: cvt1, cvb1, tem1d, tskn - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: & + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP) :: & htswc, htlwc, gcice, grain, grime, htsw0, htlw0, & rhly, tvly,qstl, vvel, clw, ciw, prslk1, tem2da, & - cldcov, deltaq, cnvc, cnvw, & + dzb, hzb, cldcov, deltaq, cnvc, cnvw, & effrl, effri, effrr, effrs, rho, orho ! for Thompson MP - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: & + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP) :: & re_cloud, re_ice, re_snow, qv_mp, qc_mp, & qi_mp, qs_mp, nc_mp, ni_mp, nwfa - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP+1) :: tem2db -! real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP+1) :: hz + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP+1) :: tem2db, hz - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,min(4,Model%ncnd)) :: ccnd - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,2:Model%ntrac) :: tracer1 - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_CLDS) :: clouds - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_VGAS) :: gasvmr - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW,NF_AESW)::faersw - real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW,NF_AELW)::faerlw + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,min(4,Model%ncnd)) :: ccnd + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,2:Model%ntrac) :: tracer1 + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NF_CLDS) :: clouds + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NF_VGAS) :: gasvmr + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDSW,NF_AESW) ::faersw + real(kind=kind_phys), dimension(size(Grid%xlon,1),lm+LTP,NBDLW,NF_AELW) ::faerlw real(kind=kind_phys) :: qvs ! @@ -191,8 +172,8 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input if (.not. (Model%lsswr .or. Model%lslwr)) return !--- set commonly used integers - me = Model%me - NFXR = Model%nfxr + me = Model%me + NFXR = Model%nfxr NTRAC = Model%ntrac ! tracers in grrad strip off sphum - start tracer1(2:NTRAC) ntcw = Model%ntcw ntiw = Model%ntiw @@ -228,16 +209,16 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input llb = 1 ! local index at toa level lya = 2 ! local index for the 2nd layer from top lyb = 1 ! local index for the top layer - endif ! end if_ivflip_block + endif ! end if_ivflip_block else kd = 0 - if ( ivflip == 1 ) then ! vertical from sfc upward + if ( ivflip == 1 ) then ! vertical from sfc upward kt = 1 ! index diff between lyr and upper bound kb = 0 ! index diff between lyr and lower bound - else ! vertical from toa downward + else ! vertical from toa downward kt = 0 ! index diff between lyr and upper bound kb = 1 ! index diff between lyr and lower bound - endif ! end if_ivflip_block + endif ! end if_ivflip_block endif ! end if_lextop_block raddt = min(Model%fhswr, Model%fhlwr) @@ -266,7 +247,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input lsk = 0 if (ivflip == 0 .and. lm < Model%levs) lsk = Model%levs - lm -! convert pressure unit from pa to mb +! convert pressure unit from pa to mb do k = 1, LM k1 = k + kd k2 = k + lsk @@ -296,38 +277,49 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input enddo ! if (ivflip == 0) then ! input data from toa to sfc - do i = 1, IM - plvl(i,1+kd) = 0.01 * Statein%prsi(i,1) ! pa to mb (hpa) - enddo - if (lsk /= 0) then + if (lsk > 0) then + k1 = 1 + kd + k2 = k1 + kb + do i = 1, IM + plvl(i,k2) = 0.01 * Statein%prsi(i,1+kb) ! pa to mb (hpa) + plyr(i,k1) = 0.5 * (plvl(i,k2+1) + plvl(i,k2)) + prslk1(i,k1) = (plyr(i,k1)*0.001) ** rocp + enddo + else + k1 = 1 + kd do i = 1, IM - plvl(i,1+kd) = 0.5 * (plvl(i,2+kd) + plvl(i,1+kd)) + plvl(i,k1) = Statein%prsi(i,1) * 0.01 ! pa to mb (hpa) enddo endif else ! input data from sfc to top - do i = 1, IM - plvl(i,LP1+kd) = 0.01 * Statein%prsi(i,LP1+lsk) ! pa to mb (hpa) - enddo - if (lsk /= 0) then + if (Model%levs > lm) then + k1 = lm + kd do i = 1, IM - plvl(i,LM+kd) = 0.5 * (plvl(i,LP1+kd) + plvl(i,LM+kd)) + plvl(i,k1+1) = 0.01 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) + plyr(i,k1) = 0.5 * (plvl(i,k1+1) + plvl(i,k1)) + prslk1(i,k1) = (plyr(i,k1)*0.001) ** rocp + enddo + else + k1 = lp1 + kd + do i = 1, IM + plvl(i,k1) = Statein%prsi(i,lp1) * 0.01 ! pa to mb (hpa) enddo endif endif - +! if ( lextop ) then ! values for extra top layer do i = 1, IM plvl(i,llb) = prsmin if ( plvl(i,lla) <= prsmin ) plvl(i,lla) = 2.0*prsmin plyr(i,lyb) = 0.5 * plvl(i,lla) tlyr(i,lyb) = tlyr(i,lya) - prslk1(i,lyb) = (plyr(i,lyb)*0.00001) ** rocp ! plyr in Pa + prslk1(i,lyb) = (plyr(i,lyb)*0.001) ** rocp ! plyr in Pa rhly(i,lyb) = rhly(i,lya) qstl(i,lyb) = qstl(i,lya) enddo ! --- note: may need to take care the top layer amount - tracer1(:,lyb,:) = tracer1(:,lya,:) + tracer1(:,lyb,:) = tracer1(:,lya,:) endif @@ -432,6 +424,10 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input enddo ! --- ... level height and layer thickness (km) +! dz: Layer thickness between layer boundaries +! dzb: Layer thickness between layer centers (lowest is from surface to lowest layer center) +! hz: Height of each level (i.e. layer boundary) +! hzb: Height of each layer center tem0d = 0.001 * rog do i = 1, IM @@ -439,10 +435,20 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input dz(i,k) = tem0d * (tem2db(i,k+1) - tem2db(i,k)) * tvly(i,k) enddo -! hz(i,LMP) = 0.0 -! do k = LMK, 1, -1 -! hz(i,k) = hz(i,k+1) + dz(i,k) -! enddo + hz(i,LMP) = 0.0 + do k = LMK, 1, -1 + hz(i,k) = hz(i,k+1) + dz(i,k) + enddo + + do k = LMK, 1, -1 + pfac = (tem2db(i,k+1) - tem2da(i,k)) / (tem2db(i,k+1) - tem2db(i,k)) + hzb(i,k) = hz(i,k+1) + pfac * (hz(i,k) - hz(i,k+1)) + enddo + + do k = LMK-1, 1, -1 + dzb(i,k) = hzb(i,k) - hzb(i,k+1) + enddo + dzb(i,LMK) = hzb(i,LMK) - hz(i,LMP) enddo else ! input data from sfc to toa @@ -483,6 +489,10 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input enddo ! --- ... level height and layer thickness (km) +! dz: Layer thickness between layer boundaries +! dzb: Layer thickness between layer centers (lowest is from surface to lowest layer center) +! hz: Height of each level (i.e. layer boundary) +! hzb: Height of each layer center tem0d = 0.001 * rog do i = 1, IM @@ -490,10 +500,20 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input dz(i,k) = tem0d * (tem2db(i,k) - tem2db(i,k+1)) * tvly(i,k) enddo -! hz(i,1) = 0.0 -! do k = 1, LMP -! hz(i,k+1) = hz(i,k) + dz(i,k) -! enddo + hz(i,1) = 0.0 + do k = 1, LMK + hz(i,k+1) = hz(i,k) + dz(i,k) + enddo + + do k = 1, LMK + pfac = (tem2db(i,k) - tem2da(i,k)) / (tem2db(i,k) - tem2db(i,k+1)) + hzb(i,k) = hz(i,k) + pfac * (hz(i,k+1) - hz(i,k)) + enddo + + do k = 2, LMK + dzb(i,k) = hzb(i,k) - hzb(i,k-1) + enddo + dzb(i,1) = hzb(i,1) - hz(i,1) enddo endif ! end_if_ivflip @@ -504,7 +524,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input !check print *,' in grrad : calling setaer ' call setaer (plvl, plyr, prslk1, tvly, rhly, Sfcprop%slmsk, & ! --- inputs - tracer1, Tbd%aer_nm, & + tracer1, Tbd%aer_nm, & Grid%xlon, Grid%xlat, IM, LMK, LMP, & Model%lsswr,Model%lslwr, & faersw,faerlw,aerodp) ! --- outputs @@ -598,7 +618,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input qc_mp (i,k) = tracer1(i,k,ntcw)/(1.-qvs) qi_mp (i,k) = tracer1(i,k,ntiw)/(1.-qvs) qs_mp (i,k) = tracer1(i,k,ntsw)/(1.-qvs) - nc_mp (i,k) = nt_c*orho(i,k1) + nc_mp (i,k) = nt_c*orho(i,k) ni_mp (i,k) = tracer1(i,k,ntinc)/(1.-qvs) enddo enddo @@ -815,19 +835,21 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! or unified cloud and/or with MG microphysics if (Model%uni_cld .and. Model%ncld >= 2) then - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs - Grid%xlat, Grid%xlon, Sfcprop%slmsk,dz,delp, & - IM, LMK, LMP, cldcov, & - effrl, effri, effrr, effrs, Model%effr_in, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs + Grid%xlat, Grid%xlon, Sfcprop%slmsk,dz,delp, & + IM, LMK, LMP, cldcov, & + effrl, effri, effrr, effrs, Model%effr_in, & + dzb, Grid%xlat_d, Model%julian, Model%yearlen, & + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs else - call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs - ccnd(1:IM,1:LMK,1), Grid%xlat,Grid%xlon, & - Sfcprop%slmsk, dz, delp, IM, LMK, LMP, & - Model%uni_cld, Model%lmfshal, & - Model%lmfdeep2, cldcov, & - effrl, effri, effrr, effrs, Model%effr_in, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs + ccnd(1:IM,1:LMK,1), Grid%xlat,Grid%xlon, & + Sfcprop%slmsk, dz, delp, IM, LMK, LMP, & + Model%uni_cld, Model%lmfshal, & + Model%lmfdeep2, cldcov, & + effrl, effri, effrr, effrs, Model%effr_in, & + dzb, Grid%xlat_d, Model%julian, Model%yearlen, & + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs endif elseif(Model%imp_physics == 98) then ! zhao/moorthi's prognostic cloud+pdfcld @@ -837,7 +859,8 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input cnvw, cnvc, Grid%xlat, Grid%xlon, & Sfcprop%slmsk, dz, delp, im, lmk, lmp, deltaq, & Model%sup, Model%kdt, me, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + dzb, Grid%xlat_d, Model%julian, Model%yearlen, & + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs elseif (Model%imp_physics == 11) then ! GFDL cloud scheme @@ -847,21 +870,24 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ccnd(1:IM,1:LMK,1), cnvw, cnvc, & Grid%xlat, Grid%xlon, Sfcprop%slmsk, & cldcov, dz, delp, im, lmk, lmp, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + dzb, Grid%xlat_d, Model%julian, Model%yearlen, & + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs else call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, & ! --- inputs Grid%xlat, Grid%xlon, Sfcprop%slmsk, dz,delp, & IM, LMK, LMP, cldcov, & effrl, effri, effrr, effrs, Model%effr_in, & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + dzb, Grid%xlat_d, Model%julian, Model%yearlen,& + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs ! call progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs ! tracer1, Grid%xlat, Grid%xlon, Sfcprop%slmsk, & ! dz, delp, & ! ntrac-1, Model%ntcw-1,Model%ntiw-1,Model%ntrw-1,& ! Model%ntsw-1,Model%ntgl-1,Model%ntclamt-1, & ! im, lmk, lmp, & -! clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs +! dzb, Grid%xlat_d, Model%julian, Model%yearlen, & +! clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs endif elseif(Model%imp_physics == 6 .or. Model%imp_physics == 15) then @@ -871,15 +897,16 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Tbd%phy_f3d(:,:,Model%nseffr) = 250. endif - call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs - Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lmk, lmp, Model%uni_cld, & - Model%lmfshal,Model%lmfdeep2, & - cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & - Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & - clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs + call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, Model%uni_cld, & + Model%lmfshal,Model%lmfdeep2, & + cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & + Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & + dzb, Grid%xlat_d, Model%julian, Model%yearlen,& + clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs elseif(Model%imp_physics == Model%imp_physics_thompson) then ! Thompson MP @@ -900,19 +927,21 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input Grid%xlat, Grid%xlon, Sfcprop%slmsk, dz,delp, & IM, LMK, LMP, clouds(:,1:LMK,1), & effrl, effri, effrr, effrs, Model%effr_in , & - clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs + dzb, Grid%xlat_d, Model%julian, Model%yearlen, & + clouds, cldsa, mtopa, mbota, de_lgth, alpha) ! --- outputs else ! MYNN PBL or GF convective are not used - call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs - Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & - ntrac-1, ntcw-1,ntiw-1,ntrw-1, & - ntsw-1,ntgl-1, & - im, lmk, lmp, Model%uni_cld, & - Model%lmfshal,Model%lmfdeep2, & - cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & - Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & - clouds,cldsa,mtopa,mbota, de_lgth) ! --- outputs + call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + Grid%xlat,Grid%xlon,Sfcprop%slmsk,dz,delp, & + ntrac-1, ntcw-1,ntiw-1,ntrw-1, & + ntsw-1,ntgl-1, & + im, lmk, lmp, Model%uni_cld, & + Model%lmfshal,Model%lmfdeep2, & + cldcov(:,1:LMK),Tbd%phy_f3d(:,:,1), & + Tbd%phy_f3d(:,:,2), Tbd%phy_f3d(:,:,3), & + dzb, Grid%xlat_d, Model%julian, Model%yearlen,& + clouds,cldsa,mtopa,mbota, de_lgth, alpha) ! --- outputs endif ! MYNN PBL or GF endif ! end if_imp_physics @@ -930,6 +959,7 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input clouds7(i,k) = clouds(i,k,7) clouds8(i,k) = clouds(i,k,8) clouds9(i,k) = clouds(i,k,9) + cldfra(i,k) = clouds(i,k,1) enddo enddo @@ -938,12 +968,15 @@ subroutine GFS_rrtmg_pre_run (Model, Grid, Sfcprop, Statein, & ! input ! perturbation size ! --- turn vegetation fraction pattern into percentile pattern alb1d(:) = 0. - if (Model%do_sfcperts) then - if (Model%pertalb(1) > 0.) then - do i=1,im - call cdfnor(Coupling%sfc_wts(i,5),alb1d(i)) + if (Model%lndp_type==1) then + do k =1,Model%n_var_lndp + if (Model%lndp_var_list(k) == 'alb') then + do i=1,im + call cdfnor(Coupling%sfc_wts(i,k),alb1d(i)) + !lndp_alb = Model%lndp_prt_list(k) + enddo + endif enddo - endif endif ! mg, sfc-perts diff --git a/physics/GFS_rrtmg_pre.meta b/physics/GFS_rrtmg_pre.meta index a06e718a5..5147c1990 100644 --- a/physics/GFS_rrtmg_pre.meta +++ b/physics/GFS_rrtmg_pre.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = GFS_rrtmg_pre_init +[ccpp-table-properties] + name = GFS_rrtmg_pre type = scheme + dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,module_mp_radar.F90,module_mp_thompson.F90,module_mp_thompson_make_number_concentrations.F90,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radlw_param.f,radsw_param.f,surface_perturbation.F90 ######################################################################## [ccpp-arg-table] @@ -529,6 +530,15 @@ kind = kind_phys intent = out optional = F +[cldfra] + standard_name = instantaneous_3d_cloud_fraction + long_name = instantaneous 3D cloud fraction for all MPs + units = frac + dimensions = (horizontal_dimension,vertical_dimension) + type = real + kind = kind_phys + intent = out + optional = F [mtopa] standard_name = model_layer_number_at_cloud_top long_name = vertical indices for low, middle and high cloud tops @@ -554,6 +564,15 @@ kind = kind_phys intent = out optional = F +[alpha] + standard_name = cloud_overlap_decorrelation_parameter + long_name = cloud overlap decorrelation parameter + units = frac + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = out + optional = F [alb1d] standard_name = surface_albedo_perturbation long_name = surface albedo perturbation @@ -581,7 +600,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmg_pre_finalize - type = scheme diff --git a/physics/GFS_rrtmg_setup.F90 b/physics/GFS_rrtmg_setup.F90 index b6d86a34e..b3c91cacc 100644 --- a/physics/GFS_rrtmg_setup.F90 +++ b/physics/GFS_rrtmg_setup.F90 @@ -400,7 +400,7 @@ subroutine radinit( si, NLAY, imp_physics, me ) ! ! ! attributes: ! ! language: fortran 90 ! -! machine: wcoss ! +! machine: wcoss ! ! ! ! ==================== definition of variables ==================== ! ! ! @@ -683,7 +683,7 @@ subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & ! solcon : sun-earth distance adjusted solar constant (w/m2) ! ! ! ! external module variables: ! -! isolar : solar constant cntrl (in module physparam) ! +! isolar : solar constant cntrl (in module physparam) ! ! = 0: use the old fixed solar constant in "physcon" ! ! =10: use the new fixed solar constant in "physcon" ! ! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! diff --git a/physics/GFS_rrtmg_setup.meta b/physics/GFS_rrtmg_setup.meta index 3ca93ffd4..fec7e32d0 100644 --- a/physics/GFS_rrtmg_setup.meta +++ b/physics/GFS_rrtmg_setup.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_rrtmg_setup + type = scheme + dependencies = iounitdef.f,module_bfmicrophysics.f,physparam.f,radcons.f90,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_surface.f,radlw_main.f,radlw_param.f,radsw_main.f,radsw_param.f + +######################################################################## [ccpp-arg-table] name = GFS_rrtmg_setup_init type = scheme @@ -107,7 +113,7 @@ intent = in optional = F [iovr_sw] - standard_name = flag_for_max_random_overlap_clouds_for_shortwave_radiation + standard_name = flag_for_cloud_overlap_method_for_shortwave_radiation long_name = sw: max-random overlap clouds units = flag dimensions = () @@ -115,7 +121,7 @@ intent = in optional = F [iovr_lw] - standard_name = flag_for_max_random_overlap_clouds_for_longwave_radiation + standard_name = flag_for_cloud_overlap_method_for_longwave_radiation long_name = lw: max-random overlap clouds units = flag dimensions = () diff --git a/physics/GFS_rrtmgp_gfdlmp_pre.meta b/physics/GFS_rrtmgp_gfdlmp_pre.meta index 932ffeb8f..7e0797538 100644 --- a/physics/GFS_rrtmgp_gfdlmp_pre.meta +++ b/physics/GFS_rrtmgp_gfdlmp_pre.meta @@ -1,3 +1,8 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_gfdlmp_pre + type = scheme + dependencies = rrtmgp_aux.F90 + ######################################################################## [ccpp-arg-table] name = GFS_rrtmgp_gfdlmp_pre_run diff --git a/physics/GFS_rrtmgp_lw_post.meta b/physics/GFS_rrtmgp_lw_post.meta index c261a7797..a786da2e8 100644 --- a/physics/GFS_rrtmgp_lw_post.meta +++ b/physics/GFS_rrtmgp_lw_post.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_lw_post + type = scheme + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radlw_param.f,rte-rrtmgp/extensions/mo_fluxes_byband.F90,rte-rrtmgp/extensions/mo_fluxes_byband_kernels.F90,rrtmgp_aux.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rte-rrtmgp/extensions/mo_heating_rates.F90 + +######################################################################## [ccpp-arg-table] name = GFS_rrtmgp_lw_post_run type = scheme diff --git a/physics/GFS_rrtmgp_pre.meta b/physics/GFS_rrtmgp_pre.meta index 95a9403cd..2e27f46ac 100644 --- a/physics/GFS_rrtmgp_pre.meta +++ b/physics/GFS_rrtmgp_pre.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_pre + type = scheme + dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,physparam.f,radcons.f90,radiation_aerosols.f + dependencies = radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_surface.f,rrtmgp_aux.F90,rrtmg_lw_cloud_optics.F90 + +######################################################################## [ccpp-arg-table] name = GFS_rrtmgp_pre_init type = scheme diff --git a/physics/GFS_rrtmgp_setup.meta b/physics/GFS_rrtmgp_setup.meta index aec1b4374..45e9d65a2 100644 --- a/physics/GFS_rrtmgp_setup.meta +++ b/physics/GFS_rrtmgp_setup.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_setup + type = scheme + dependencies = iounitdef.f,machine.F,module_bfmicrophysics.f,physparam.f,radiation_aerosols.f,radiation_astronomy.f,radiation_clouds.f,radiation_gases.f,radiation_surface.f + +######################################################################## [ccpp-arg-table] name = GFS_rrtmgp_setup_init type = scheme @@ -155,7 +161,7 @@ intent = in optional = F [iovr_sw] - standard_name = flag_for_max_random_overlap_clouds_for_shortwave_radiation + standard_name = flag_for_cloud_overlap_method_for_shortwave_radiation long_name = sw: max-random overlap clouds units = flag dimensions = () @@ -163,7 +169,7 @@ intent = in optional = F [iovr_lw] - standard_name = flag_for_max_random_overlap_clouds_for_longwave_radiation + standard_name = flag_for_cloud_overlap_method_for_longwave_radiation long_name = lw: max-random overlap clouds units = flag dimensions = () diff --git a/physics/GFS_rrtmgp_sw_post.meta b/physics/GFS_rrtmgp_sw_post.meta index 94f2cbf5f..128e66fac 100644 --- a/physics/GFS_rrtmgp_sw_post.meta +++ b/physics/GFS_rrtmgp_sw_post.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_sw_post + type = scheme + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,radsw_param.f,rte-rrtmgp/extensions/mo_fluxes_byband.F90,rte-rrtmgp/extensions/mo_fluxes_byband_kernels.F90 + dependencies = rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rte-rrtmgp/extensions/mo_heating_rates.F90,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = GFS_rrtmgp_sw_post_run type = scheme diff --git a/physics/GFS_rrtmgp_sw_pre.F90 b/physics/GFS_rrtmgp_sw_pre.F90 index c4208d872..f6aac60b1 100644 --- a/physics/GFS_rrtmgp_sw_pre.F90 +++ b/physics/GFS_rrtmgp_sw_pre.F90 @@ -27,8 +27,9 @@ end subroutine GFS_rrtmgp_sw_pre_init !> \section arg_table_GFS_rrtmgp_sw_pre_run !! \htmlinclude GFS_rrtmgp_sw_pre.html !! - subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, nsfcpert, lsswr, do_sfcperts, solhr, & - pertalb, lon, coslat, sinlat, snowd, sncovr, snoalb, zorl, tsfc, hprime, alvsf, & + subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, lndp_type, n_var_lndp,lndp_var_list, & + lndp_prt_list, lsswr, solhr, & + lon, coslat, sinlat, snowd, sncovr, snoalb, zorl, tsfc, hprime, alvsf, & alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, lsmask, sfc_wts, p_lay, tv_lay, & relhum, p_lev, sw_gas_props, & nday, idxday, alb1d, coszen, coszdg, sfc_alb_nir_dir, sfc_alb_nir_dif, & @@ -39,14 +40,16 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, nsfcpert, lsswr, do_sfcperts, s me, & ! Current MPI rank nCol, & ! Number of horizontal grid points nLev, & ! Number of vertical layers - nsfcpert ! Number of surface perturbations + n_var_lndp, & ! Number of surface variables perturbed + lndp_type ! Type of land perturbations scheme used + character(len=3), dimension(n_var_lndp), intent(in) :: & + lndp_var_list + real(kind_phys), dimension(n_var_lndp), intent(in) :: & + lndp_prt_list logical,intent(in) :: & - lsswr, & ! Call RRTMGP SW radiation? - do_sfcperts + lsswr ! Call RRTMGP SW radiation? real(kind_phys), intent(in) :: & - solhr ! Time in hours after 00z at the current timestep - real(kind_phys), dimension(5), intent(in) :: & - pertalb ! Magnitude of surface albedo perturbation (frac) + solhr ! Time in hours after 00z at the current timestep real(kind_phys), dimension(nCol), intent(in) :: & lsmask, & ! Landmask: sea/land/ice=0/1/2 lon, & ! Longitude @@ -66,7 +69,7 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, nsfcpert, lsswr, do_sfcperts, s facwf, & ! Fractional coverage with weak cosz dependency (frac) fice, & ! Ice fraction over open water (frac) tisfc ! Sea ice surface skin temperature (K) - real(kind_phys), dimension(nCol,nsfcpert), intent(in) :: & + real(kind_phys), dimension(nCol,n_var_lndp), intent(in) :: & sfc_wts ! Weights for stochastic surface physics perturbation () real(kind_phys), dimension(nCol,nLev),intent(in) :: & p_lay, & ! Layer pressure @@ -100,6 +103,7 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, nsfcpert, lsswr, do_sfcperts, s ! Local variables integer :: i, j, iCol, iBand, iLay real(kind_phys), dimension(ncol, NF_ALBD) :: sfcalb + real(kind_phys) :: lndp_alb ! Initialize CCPP error handling variables errmsg = '' @@ -130,13 +134,17 @@ subroutine GFS_rrtmgp_sw_pre_run(me, nCol, nLev, nsfcpert, lsswr, do_sfcperts, s ! --- turn vegetation fraction pattern into percentile pattern ! ####################################################################################### alb1d(:) = 0. - if (do_sfcperts) then - if (pertalb(1) > 0.) then + lndp_alb = -999. + if (lndp_type ==1) then + do k =1,n_var_lndp + if (lndp_var_list(k) == 'alb') then do i=1,ncol - call cdfnor(sfc_wts(i,5),alb1d(i)) + call cdfnor(sfc_wts(i,k),alb1d(i)) + lndp_alb = lndp_prt_list(k) enddo - endif - endif + endif + enddo + endif ! ####################################################################################### ! Call module_radiation_surface::setalb() to setup surface albedo. diff --git a/physics/GFS_rrtmgp_sw_pre.meta b/physics/GFS_rrtmgp_sw_pre.meta index 1cccf6ffd..81ed3137e 100644 --- a/physics/GFS_rrtmgp_sw_pre.meta +++ b/physics/GFS_rrtmgp_sw_pre.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_sw_pre + type = scheme + dependencies = iounitdef.f,machine.F,physparam.f,radiation_astronomy.f,radiation_surface.f + +######################################################################## [ccpp-arg-table] name = GFS_rrtmgp_sw_pre_run type = scheme @@ -25,25 +31,43 @@ type = integer intent = in optional = F -[nsfcpert] - standard_name = number_of_surface_perturbations - long_name = number of surface perturbations +[n_var_lndp] + standard_name = number_of_land_surface_variables_perturbed + long_name = number of land surface variables perturbed units = count dimensions = () type = integer intent = in optional = F -[lsswr] - standard_name = flag_to_calc_sw - long_name = logical flags for sw radiation calls - units = flag +[lndp_type] + standard_name = index_for_stochastic_land_surface_perturbation_type + long_name = index for stochastic land surface perturbations type + units = index dimensions = () - type = logical + type = integer intent = in optional = F -[do_sfcperts] - standard_name = flag_for_stochastic_surface_perturbations - long_name = flag for stochastic surface perturbations option +[lndp_prt_list] + standard_name =magnitude_of_perturbations_for_landperts + long_name = magnitude of perturbations for landperts + units = variable + dimensions = (number_of_land_surface_variables_perturbed) + type = real + kind = kind_phys + intent = in + optional = F +[lndp_var_list] + standard_name = variables_to_be_perturbed_for_landperts + long_name = variables to be perturbed for landperts + units = none + dimensions = (number_of_land_surface_variables_perturbed) + type = character + kind = len=3 + intent = in + optional = F +[lsswr] + standard_name = flag_to_calc_sw + long_name = logical flags for sw radiation calls units = flag dimensions = () type = logical @@ -58,15 +82,6 @@ kind = kind_phys intent = in optional = F -[pertalb] - standard_name = magnitude_of_surface_albedo_perturbation - long_name = magnitude of surface albedo perturbation - units = frac - dimensions = (5) - type = real - kind = kind_phys - intent = in - optional = F [lon] standard_name = longitude long_name = longitude @@ -387,7 +402,3 @@ type = integer intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = GFS_rrtmgp_sw_pre_finalize - type = scheme diff --git a/physics/GFS_rrtmgp_zhaocarr_pre.F90 b/physics/GFS_rrtmgp_zhaocarr_pre.F90 index ac9fb7446..35b404b45 100644 --- a/physics/GFS_rrtmgp_zhaocarr_pre.F90 +++ b/physics/GFS_rrtmgp_zhaocarr_pre.F90 @@ -6,7 +6,7 @@ module GFS_rrtmgp_zhaocarr_pre use machine, only: kind_phys use rrtmgp_aux, only: check_error_msg use funcphys, only: fpvs - use module_radiation_clouds, only: get_alpha_dcorr + use module_radiation_clouds, only: get_alpha_dcorr ! Zhao-Carr MP parameters. real(kind_phys), parameter :: & diff --git a/physics/GFS_rrtmgp_zhaocarr_pre.meta b/physics/GFS_rrtmgp_zhaocarr_pre.meta index 052da5798..11aac8437 100644 --- a/physics/GFS_rrtmgp_zhaocarr_pre.meta +++ b/physics/GFS_rrtmgp_zhaocarr_pre.meta @@ -1,3 +1,8 @@ +[ccpp-table-properties] + name = GFS_rrtmgp_zhaocarr_pre + type = scheme + dependencies = rrtmgp_aux.F90 + ######################################################################## [ccpp-arg-table] name = GFS_rrtmgp_zhaocarr_pre_run diff --git a/physics/GFS_stochastics.meta b/physics/GFS_stochastics.meta index bd0dbf487..c729a3980 100644 --- a/physics/GFS_stochastics.meta +++ b/physics/GFS_stochastics.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_stochastics + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = GFS_stochastics_run type = scheme @@ -26,8 +32,8 @@ intent = in optional = F [do_sppt] - standard_name = flag_for_stochastic_surface_physics_perturbations - long_name = flag for stochastic surface physics perturbations + standard_name = flag_for_stochastic_physics_perturbations + long_name = flag for stochastic physics perturbations units = flag dimensions = () type = logical diff --git a/physics/GFS_suite_interstitial.F90 b/physics/GFS_suite_interstitial.F90 index 5e6104478..263e316a5 100644 --- a/physics/GFS_suite_interstitial.F90 +++ b/physics/GFS_suite_interstitial.F90 @@ -100,6 +100,7 @@ subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, real(kind=kind_phys), intent(out), dimension(im) :: work1, work2, psurf real(kind=kind_phys), intent(out), dimension(im,levs) :: dudt, dvdt, dtdt, dtdtc real(kind=kind_phys), intent(out), dimension(im,levs,ntrac) :: dqdt + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -114,23 +115,23 @@ subroutine GFS_suite_interstitial_1_run (im, levs, ntrac, dtf, dtp, slmsk, area, islmsk(i) = nint(slmsk(i)) work1(i) = (log(area(i)) - dxmin) * dxinv - work1(i) = max(0.0, min(1.0,work1(i))) - work2(i) = 1.0 - work1(i) + work1(i) = max(zero, min(one, work1(i))) + work2(i) = one - work1(i) psurf(i) = pgr(i) end do do k=1,levs do i=1,im - dudt(i,k) = 0. - dvdt(i,k) = 0. - dtdt(i,k) = 0. - dtdtc(i,k) = 0. + dudt(i,k) = zero + dvdt(i,k) = zero + dtdt(i,k) = zero + dtdtc(i,k) = zero enddo enddo do n=1,ntrac do k=1,levs do i=1,im - dqdt(i,k,n) = 0. + dqdt(i,k,n) = zero enddo enddo enddo @@ -143,7 +144,7 @@ end module GFS_suite_interstitial_1 module GFS_suite_interstitial_2 use machine, only: kind_phys - real(kind=kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: one = 1.0_kind_phys logical :: linit_mod = .false. contains @@ -206,13 +207,14 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl integer, intent(out) :: errflg ! local variables - real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) + real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) integer :: i, k real(kind=kind_phys) :: tem1, tem2, tem, hocp logical, dimension(im) :: invrsn real(kind=kind_phys), dimension(im) :: tx1, tx2, dT - real(kind=kind_phys), parameter :: qmin = 1.0d-10 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-10_kind_phys, epsln=1.0e-10_kind_phys ! Initialize CCPP error handling variables errmsg = '' @@ -229,7 +231,7 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl do i = 1, im if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg tem1 = adjsfcdsw(i) / xcosz(i) - if ( tem1 >= 120.0 ) then + if ( tem1 >= 120.0_kind_phys ) then suntim(i) = suntim(i) + dtf endif endif @@ -240,94 +242,56 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ! --- ... when using RRTMGP w/ use_GP_jacobian, these adjustment factors are pre-computed ! --- ... and provided as inputs in this routine. - if (use_GP_jacobian) then + if (use_GP_jacobian) then ! Compute adjustment to the surface flux using Jacobian. - if(linit_mod) then - dT(:) = (skt(:) - sktp1r(:)) - adjsfculw(:) = fluxlwUP(:,1) + fluxlwUP_jac(:,1) * dT(:) - else - adjsfculw(:) = 0. - linit_mod = .true. - endif + if(linit_mod) then + dT(:) = (skt(:) - sktp1r(:)) + adjsfculw(:) = fluxlwUP(:,1) + fluxlwUP_jac(:,1) * dT(:) + else + adjsfculw(:) = 0. + linit_mod = .true. + endif - ! Store surface temperature for next iteration - sktp1r(:) = skt(:) - else - if (frac_grid) then - do i=1,im - tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell - if (flag_cice(i)) then - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + ulwsfc_cice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - else - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + adjsfculw_ice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - endif - enddo - else - do i=1,im - if (dry(i)) then ! all land - adjsfculw(i) = adjsfculw_lnd(i) - elseif (icy(i)) then ! ice (and water) - tem = one - cice(i) - if (flag_cice(i)) then - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = ulwsfc_cice(i) - endif - else - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = adjsfculw_ice(i) - endif - endif - else ! all water - adjsfculw(i) = adjsfculw_wat(i) - endif - enddo - endif - endif - - if (frac_grid) then - do i=1,im - tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell - if (flag_cice(i)) then - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + ulwsfc_cice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - else - adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & - + adjsfculw_ice(i) * tem & - + adjsfculw_wat(i) * (one - frland(i) - tem) - endif - enddo + ! Store surface temperature for next iteration + sktp1r(:) = skt(:) else - do i=1,im - if (dry(i)) then ! all land - adjsfculw(i) = adjsfculw_lnd(i) - elseif (icy(i)) then ! ice (and water) - tem = one - cice(i) + if (frac_grid) then + do i=1,im + tem = (one - frland(i)) * cice(i) ! tem = ice fraction wrt whole cell if (flag_cice(i)) then - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem - else - adjsfculw(i) = ulwsfc_cice(i) - endif + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + ulwsfc_cice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) else - if (wet(i) .and. adjsfculw_wat(i) /= huge) then - adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem + adjsfculw(i) = adjsfculw_lnd(i) * frland(i) & + + adjsfculw_ice(i) * tem & + + adjsfculw_wat(i) * (one - frland(i) - tem) + endif + enddo + else + do i=1,im + if (dry(i)) then ! all land + adjsfculw(i) = adjsfculw_lnd(i) + elseif (icy(i)) then ! ice (and water) + tem = one - cice(i) + if (flag_cice(i)) then + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = ulwsfc_cice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = ulwsfc_cice(i) + endif else - adjsfculw(i) = adjsfculw_ice(i) + if (wet(i) .and. adjsfculw_wat(i) /= huge) then + adjsfculw(i) = adjsfculw_ice(i)*cice(i) + adjsfculw_wat(i)*tem + else + adjsfculw(i) = adjsfculw_ice(i) + endif endif + else ! all water + adjsfculw(i) = adjsfculw_wat(i) endif - else ! all water - adjsfculw(i) = adjsfculw_wat(i) - endif - enddo + enddo + endif endif do i=1,im @@ -361,9 +325,9 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl do i=1, im invrsn(i) = .false. - tx1(i) = 0.0 - tx2(i) = 10.0 - ctei_r(i) = 10.0 + tx1(i) = zero + tx2(i) = 10.0_kind_phys + ctei_r(i) = 10.0_kind_phys enddo if ((((imfshalcnv == 0 .and. shal_cnv) .or. old_monin) .and. mstrat) & @@ -371,13 +335,13 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl ctei_rml(:) = ctei_rm(1)*work1(:) + ctei_rm(2)*work2(:) do k=1,levs/2 do i=1,im - if (prsi(i,1)-prsi(i,k+1) < 0.35*prsi(i,1) & + if (prsi(i,1)-prsi(i,k+1) < 0.35_kind_phys*prsi(i,1) & .and. (.not. invrsn(i))) then tem = (tgrs(i,k+1) - tgrs(i,k)) & / (prsl(i,k) - prsl(i,k+1)) - if (((tem > 0.00010) .and. (tx1(i) < 0.0)) .or. & - ((tem-abs(tx1(i)) > 0.0) .and. (tx2(i) < 0.0))) then + if (((tem > 0.0001_kind_phys) .and. (tx1(i) < zero)) .or. & + ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then invrsn(i) = .true. if (qgrs_water_vapor(i,k) > qgrs_water_vapor(i,k+1)) then @@ -387,10 +351,10 @@ subroutine GFS_suite_interstitial_2_run (im, levs, lssav, ldiag3d, lsidea, cplfl tem1 = tem1 / prslk(i,k+1) - tem2 / prslk(i,k) ! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI - ctei_r(i) = (1.0/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & + ctei_r(i) = (one/hocp)*tem1/(qgrs_water_vapor(i,k+1)-qgrs_water_vapor(i,k) & + qgrs_cloud_water(i,k+1)-qgrs_cloud_water(i,k)) else - ctei_r(i) = 10 + ctei_r(i) = 10.0_kind_phys endif if ( ctei_rml(i) > ctei_r(i) ) then @@ -573,8 +537,9 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & !real(kind=kind_phys),parameter :: slope_mg = 0.02, slope_upmg = 0.04, & ! turnrhcrit = 0.900, turnrhcrit_upper = 0.150 ! in the following inverse of slope_mg and slope_upmg are specified - real(kind=kind_phys),parameter :: slope_mg = 50.0_kind_phys, & - slope_upmg = 25.0_kind_phys + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys + real(kind=kind_phys), parameter :: slope_mg = 50.0_kind_phys, & + slope_upmg = 25.0_kind_phys ! Initialize CCPP error handling variables errmsg = '' @@ -597,10 +562,10 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & endif ! end if_ras or cfscnv or samf if (ntcw > 0) then - if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5) then ! compute rhc for GMAO macro physics cloud pdf + if (imp_physics == imp_physics_mg .and. rhcpbl < 0.5_kind_phys) then ! compute rhc for GMAO macro physics cloud pdf do i=1,im - tx1(i) = 1.0 / prsi(i,1) - tx2(i) = 1.0 - rhcmax*work1(i)-rhcbot*work2(i) + tx1(i) = one / prsi(i,1) + tx2(i) = one - rhcmax*work1(i)-rhcbot*work2(i) kk = min(kinver(i), max(2,kpbl(i))) tx3(i) = prsi(i,kk)*tx1(i) @@ -609,18 +574,18 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & do k = 1, levs do i = 1, im tem = prsl(i,k) * tx1(i) - tem1 = min(max((tem-tx3(i))*slope_mg, -20.0), 20.0) + tem1 = min(max((tem-tx3(i))*slope_mg, -20.0_kind_phys), 20.0_kind_phys) ! Using rhcpbl and rhctop from the namelist instead of 0.3 and 0.2 ! and rhcbot represents pbl top critical relative humidity - tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0), 20.0) ! Anning + tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) ! Anning if (islmsk(i) > 0) then - tem1 = 1.0 / (1.0+exp(tem1+tem1)) + tem1 = one / (one+exp(tem1+tem1)) else - tem1 = 2.0 / (1.0+exp(tem1+tem1)) + tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) endif - tem2 = 1.0 / (1.0+exp(tem2)) + tem2 = one / (one+exp(tem2)) - rhc(i,k) = min(rhcmax, max(0.7, 1.0-tx2(i)*tem1*tem2)) + rhc(i,k) = min(rhcmax, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) enddo enddo else @@ -628,12 +593,12 @@ subroutine GFS_suite_interstitial_3_run (im, levs, nn, cscnv, & do i=1,im kk = max(10,kpbl(i)) if (k < kk) then - tem = rhcbot - (rhcbot-rhcpbl) * (1.0-prslk(i,k)) / (1.0-prslk(i,kk)) + tem = rhcbot - (rhcbot-rhcpbl) * (one-prslk(i,k)) / (one-prslk(i,kk)) else tem = rhcpbl - (rhcpbl-rhctop) * (prslk(i,kk)-prslk(i,k)) / prslk(i,kk) endif tem = rhcmax * work1(i) + tem * work2(i) - rhc(i,k) = max(0.0, min(1.0,tem)) + rhc(i,k) = max(zero, min(one,tem)) enddo enddo endif @@ -728,6 +693,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to ! dqdti may not be allocated real(kind=kind_phys), dimension(:,:), intent(inout) :: dqdti + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -783,32 +749,32 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to enddo if (imp_physics == imp_physics_thompson .and. (ntlnc>0 .or. ntinc>0)) then - do k=1,levs - do i=1,im - !> - Density of air in kg m-3 - rho_dryair(i,k) = prsl(i,k)/(con_rd*save_tcp(i,k)) - !> - Convert specific humidity to dry mixing ratio - qv_mp(i,k) = spechum(i,k)/(1.0_kind_phys-spechum(i,k)) - if (ntlnc>0) then - !> - Convert moist mixing ratio to dry mixing ratio - qc_mp(i,k) = (clw(i,k,2)-save_qc(i,k))/(1.0_kind_phys-spechum(i,k)) - !> - Convert number concentration from moist to dry - nc_mp(i,k) = gq0(i,k,ntlnc)/(1.0_kind_phys-spechum(i,k)) - nc_mp(i,k) = max(0.0, nc_mp(i,k) + make_DropletNumber(qc_mp(i,k) * rho_dryair(i,k), nwfa(i,k)) * (1.0/rho_dryair(i,k))) - !> - Convert number concentrations from dry to moist - gq0(i,k,ntlnc) = nc_mp(i,k)/(1.0_kind_phys+qv_mp(i,k)) - endif - if (ntinc>0) then - !> - Convert moist mixing ratio to dry mixing ratio - qi_mp(i,k) = (clw(i,k,1)-save_qi(i,k))/(1.0_kind_phys-spechum(i,k)) - !> - Convert number concentration from moist to dry - ni_mp(i,k) = gq0(i,k,ntinc)/(1.0_kind_phys-spechum(i,k)) - ni_mp(i,k) = max(0.0, ni_mp(i,k) + make_IceNumber(qi_mp(i,k) * rho_dryair(i,k), save_tcp(i,k)) * (1.0/rho_dryair(i,k))) - !> - Convert number concentrations from dry to moist - gq0(i,k,ntinc) = ni_mp(i,k)/(1.0_kind_phys+qv_mp(i,k)) - endif - enddo - enddo + do k=1,levs + do i=1,im + !> - Density of air in kg m-3 + rho_dryair(i,k) = prsl(i,k) / (con_rd*save_tcp(i,k)) + !> - Convert specific humidity to dry mixing ratio + qv_mp(i,k) = spechum(i,k) / (one-spechum(i,k)) + if (ntlnc>0) then + !> - Convert moist mixing ratio to dry mixing ratio + 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_dryair(i,k), nwfa(i,k)) * (one/rho_dryair(i,k))) + !> - Convert number concentrations from dry to moist + gq0(i,k,ntlnc) = nc_mp(i,k) / (one+qv_mp(i,k)) + endif + if (ntinc>0) then + !> - 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_dryair(i,k), save_tcp(i,k)) * (one/rho_dryair(i,k))) + !> - Convert number concentrations from dry to moist + gq0(i,k,ntinc) = ni_mp(i,k) / (one+qv_mp(i,k)) + endif + enddo + enddo endif else @@ -831,7 +797,7 @@ subroutine GFS_suite_interstitial_4_run (im, levs, ltaerosol, cplchm, tracers_to if (cplchm) then do k=1,levs do i=1,im - dqdti(i,k) = dqdti(i,k) * (1.0 / dtf) + dqdti(i,k) = dqdti(i,k) * (one / dtf) enddo enddo endif diff --git a/physics/GFS_suite_interstitial.meta b/physics/GFS_suite_interstitial.meta index 522d03f31..823874a0d 100644 --- a/physics/GFS_suite_interstitial.meta +++ b/physics/GFS_suite_interstitial.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_suite_interstitial_rad_reset + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## [ccpp-arg-table] name = GFS_suite_interstitial_rad_reset_run type = scheme @@ -35,6 +41,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_phys_reset + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + ######################################################################## [ccpp-arg-table] name = GFS_suite_interstitial_phys_reset_run @@ -73,6 +85,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_1 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + ######################################################################## [ccpp-arg-table] name = GFS_suite_interstitial_1_run @@ -262,6 +280,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_2 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + ######################################################################## [ccpp-arg-table] name = GFS_suite_interstitial_2_run @@ -824,6 +848,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_suite_stateout_reset + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + ######################################################################## [ccpp-arg-table] name = GFS_suite_stateout_reset_run @@ -942,6 +972,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_suite_stateout_update + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + ######################################################################## [ccpp-arg-table] name = GFS_suite_stateout_update_run @@ -1105,6 +1141,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_3 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + ######################################################################## [ccpp-arg-table] name = GFS_suite_interstitial_3_run @@ -1537,6 +1579,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_4 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + ######################################################################## [ccpp-arg-table] name = GFS_suite_interstitial_4_run @@ -1851,6 +1899,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_suite_interstitial_5 + type = scheme + dependencies = machine.F,module_mp_thompson_make_number_concentrations.F90 + ######################################################################## [ccpp-arg-table] name = GFS_suite_interstitial_5_run diff --git a/physics/GFS_surface_composites.F90 b/physics/GFS_surface_composites.F90 index 1e04a9d44..b3000b008 100644 --- a/physics/GFS_surface_composites.F90 +++ b/physics/GFS_surface_composites.F90 @@ -11,7 +11,7 @@ module GFS_surface_composites_pre public GFS_surface_composites_pre_init, GFS_surface_composites_pre_finalize, GFS_surface_composites_pre_run - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0, epsln = 1.0d-10 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, epsln = 1.0e-10_kind_phys contains @@ -25,8 +25,8 @@ end subroutine GFS_surface_composites_pre_finalize !! \htmlinclude GFS_surface_composites_pre_run.html !! subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx, cplwav2atm, & - landfrac, lakefrac, lakedepth, oceanfrac, & - frland, dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorl_wat, & + landfrac, lakefrac, lakedepth, oceanfrac, frland, & + dry, icy, lake, ocean, wet, cice, cimin, zorl, zorlo, zorll, zorli, zorl_wat, & zorl_lnd, zorl_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, uustar, uustar_wat, uustar_lnd, uustar_ice, & weasd, weasd_wat, weasd_lnd, weasd_ice, ep1d_ice, tsfc, tsfco, tsfcl, tsfc_wat,& @@ -40,7 +40,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! Interface variables integer, intent(in ) :: im, lkm logical, intent(in ) :: frac_grid, cplflx, cplwav2atm - logical, dimension(im), intent(in ) :: flag_cice + logical, dimension(im), intent(inout) :: flag_cice logical, dimension(im), intent(inout) :: dry, icy, lake, ocean, wet real(kind=kind_phys), intent(in ) :: cimin real(kind=kind_phys), dimension(im), intent(in ) :: landfrac, lakefrac, lakedepth, oceanfrac @@ -48,14 +48,14 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx real(kind=kind_phys), dimension(im), intent( out) :: frland real(kind=kind_phys), dimension(im), intent(in ) :: zorl, snowd, tprcp, uustar, weasd, qss, hflx - real(kind=kind_phys), dimension(im), intent(inout) :: zorlo, zorll, tsfc, tsfco, tsfcl, tisfc, tsurf + real(kind=kind_phys), dimension(im), intent(inout) :: zorlo, zorll, zorli, tsfc, tsfco, tsfcl, tisfc, tsurf real(kind=kind_phys), dimension(im), intent(inout) :: snowd_wat, snowd_lnd, snowd_ice, tprcp_wat, & tprcp_lnd, tprcp_ice, zorl_wat, zorl_lnd, zorl_ice, tsfc_wat, tsfc_lnd, tsfc_ice, tsurf_wat, & tsurf_lnd, tsurf_ice, uustar_wat, uustar_lnd, uustar_ice, weasd_wat, weasd_lnd, weasd_ice, & qss_wat, qss_lnd, qss_ice, hflx_wat, hflx_lnd, hflx_ice, ep1d_ice, gflx_ice real(kind=kind_phys), dimension(im), intent( out) :: tice real(kind=kind_phys), intent(in ) :: tgice - integer, dimension(im), intent(in ) :: islmsk + integer, dimension(im), intent(inout) :: islmsk real(kind=kind_phys), dimension(im), intent(in ) :: semis_rad real(kind=kind_phys), dimension(im), intent(inout) :: semis_wat, semis_lnd, semis_ice real(kind=kind_phys), intent(in ) :: min_lakeice, min_seaice @@ -79,20 +79,32 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (flag_cice(i)) then if (cice(i) >= min_seaice) then icy(i) = .true. + if (cice(i) < one) wet(i) = .true. ! some open ocean/lake water exists else - cice(i) = zero + cice(i) = zero + flag_cice(i) = .false. +! islmsk_cice(i) = 0 +! islmsk(i) = 0 + wet(i) = .true. ! some open ocean/lake water exists endif else if (cice(i) >= min_lakeice) then icy(i) = .true. + if (cice(i) < one) wet(i) = .true. ! some open ocean/lake water exists + islmsk(i) = 2 else - cice(i) = zero + cice(i) = zero +! islmsk(i) = 0 + wet(i) = .true. ! some open ocean/lake water exists + endif + endif + if (wet(i) .and. .not. cplflx) then + if (oceanfrac(i) > zero) then + tsfco(i) = max(tsfco(i), tisfc(i), tgice) + elseif (icy(i)) then + tsfco(i) = max(tisfc(i), tgice) endif endif - if (cice(i) < one ) then - wet(i)=.true. ! some open ocean/lake water exists - if (.not. cplflx) tsfco(i) = max(tsfco(i), tisfc(i), tgice) - end if else cice(i) = zero endif @@ -101,43 +113,49 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx else do i = 1, IM - frland(i) = zero - if (islmsk(i) == 0) then - ! tsfco(i) = Sfcprop%tsfc(i) - wet(i) = .true. - cice(i) = zero - elseif (islmsk(i) == 1) then - ! Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) + if (islmsk(i) == 1) then +! tsfcl(i) = tsfc(i) dry(i) = .true. frland(i) = one cice(i) = zero - else - icy(i) = .true. + else + frland(i) = zero + if (flag_cice(i)) then + if (cice(i) > min_seaice) then + icy(i) = .true. + else + cice(i) = zero + flag_cice(i) = .false. + islmsk(i) = 0 + endif + else + if (cice(i) > min_lakeice) then + icy(i) = .true. + else + cice(i) = zero + islmsk(i) = 0 + endif + endif if (cice(i) < one) then - wet(i) = .true. - ! tsfco(i) = tgice - if (.not. cplflx) tsfco(i) = max(tisfc(i), tgice) - ! if (.not. cplflx .or. lakefrac(i) > zero) tsfco(i) = max(tsfco(i), tisfc(i), tgice) - ! tsfco(i) = max((tsfc(i) - cice(i)*tisfc(i)) & - ! / (one - cice(i)), tgice) + wet(i) = .true. ! some open ocean/lake water exists + if (.not. cplflx .and. icy(i)) tsfco(i) = max(tisfc(i), tgice) endif endif enddo - endif - if (.not. cplflx .or. .not. frac_grid) then - if (cplwav2atm) then - do i=1,im - zorll(i) = zorl(i) - enddo - else - do i=1,im - zorll(i) = zorl(i) - zorlo(i) = zorl(i) - enddo - endif - endif +! if (.not. cplflx .or. .not. frac_grid) then +! if (cplwav2atm) then +! do i=1,im +! zorll(i) = zorl(i) +! enddo +! else +! do i=1,im +! zorll(i) = zorl(i) +! zorlo(i) = zorl(i) +! enddo +! endif +! endif do i=1,im tprcp_wat(i) = tprcp(i) @@ -170,13 +188,13 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx if (icy(i)) then ! Ice uustar_ice(i) = uustar(i) weasd_ice(i) = weasd(i) - zorl_ice(i) = zorll(i) + zorl_ice(i) = zorli(i) tsfc_ice(i) = tisfc(i) tsurf_ice(i) = tisfc(i) snowd_ice(i) = snowd(i) ep1d_ice(i) = zero gflx_ice(i) = zero - semis_ice(i) = 0.95d0 + semis_ice(i) = 0.95_kind_phys qss_ice(i) = qss(i) hflx_ice(i) = hflx(i) endif @@ -185,7 +203,7 @@ subroutine GFS_surface_composites_pre_run (im, lkm, frac_grid, flag_cice, cplflx ! to prepare to separate lake from ocean under water category do i = 1, im if(lkm == 1) then - if(lakefrac(i) .ge. 0.15 .and. lakedepth(i) .gt. 1.0) then + if(lakefrac(i) >= 0.15 .and. lakedepth(i) > one) then lake(i) = .true. else lake(i) = .false. @@ -291,7 +309,7 @@ module GFS_surface_composites_post public GFS_surface_composites_post_init, GFS_surface_composites_post_finalize, GFS_surface_composites_post_run - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys contains @@ -308,14 +326,14 @@ end subroutine GFS_surface_composites_post_finalize #endif subroutine GFS_surface_composites_post_run ( & im, kice, km, cplflx, cplwav2atm, frac_grid, flag_cice, islmsk, dry, wet, icy, landfrac, lakefrac, oceanfrac, & - zorl, zorlo, zorll, zorl_wat, zorl_lnd, zorl_ice, & + zorl, zorlo, zorll, zorli, zorl_wat, zorl_lnd, zorl_ice, & cd, cd_wat, cd_lnd, cd_ice, cdq, cdq_wat, cdq_lnd, cdq_ice, rb, rb_wat, rb_lnd, rb_ice, stress, stress_wat, stress_lnd, & stress_ice, ffmm, ffmm_wat, ffmm_lnd, ffmm_ice, ffhh, ffhh_wat, ffhh_lnd, ffhh_ice, uustar, uustar_wat, uustar_lnd, & uustar_ice, fm10, fm10_wat, fm10_lnd, fm10_ice, fh2, fh2_wat, fh2_lnd, fh2_ice, tsurf, tsurf_wat, tsurf_lnd, tsurf_ice, & cmm, cmm_wat, cmm_lnd, cmm_ice, chh, chh_wat, chh_lnd, chh_ice, gflx, gflx_wat, gflx_lnd, gflx_ice, ep1d, ep1d_wat, & ep1d_lnd, ep1d_ice, weasd, weasd_wat, weasd_lnd, weasd_ice, snowd, snowd_wat, snowd_lnd, snowd_ice, tprcp, tprcp_wat, & tprcp_lnd, tprcp_ice, evap, evap_wat, evap_lnd, evap_ice, hflx, hflx_wat, hflx_lnd, hflx_ice, qss, qss_wat, qss_lnd, & - qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, tiice, stc, errmsg, errflg) + qss_ice, tsfc, tsfco, tsfcl, tsfc_wat, tsfc_lnd, tsfc_ice, tisfc, tice, hice, cice, min_seaice, tiice, stc, errmsg, errflg) implicit none @@ -331,11 +349,12 @@ subroutine GFS_surface_composites_post_run ( snowd_wat, snowd_lnd, snowd_ice,tprcp_wat, tprcp_lnd, tprcp_ice, evap_wat, evap_lnd, evap_ice, hflx_wat, hflx_lnd, & hflx_ice, qss_wat, qss_lnd, qss_ice, tsfc_wat, tsfc_lnd, tsfc_ice - real(kind=kind_phys), dimension(im), intent(inout) :: zorl, zorlo, zorll, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & + real(kind=kind_phys), dimension(im), intent(inout) :: zorl, zorlo, zorll, zorli, cd, cdq, rb, stress, ffmm, ffhh, uustar, fm10, & fh2, tsurf, cmm, chh, gflx, ep1d, weasd, snowd, tprcp, evap, hflx, qss, tsfc, tsfco, tsfcl, tisfc real(kind=kind_phys), dimension(im), intent(in ) :: tice ! interstitial sea ice temperature real(kind=kind_phys), dimension(im), intent(inout) :: hice, cice + real(kind=kind_phys), intent(in ) :: min_seaice real(kind=kind_phys), dimension(im, kice), intent(in ) :: tiice real(kind=kind_phys), dimension(im, km), intent(inout) :: stc @@ -372,7 +391,7 @@ subroutine GFS_surface_composites_post_run ( uustar(i) = txl*uustar_lnd(i) + txi*uustar_ice(i) + txo*uustar_wat(i) fm10(i) = txl*fm10_lnd(i) + txi*fm10_ice(i) + txo*fm10_wat(i) fh2(i) = txl*fh2_lnd(i) + txi*fh2_ice(i) + txo*fh2_wat(i) - !tsurf(i) = txl*tsurf_lnd(i) + txi*tice(i) + txo*tsurf_wat(i) + !tsurf(i) = txl*tsurf_lnd(i) + txi*tice(i) + txo*tsurf_wat(i) !tsurf(i) = txl*tsurf_lnd(i) + txi*tsurf_ice(i) + txo*tsurf_wat(i) ! not used again! Moorthi cmm(i) = txl*cmm_lnd(i) + txi*cmm_ice(i) + txo*cmm_wat(i) chh(i) = txl*chh_lnd(i) + txi*chh_ice(i) + txo*chh_wat(i) @@ -399,10 +418,30 @@ subroutine GFS_surface_composites_post_run ( tsfc(i) = txl*tsfc_lnd(i) + txi*tice(i) + txo*tsfc_wat(i) zorll(i) = zorl_lnd(i) + zorli(i) = zorl_ice(i) zorlo(i) = zorl_wat(i) - if (dry(i)) tsfcl(i) = tsfc_lnd(i) ! over land - if (wet(i)) tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled + if (dry(i)) then + tsfcl(i) = tsfc_lnd(i) ! over land + elseif (wet(i)) then + tsfcl(i) = tsfc_wat(i) ! over water + else + tsfcl(i) = tice(i) ! over ice + endif + if (wet(i)) then + tsfco(i) = tsfc_wat(i) ! over lake or ocean when uncoupled + elseif (icy(i)) then + tsfco(i) = tice(i) ! over lake or ocean ice when uncoupled + else + tsfco(i) = tsfc_lnd(i) ! over land + endif + if (icy(i)) then + tisfc(i) = tice(i) ! over lake or ocean ice when uncoupled + elseif (wet(i)) then + tisfc(i) = tsfc_wat(i) ! over lake or ocean when uncoupled + else + tisfc(i) = tsfc_lnd(i) ! over land + endif ! for coupled model ocean will replace this ! if (icy(i)) tisfc(i) = tsfc_ice(i) ! over ice when uncoupled ! if (icy(i)) tisfc(i) = tice(i) ! over ice when uncoupled @@ -413,9 +452,9 @@ subroutine GFS_surface_composites_post_run ( ! endif if (.not. flag_cice(i)) then - if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array + if (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array tisfc(i) = tice(i) - else ! this would be over open ocean or land (no ice fraction) + else ! this would be over open ocean or land (no ice fraction) hice(i) = zero cice(i) = zero tisfc(i) = tsfc(i) @@ -450,9 +489,10 @@ subroutine GFS_surface_composites_post_run ( hflx(i) = hflx_lnd(i) qss(i) = qss_lnd(i) tsfc(i) = tsfc_lnd(i) - !hice(i) = zero - !cice(i) = zero - !tisfc(i) = tsfc(i) + hice(i) = zero + cice(i) = zero + tisfc(i) = tsfc(i) + tsfco(i) = tsfc(i) elseif (islmsk(i) == 0) then zorl(i) = zorl_wat(i) cd(i) = cd_wat(i) @@ -466,7 +506,7 @@ subroutine GFS_surface_composites_post_run ( fh2(i) = fh2_wat(i) !tsurf(i) = tsurf_wat(i) tsfco(i) = tsfc_wat(i) ! over lake (and ocean when uncoupled) - if( cplflx ) tsfcl(i) = tsfc_wat(i) ! for restart repro comparisons + tsfcl(i) = tsfc(i) cmm(i) = cmm_wat(i) chh(i) = chh_wat(i) gflx(i) = gflx_wat(i) @@ -478,24 +518,21 @@ subroutine GFS_surface_composites_post_run ( hflx(i) = hflx_wat(i) qss(i) = qss_wat(i) tsfc(i) = tsfc_wat(i) - !hice(i) = zero - !cice(i) = zero - !tisfc(i) = tsfc(i) + hice(i) = zero + cice(i) = zero + tisfc(i) = tsfc(i) else ! islmsk(i) == 2 zorl(i) = zorl_ice(i) cd(i) = cd_ice(i) cdq(i) = cdq_ice(i) rb(i) = rb_ice(i) - stress(i) = cice(i)*stress_ice(i) + (one-cice(i))*stress_wat(i) ffmm(i) = ffmm_ice(i) ffhh(i) = ffhh_ice(i) uustar(i) = uustar_ice(i) fm10(i) = fm10_ice(i) fh2(i) = fh2_ice(i) + stress(i) = stress_ice(i) !tsurf(i) = tsurf_ice(i) - if (.not. flag_cice(i)) then - tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - endif cmm(i) = cmm_ice(i) chh(i) = chh_ice(i) gflx(i) = gflx_ice(i) @@ -507,31 +544,44 @@ subroutine GFS_surface_composites_post_run ( evap(i) = evap_ice(i) hflx(i) = hflx_ice(i) qss(i) = qss_ice(i) - tsfc(i) = tsfc_ice(i) + if (.not. flag_cice(i)) then + tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + zorl(i) = cice(i) * zorl_ice(i) + (one - cice(i)) * zorl_wat(i) + elseif (wet(i)) then + if (cice(i) > min_seaice) then ! this was already done for lake ice in sfc_sice + txi = cice(i) + txo = one - txi + evap(i) = txi * evap_ice(i) + txo * evap_wat(i) + hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) + tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_wat(i) + stress(i) = txi * stress_ice(i) + txo * stress_wat(i) + qss(i) = txi * qss_ice(i) + txo * qss_wat(i) + ep1d(i) = txi * ep1d_ice(i) + txo * ep1d_wat(i) + zorl(i) = txi * zorl_ice(i) + txo * zorl_wat(i) + else + evap(i) = evap_wat(i) + hflx(i) = hflx_wat(i) + tsfc(i) = tsfc_wat(i) + stress(i) = stress_wat(i) + qss(i) = qss_wat(i) + ep1d(i) = ep1d_wat(i) + zorl(i) = zorl_wat(i) + endif + endif + if (wet(i)) then + tsfco(i) = tsfc_wat(i) + else + tsfco(i) = tsfc(i) + endif + tsfcl(i) = tsfc(i) do k=1,kice ! store tiice in stc to reduce output in the nonfrac grid case stc(i,k)=tiice(i,k) end do - if( cplflx ) tsfcl(i) = tsfc_ice(i) endif zorll(i) = zorl_lnd(i) zorlo(i) = zorl_wat(i) - - if (flag_cice(i) .and. wet(i)) then ! this was already done for lake ice in sfc_sice - txi = cice(i) - txo = one - txi - evap(i) = txi * evap_ice(i) + txo * evap_wat(i) - hflx(i) = txi * hflx_ice(i) + txo * hflx_wat(i) - tsfc(i) = txi * tsfc_ice(i) + txo * tsfc_wat(i) - else - if (islmsk(i) == 2) then - tisfc(i) = tice(i) - else ! over open ocean or land (no ice fraction) - hice(i) = zero - cice(i) = zero - tisfc(i) = tsfc(i) - endif - endif + zorli(i) = zorl_ice(i) enddo diff --git a/physics/GFS_surface_composites.meta b/physics/GFS_surface_composites.meta index 9b297ca38..e3c46d20e 100644 --- a/physics/GFS_surface_composites.meta +++ b/physics/GFS_surface_composites.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_surface_composites_pre + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = GFS_surface_composites_pre_run type = scheme @@ -179,6 +185,15 @@ kind = kind_phys intent = inout optional = F +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [zorl_wat] standard_name = surface_roughness_length_over_ocean_interstitial long_name = surface roughness length over ocean (temporary use as interstitial) @@ -604,7 +619,7 @@ [min_lakeice] standard_name = lake_ice_minimum long_name = minimum lake ice value - units = ??? + units = frac dimensions = () type = real kind = kind_phys @@ -613,7 +628,7 @@ [min_seaice] standard_name = sea_ice_minimum long_name = minimum sea ice value - units = ??? + units = frac dimensions = () type = real kind = kind_phys @@ -637,6 +652,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_surface_composites_inter + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_surface_composites_inter_run @@ -781,6 +802,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_surface_composites_post + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_surface_composites_post_run @@ -927,6 +954,15 @@ kind = kind_phys intent = inout optional = F +[zorli] + standard_name = surface_roughness_length_over_ice + long_name = surface roughness length over ice + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [zorl_wat] standard_name = surface_roughness_length_over_ocean_interstitial long_name = surface roughness length over ocean (temporary use as interstitial) @@ -1764,6 +1800,14 @@ kind = kind_phys intent = inout optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in [tiice] standard_name = internal_ice_temperature long_name = sea ice internal temperature diff --git a/physics/GFS_surface_generic.F90 b/physics/GFS_surface_generic.F90 index d7debf1cc..b6d4dfb02 100644 --- a/physics/GFS_surface_generic.F90 +++ b/physics/GFS_surface_generic.F90 @@ -11,8 +11,7 @@ module GFS_surface_generic_pre public GFS_surface_generic_pre_init, GFS_surface_generic_pre_finalize, GFS_surface_generic_pre_run - real(kind=kind_phys), parameter :: one = 1.0d0 - real(kind=kind_phys), parameter :: zero = 0.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys contains @@ -28,8 +27,9 @@ end subroutine GFS_surface_generic_pre_finalize subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, stype, vtype, slope, & prsik_1, prslk_1, tsfc, phil, con_g, & sigmaf, soiltyp, vegtype, slopetyp, work3, tsurf, zlvl, do_sppt, ca_global,dtdtr,& - drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, do_sfcperts, nsfcpert, sfc_wts, & - pertz0, pertzt, pertshc, pertlai, pertvegf, z01d, zt1d, bexp1d, xlai1d, vegf1d, & + drain_cpl, dsnow_cpl, rain_cpl, snow_cpl, lndp_type, n_var_lndp, sfc_wts, & + lndp_var_list, lndp_prt_list, & + z01d, zt1d, bexp1d, xlai1d, vegf1d, lndp_vgf, & cplflx, flag_cice, islmsk_cice, slimskin_cpl, tisfc, tsfco, fice, hice, & wind, u1, v1, cnvwind, smcwlt2, smcref2, errmsg, errflg) @@ -57,19 +57,17 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, real(kind=kind_phys), dimension(im), intent(out) :: dsnow_cpl real(kind=kind_phys), dimension(im), intent(in) :: rain_cpl real(kind=kind_phys), dimension(im), intent(in) :: snow_cpl - logical, intent(in) :: do_sfcperts - integer, intent(in) :: nsfcpert - real(kind=kind_phys), dimension(im,nsfcpert), intent(in) :: sfc_wts - real(kind=kind_phys), dimension(:), intent(in) :: pertz0 - real(kind=kind_phys), dimension(:), intent(in) :: pertzt - real(kind=kind_phys), dimension(:), intent(in) :: pertshc - real(kind=kind_phys), dimension(:), intent(in) :: pertlai - real(kind=kind_phys), dimension(:), intent(in) :: pertvegf + integer, intent(in) :: lndp_type + integer, intent(in) :: n_var_lndp + character(len=3), dimension(n_var_lndp), intent(in) :: lndp_var_list + real(kind=kind_phys), dimension(n_var_lndp), intent(in) :: lndp_prt_list + real(kind=kind_phys), dimension(im,n_var_lndp), intent(in) :: sfc_wts real(kind=kind_phys), dimension(im), intent(out) :: z01d real(kind=kind_phys), dimension(im), intent(out) :: zt1d real(kind=kind_phys), dimension(im), intent(out) :: bexp1d real(kind=kind_phys), dimension(im), intent(out) :: xlai1d real(kind=kind_phys), dimension(im), intent(out) :: vegf1d + real(kind=kind_phys), intent(out) :: lndp_vgf logical, intent(in) :: cplflx real(kind=kind_phys), dimension(im), intent(in) :: slimskin_cpl @@ -90,7 +88,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, integer, intent(out) :: errflg ! Local variables - integer :: i + integer :: i, k real(kind=kind_phys) :: onebg real(kind=kind_phys) :: cdfz @@ -108,40 +106,35 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, ! Scale random patterns for surface perturbations with perturbation size ! Turn vegetation fraction pattern into percentile pattern - if (do_sfcperts) then - if (pertz0(1) > 0.) then - z01d(:) = pertz0(1) * sfc_wts(:,1) -! if (me == 0) print*,'sfc_wts(:,1) min and max',minval(sfc_wts(:,1)),maxval(sfc_wts(:,1)) -! if (me == 0) print*,'z01d min and max ',minval(z01d),maxval(z01d) - endif - if (pertzt(1) > 0.) then - zt1d(:) = pertzt(1) * sfc_wts(:,2) - endif - if (pertshc(1) > 0.) then - bexp1d(:) = pertshc(1) * sfc_wts(:,3) - endif - if (pertlai(1) > 0.) then - xlai1d(:) = pertlai(1) * sfc_wts(:,4) - endif -! --- do the albedo percentile calculation in GFS_radiation_driver instead --- ! -! if (pertalb(1) > 0.) then -! do i=1,im -! call cdfnor(sfc_wts(i,5),cdfz) -! alb1d(i) = cdfz -! enddo -! endif - if (pertvegf(1) > 0.) then - do i=1,im - call cdfnor(sfc_wts(i,6),cdfz) - vegf1d(i) = cdfz - enddo - endif + lndp_vgf=-999. + + if (lndp_type==1) then + do k =1,n_var_lndp + select case(lndp_var_list(k)) + case ('rz0') + z01d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('rzt') + zt1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('shc') + bexp1d(:) = lndp_prt_list(k) * sfc_wts(:,k) + case ('lai') + xlai1d(:) = lndp_prt_list(k)* sfc_wts(:,k) + case ('vgf') + ! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff + do i=1,im + call cdfnor(sfc_wts(i,k),cdfz) + vegf1d(i) = cdfz + enddo + lndp_vgf = lndp_prt_list(k) + end select + enddo endif ! End of stochastic physics / surface perturbation do i=1,im - sigmaf(i) = max(vfrac(i),0.01 ) + sigmaf(i) = max(vfrac(i), 0.01_kind_phys) + islmsk_cice(i) = islmsk(i) if (islmsk(i) == 2) then if (isot == 1) then soiltyp(i) = 16 @@ -155,9 +148,9 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, endif slopetyp(i) = 9 else - soiltyp(i) = int( stype(i)+0.5 ) - vegtype(i) = int( vtype(i)+0.5 ) - slopetyp(i) = int( slope(i)+0.5 ) !! clu: slope -> slopetyp + soiltyp(i) = int( stype(i)+0.5_kind_phys ) + vegtype(i) = int( vtype(i)+0.5_kind_phys ) + slopetyp(i) = int( slope(i)+0.5_kind_phys ) !! clu: slope -> slopetyp if (soiltyp(i) < 1) soiltyp(i) = 14 if (vegtype(i) < 1) vegtype(i) = 17 if (slopetyp(i) < 1) slopetyp(i) = 1 @@ -171,7 +164,7 @@ subroutine GFS_surface_generic_pre_run (im, levs, vfrac, islmsk, isot, ivegsrc, smcref2(i) = zero wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & - + max(zero, min(cnvwind(i), 30.0)), one) + + max(zero, min(cnvwind(i), 30.0_kind_phys)), one) !wind(i) = max(sqrt(Statein%ugrs(i,1)*Statein%ugrs(i,1) + & ! Statein%vgrs(i,1)*Statein%vgrs(i,1)) & ! + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), one) @@ -201,7 +194,7 @@ module GFS_surface_generic_post public GFS_surface_generic_post_init, GFS_surface_generic_post_finalize, GFS_surface_generic_post_run - real(kind=kind_phys), parameter :: zero = 0.0, one = 1.0d0 + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys contains @@ -256,8 +249,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt integer, intent(out) :: errflg ! Local variables - - real(kind=kind_phys), parameter :: albdf = 0.06d0 + real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys ! Parameters for canopy heat storage parametrization real(kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 @@ -320,12 +312,12 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt ! if (Sfcprop%landfrac(i) < one) then ! Not 100% land if (wet(i)) then ! some open water ! --- compute open water albedo - xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) - ocalnirdf_cpl = 0.06 - ocalnirbm_cpl = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & - & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & - & * (xcosz_loc-1.0)) - ocalvisdf_cpl = 0.06 + xcosz_loc = max( zero, min( one, xcosz(i) )) + ocalnirdf_cpl = 0.06_kind_phys + ocalnirbm_cpl = max(albdf, 0.026_kind_phys/(xcosz_loc**1.7_kind_phys+0.065_kind_phys) & + & + 0.15_kind_phys * (xcosz_loc-0.1_kind_phys) * (xcosz_loc-0.5_kind_phys) & + & * (xcosz_loc-one)) + ocalvisdf_cpl = 0.06_kind_phys ocalvisbm_cpl = ocalnirbm_cpl nnirbmi_cpl(i) = adjnirbmd(i) * (one-ocalnirbm_cpl) @@ -339,7 +331,7 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) endif nswsfci_cpl(i) = nnirbmi_cpl(i) + nnirdfi_cpl(i) & - + nvisbmi_cpl(i) + nvisdfi_cpl(i) + + nvisbmi_cpl(i) + nvisdfi_cpl(i) nswsfc_cpl(i) = nswsfc_cpl(i) + nswsfci_cpl(i)*dtf nnirbm_cpl(i) = nnirbm_cpl(i) + nnirbmi_cpl(i)*dtf nnirdf_cpl(i) = nnirdf_cpl(i) + nnirdfi_cpl(i)*dtf @@ -358,13 +350,9 @@ subroutine GFS_surface_generic_post_run (im, cplflx, cplwav, lssav, icy, wet, dt snowca(i) = snowca(i) + snowc(i) * dtf snohfa(i) = snohfa(i) + snohf(i) * dtf ep(i) = ep(i) + ep1d(i) * dtf - enddo - endif ! --- ... total runoff is composed of drainage into water table and ! runoff at the surface and is accumulated in unit of meters - if (lssav) then - do i=1,im runoff(i) = runoff(i) + (drain(i)+runof(i)) * dtf srunoff(i) = srunoff(i) + runof(i) * dtf enddo diff --git a/physics/GFS_surface_generic.meta b/physics/GFS_surface_generic.meta index d37f7ec64..f5c73db13 100644 --- a/physics/GFS_surface_generic.meta +++ b/physics/GFS_surface_generic.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_surface_generic_pre + type = scheme + dependencies = machine.F,surface_perturbation.F90 + +######################################################################## [ccpp-arg-table] name = GFS_surface_generic_pre_run type = scheme @@ -183,8 +189,8 @@ intent = inout optional = F [do_sppt] - standard_name = flag_for_stochastic_surface_physics_perturbations - long_name = flag for stochastic surface physics perturbations + standard_name = flag_for_stochastic_physics_perturbations + long_name = flag for stochastic physics perturbations units = flag dimensions = () type = logical @@ -243,17 +249,17 @@ kind = kind_phys intent = in optional = F -[do_sfcperts] - standard_name = flag_for_stochastic_surface_perturbations - long_name = flag for stochastic surface perturbations option - units = flag +[lndp_type] + standard_name = index_for_stochastic_land_surface_perturbation_type + long_name = index for stochastic land surface perturbations type + units = index dimensions = () - type = logical + type = integer intent = in optional = F -[nsfcpert] - standard_name = number_of_surface_perturbations - long_name = number of surface perturbations +[n_var_lndp] + standard_name = number_of_land_surface_variables_perturbed + long_name = number of land surface variables perturbed units = count dimensions = () type = integer @@ -263,55 +269,28 @@ standard_name = weights_for_stochastic_surface_physics_perturbation long_name = weights for stochastic surface physics perturbation units = none - dimensions = (horizontal_dimension,number_of_surface_perturbations) - type = real - kind = kind_phys - intent = in - optional = F -[pertz0] - standard_name = magnitude_of_perturbation_of_momentum_roughness_length - long_name = magnitude of perturbation of momentum roughness length - units = frac - dimensions = (5) - type = real - kind = kind_phys - intent = in - optional = F -[pertzt] - standard_name = magnitude_of_perturbation_of_heat_to_momentum_roughness_length_ratio - long_name = magnitude of perturbation of heat to momentum roughness length r. - units = frac - dimensions = (5) - type = real - kind = kind_phys - intent = in - optional = F -[pertshc] - standard_name = magnitude_of_perturbation_of_soil_type_b_parameter - long_name = magnitude of perturbation of soil type b parameter - units = frac - dimensions = (5) + dimensions = (horizontal_dimension,number_of_land_surface_variables_perturbed) type = real kind = kind_phys intent = in optional = F -[pertlai] - standard_name = magnitude_of_perturbation_of_leaf_area_index - long_name = magnitude of perturbation of leaf area index - units = frac - dimensions = (5) +[lndp_prt_list] + standard_name =magnitude_of_perturbations_for_landperts + long_name = magnitude of perturbations for landperts + units = variable + dimensions = (number_of_land_surface_variables_perturbed) type = real kind = kind_phys - intent = in + intent = in optional = F -[pertvegf] - standard_name = magnitude_of_perturbation_of_vegetation_fraction - long_name = magnitude of perturbation of vegetation fraction - units = frac - dimensions = (5) - type = real - kind = kind_phys - intent = in +[lndp_var_list] + standard_name = variables_to_be_perturbed_for_landperts + long_name = variables to be perturbed for landperts + units = none + dimensions = (number_of_land_surface_variables_perturbed) + type = character + kind = len=3 + intent = in optional = F [z01d] standard_name = perturbation_of_momentum_roughness_length @@ -358,6 +337,15 @@ kind = kind_phys intent = out optional = F +[lndp_vgf] + standard_name = magnitude_of_perturbation_of_vegetation_fraction + long_name = magnitude of perturbation of vegetation fraction + units = frac + dimensions = () + type = real + kind = kind_phys + intent = out + optional = F [cplflx] standard_name = flag_for_flux_coupling long_name = flag controlling cplflx collection (default off) @@ -499,6 +487,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_surface_generic_post + type = scheme + dependencies = machine.F,surface_perturbation.F90 + ######################################################################## [ccpp-arg-table] name = GFS_surface_generic_post_run diff --git a/physics/GFS_surface_loop_control.F90 b/physics/GFS_surface_loop_control.F90 index c701c523e..c7f727d27 100644 --- a/physics/GFS_surface_loop_control.F90 +++ b/physics/GFS_surface_loop_control.F90 @@ -47,7 +47,7 @@ subroutine GFS_surface_loop_control_part1_run (im, iter, wind, flag_guess, errms errflg = 0 do i=1,im - if (iter == 1 .and. wind(i) < 2.0) then + if (iter == 1 .and. wind(i) < 2.0d0) then flag_guess(i) = .true. endif enddo @@ -110,7 +110,7 @@ subroutine GFS_surface_loop_control_part2_run (im, iter, wind, & flag_iter(i) = .false. flag_guess(i) = .false. - if (iter == 1 .and. wind(i) < 2.0) then + if (iter == 1 .and. wind(i) < 2.0d0) then !if (dry(i) .or. (wet(i) .and. .not.icy(i) .and. nstf_name1 > 0)) then if (dry(i) .or. (wet(i) .and. nstf_name1 > 0)) then flag_iter(i) = .true. diff --git a/physics/GFS_surface_loop_control.meta b/physics/GFS_surface_loop_control.meta index 3fe5878f7..a4d62cd29 100644 --- a/physics/GFS_surface_loop_control.meta +++ b/physics/GFS_surface_loop_control.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_surface_loop_control_part1 + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = GFS_surface_loop_control_part1_run type = scheme @@ -52,6 +58,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = GFS_surface_loop_control_part2 + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = GFS_surface_loop_control_part2_run diff --git a/physics/GFS_time_vary_pre.fv3.F90 b/physics/GFS_time_vary_pre.fv3.F90 index 5f72a6b27..dc9332bb9 100644 --- a/physics/GFS_time_vary_pre.fv3.F90 +++ b/physics/GFS_time_vary_pre.fv3.F90 @@ -172,7 +172,7 @@ subroutine GFS_time_vary_pre_run (jdat, idat, dtp, lkm, lsm, lsm_noahmp, nsswr, if (nslwr == 1) lslwr = .true. !--- allow for radiation to be called on every physics time step ! for the first nhfrad timesteps (for spinup, coldstarts only) - if (kdt<=nhfrad) then + if (kdt <= nhfrad) then lsswr = .true. lslwr = .true. end if diff --git a/physics/GFS_time_vary_pre.fv3.meta b/physics/GFS_time_vary_pre.fv3.meta index 04f7f1529..f1a088245 100644 --- a/physics/GFS_time_vary_pre.fv3.meta +++ b/physics/GFS_time_vary_pre.fv3.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_time_vary_pre + type = scheme + dependencies = funcphys.f90,machine.F + +######################################################################## [ccpp-arg-table] name = GFS_time_vary_pre_init type = scheme diff --git a/physics/GFS_time_vary_pre.scm.meta b/physics/GFS_time_vary_pre.scm.meta index 3dc91952e..189a5b05b 100644 --- a/physics/GFS_time_vary_pre.scm.meta +++ b/physics/GFS_time_vary_pre.scm.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = GFS_time_vary_pre + type = scheme + dependencies = funcphys.f90,machine.F + +######################################################################## [ccpp-arg-table] name = GFS_time_vary_pre_init type = scheme diff --git a/physics/cires_ugwp.F90 b/physics/cires_ugwp.F90 index df0116cd0..f24ae39ae 100644 --- a/physics/cires_ugwp.F90 +++ b/physics/cires_ugwp.F90 @@ -261,7 +261,7 @@ subroutine cires_ugwp_run(do_ugwp, me, master, im, levs, ntrac, dtp, kdt, lonr if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then call gwdps_run(im, levs, Pdvdt, Pdudt, Pdtdt, & - ugrs, vgrs, tgrs, qgrs, & + ugrs, vgrs, tgrs, qgrs(:,:,1), & kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt, & hprime, oc, oa4, clx, theta, sigma, gamma, & elvmax, dusfcg, dvsfcg, & diff --git a/physics/cires_ugwp.meta b/physics/cires_ugwp.meta index d323324d2..ca1e573ba 100644 --- a/physics/cires_ugwp.meta +++ b/physics/cires_ugwp.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = cires_ugwp + type = scheme +# DH* 20200804 - this is a result of the nasty hack to call gwdps from within ugwp! + dependencies = cires_ugwp_triggers.F90,cires_ugwp_initialize.F90,cires_ugwp_solvers.F90,cires_ugwp_utils.F90,cires_orowam2017.f,cires_vert_lsatdis.F90,cires_vert_orodis.F90,cires_vert_wmsdis.F90,cires_ugwp_module.F90,gwdps.f,machine.F,ugwp_driver_v0.F + +######################################################################## [ccpp-arg-table] name = cires_ugwp_init type = scheme diff --git a/physics/cires_ugwp_post.F90 b/physics/cires_ugwp_post.F90 old mode 100755 new mode 100644 diff --git a/physics/cires_ugwp_post.meta b/physics/cires_ugwp_post.meta index 1f98aa8a4..ccb7cf50f 100644 --- a/physics/cires_ugwp_post.meta +++ b/physics/cires_ugwp_post.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = cires_ugwp_post_init +[ccpp-table-properties] + name = cires_ugwp_post type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -309,7 +310,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = cires_ugwp_post_finalize - type = scheme diff --git a/physics/cnvc90.meta b/physics/cnvc90.meta index 0cf7c22a4..ab487ff22 100644 --- a/physics/cnvc90.meta +++ b/physics/cnvc90.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = cnvc90_init +[ccpp-table-properties] + name = cnvc90 type = scheme + dependencies = ######################################################################## [ccpp-arg-table] @@ -137,7 +138,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = cnvc90_finalize - type = scheme diff --git a/physics/cs_conv.meta b/physics/cs_conv.meta index b19a42a5b..42201b155 100644 --- a/physics/cs_conv.meta +++ b/physics/cs_conv.meta @@ -1,11 +1,7 @@ -[ccpp-arg-table] - name = cs_conv_pre_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = cs_conv_pre_finalize +[ccpp-table-properties] + name = cs_conv_pre type = scheme + dependencies = funcphys.f90,machine.F,physcons.F90 ######################################################################## [ccpp-arg-table] @@ -179,14 +175,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = cs_conv_post_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = cs_conv_post_finalize +[ccpp-table-properties] + name = cs_conv_post type = scheme + dependencies = funcphys.f90,machine.F,physcons.F90 ######################################################################## [ccpp-arg-table] @@ -253,14 +245,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = cs_conv_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = cs_conv_finalize +[ccpp-table-properties] + name = cs_conv type = scheme + dependencies = funcphys.f90,machine.F,physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/cs_conv_aw_adj.meta b/physics/cs_conv_aw_adj.meta index fbbe3770c..626fd6d4b 100644 --- a/physics/cs_conv_aw_adj.meta +++ b/physics/cs_conv_aw_adj.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = cs_conv_aw_adj + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = cs_conv_aw_adj_run type = scheme diff --git a/physics/cu_gf_driver.F90 b/physics/cu_gf_driver.F90 index aa3ca977e..30ad8e6ab 100644 --- a/physics/cu_gf_driver.F90 +++ b/physics/cu_gf_driver.F90 @@ -868,11 +868,13 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & if(ishallow_g3.eq.1 .and. .not.flag_for_scnv_generic_tend) then do k=kts,ktf do i=its,itf - du3dt_SCNV(i,k) = du3dt_SCNV(i,k) + outus(i,k) * dt - dv3dt_SCNV(i,k) = dv3dt_SCNV(i,k) + outvs(i,k) * dt - dt3dt_SCNV(i,k) = dt3dt_SCNV(i,k) + outts(i,k) * dt + du3dt_SCNV(i,k) = du3dt_SCNV(i,k) + cutens(i)*outus(i,k) * dt + dv3dt_SCNV(i,k) = dv3dt_SCNV(i,k) + cutens(i)*outvs(i,k) * dt + dt3dt_SCNV(i,k) = dt3dt_SCNV(i,k) + cutens(i)*outts(i,k) * dt if(qdiag3d) then - dq3dt_SCNV(i,k) = dq3dt_SCNV(i,k) + outqs(i,k) * dt + tem = cutens(i)*outqs(i,k)* dt + tem = tem/(1.0_kind_phys+tem) + dq3dt_SCNV(i,k) = dq3dt_SCNV(i,k) + tem endif enddo enddo @@ -880,11 +882,13 @@ subroutine cu_gf_driver_run(ntracer,garea,im,km,dt,cactiv, & if((ideep.eq.1. .or. imid_gf.eq.1) .and. .not.flag_for_dcnv_generic_tend) then do k=kts,ktf do i=its,itf - du3dt_DCNV(i,k) = du3dt_DCNV(i,k) + (outu(i,k)+outum(i,k)) * dt - dv3dt_DCNV(i,k) = dv3dt_DCNV(i,k) + (outv(i,k)+outvm(i,k)) * dt - dt3dt_DCNV(i,k) = dt3dt_DCNV(i,k) + (outt(i,k)+outtm(i,k)) * dt + du3dt_DCNV(i,k) = du3dt_DCNV(i,k) + (cuten(i)*outu(i,k)+cutenm(i)*outum(i,k)) * dt + dv3dt_DCNV(i,k) = dv3dt_DCNV(i,k) + (cuten(i)*outv(i,k)+cutenm(i)*outvm(i,k)) * dt + dt3dt_DCNV(i,k) = dt3dt_DCNV(i,k) + (cuten(i)*outt(i,k)+cutenm(i)*outtm(i,k)) * dt if(qdiag3d) then - dq3dt_DCNV(i,k) = dq3dt_DCNV(i,k) + (outq(i,k)+outqm(i,k)) * dt + tem = (cuten(i)*outq(i,k) + cutenm(i)*outqm(i,k))* dt + tem = tem/(1.0_kind_phys+tem) + dq3dt_DCNV(i,k) = dq3dt_DCNV(i,k) + tem endif enddo enddo diff --git a/physics/cu_gf_driver.meta b/physics/cu_gf_driver.meta index d684ce331..7c86d7952 100644 --- a/physics/cu_gf_driver.meta +++ b/physics/cu_gf_driver.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = cu_gf_driver + type = scheme + dependencies = cu_gf_deep.F90,cu_gf_sh.F90,machine.F,physcons.F90 + +######################################################################## [ccpp-arg-table] name = cu_gf_driver_init type = scheme @@ -35,11 +41,6 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = cu_gf_driver_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = cu_gf_driver_run diff --git a/physics/cu_gf_driver_post.meta b/physics/cu_gf_driver_post.meta index 9a28bc719..43bc02545 100644 --- a/physics/cu_gf_driver_post.meta +++ b/physics/cu_gf_driver_post.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = cu_gf_driver_post + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = cu_gf_driver_post_run type = scheme diff --git a/physics/cu_gf_driver_pre.meta b/physics/cu_gf_driver_pre.meta index 353bbe889..bfdebee59 100644 --- a/physics/cu_gf_driver_pre.meta +++ b/physics/cu_gf_driver_pre.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = cu_gf_driver_pre + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = cu_gf_driver_pre_run type = scheme diff --git a/physics/cu_ntiedtke.meta b/physics/cu_ntiedtke.meta index 0e6a3d4b0..8bc067735 100644 --- a/physics/cu_ntiedtke.meta +++ b/physics/cu_ntiedtke.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = cu_ntiedtke + type = scheme + dependencies = machine.F,physcons.F90 + +######################################################################## [ccpp-arg-table] name = cu_ntiedtke_init type = scheme @@ -35,11 +41,6 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = cu_ntiedtke_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = cu_ntiedtke_run diff --git a/physics/cu_ntiedtke_post.meta b/physics/cu_ntiedtke_post.meta index a4fea92b3..dfaee692d 100644 --- a/physics/cu_ntiedtke_post.meta +++ b/physics/cu_ntiedtke_post.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = cu_ntiedtke_post + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = cu_ntiedtke_post_run type = scheme diff --git a/physics/cu_ntiedtke_pre.meta b/physics/cu_ntiedtke_pre.meta index 8fd2448a9..411bb8fab 100644 --- a/physics/cu_ntiedtke_pre.meta +++ b/physics/cu_ntiedtke_pre.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = cu_ntiedtke_pre + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = cu_ntiedtke_pre_run type = scheme diff --git a/physics/dcyc2.f b/physics/dcyc2.f index f5967f7a2..6dca65cf5 100644 --- a/physics/dcyc2.f +++ b/physics/dcyc2.f @@ -286,10 +286,10 @@ subroutine dcyc2t3_run & istsun(i) = zero enddo do it=1,nstl - cns = solang + (float(it)-0.5)*anginc + slag + cns = solang + (float(it)-0.5_kind_phys)*anginc + slag do i = 1, IM coszn = sdec*sinlat(i) + cdec*coslat(i)*cos(cns+xlon(i)) - xcosz(i) = xcosz(i) + max(0.0, coszn) + xcosz(i) = xcosz(i) + max(zero, coszn) if (coszn > czlimt) istsun(i) = istsun(i) + 1 enddo enddo @@ -334,7 +334,7 @@ subroutine dcyc2t3_run & if ( xcosz(i) > f_eps .and. coszen(i) > f_eps ) then xmu(i) = xcosz(i) / coszen(i) else - xmu(i) = 0.0 + xmu(i) = zero endif !> - adjust \a sfc net and downward SW fluxes for zenith angle changes. diff --git a/physics/dcyc2.meta b/physics/dcyc2.meta index e946e3c90..ce406e824 100644 --- a/physics/dcyc2.meta +++ b/physics/dcyc2.meta @@ -1,11 +1,7 @@ -[ccpp-arg-table] - name = dcyc2t3_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = dcyc2t3_finalize +[ccpp-table-properties] + name = dcyc2t3 type = scheme + dependencies = machine.F,physcons.F90 ######################################################################## [ccpp-arg-table] diff --git a/physics/drag_suite.meta b/physics/drag_suite.meta index dfcac8582..ba15719c1 100644 --- a/physics/drag_suite.meta +++ b/physics/drag_suite.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = drag_suite_init +[ccpp-table-properties] + name = drag_suite type = scheme + dependencies = ######################################################################## [ccpp-arg-table] @@ -608,7 +609,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = drag_suite_finalize - type = scheme diff --git a/physics/flake_driver.meta b/physics/flake_driver.meta index a40016010..128977e05 100644 --- a/physics/flake_driver.meta +++ b/physics/flake_driver.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = flake_driver + type = scheme + dependencies = flake.F90,machine.F + +######################################################################## [ccpp-arg-table] name = flake_driver_init type = scheme diff --git a/physics/gcm_shoc.F90 b/physics/gcm_shoc.F90 index f9f2d4c0a..dd7791e18 100644 --- a/physics/gcm_shoc.F90 +++ b/physics/gcm_shoc.F90 @@ -10,6 +10,7 @@ module shoc private public shoc_run, shoc_init, shoc_finalize + integer, parameter :: kp = kind_phys contains @@ -44,7 +45,7 @@ subroutine shoc_run (nx, nzm, tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, con_ character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg - real(kind=kind_phys), parameter :: epsq = 1.d-20 + real(kind=kind_phys), parameter :: epsq = 1.0e-20_kp, zero=0.0_kp, one=1.0_kp integer :: i, k @@ -67,15 +68,15 @@ subroutine shoc_run (nx, nzm, tcr, tcrf, con_cp, con_g, con_hvap, con_hfus, con_ do i=1,nx qc(i,k) = gq0(i,k,ntcw) if (abs(qc(i,k)) < epsq) then - qc(i,k) = 0.0 + qc(i,k) = zero endif - tem = qc(i,k) * max(0.0, MIN(1.0, (tcr-gt0(i,k))*tcrf)) + tem = qc(i,k) * max(zero, MIN(one, (tcr-gt0(i,k))*tcrf)) qi(i,k) = tem ! ice qc(i,k) = qc(i,k) - tem ! water - qrn(i,k) = 0.0 - qsnw(i,k) = 0.0 - ncpl(i,k) = 0 - ncpi(i,k) = 0 + qrn(i,k) = zero + qsnw(i,k) = zero + ncpl(i,k) = zero + ncpi(i,k) = zero enddo enddo else @@ -218,34 +219,34 @@ subroutine shoc_work (ix, nx, nzm, nz, dtn, & real, intent(in) :: prnum (nx,nzm) ! turbulent Prandtl number real, intent(inout) :: wthv_sec (ix,nzm) ! Buoyancy flux, K*m/s - real, parameter :: zero=0.0d0, one=1.0d0, half=0.5d0, two=2.0d0, eps=0.622d0, & - three=3.0d0, oneb3=one/three, twoby3=two/three, fourb3=twoby3+twoby3 - real, parameter :: sqrt2 = sqrt(two), twoby15 = two / 15.d0, & - nmin = 1.0d0, RI_cub = 6.4d-14, RL_cub = 1.0d-15, & - skew_facw=1.2d0, skew_fact=0.d0, & - tkhmax=300.d0, qcmin=1.0d-9 - real :: lsub, fac_cond, fac_fus, cpolv, fac_sub, ggri, kapa, gocp, & + real, parameter :: zero=0.0_kp, one=1.0_kp, half=0.5_kp, two=2.0_kp, eps=0.622_kp, & + three=3.0_kp, oneb3=one/three, twoby3=two/three, fourb3=twoby3+twoby3 + real, parameter :: sqrt2 = sqrt(two), twoby15 = two / 15.0_kp, & + nmin = 1.0_kp, RI_cub = 6.4e-14_kp, RL_cub = 1.0e-15_kp, & + skew_facw=1.2_kp, skew_fact=0.0_kp, & + tkhmax=300.0_kp, qcmin=1.0e-9_kp + real :: lsub, fac_cond, fac_fus, cpolv, fac_sub, ggri, kapa, gocp, & rog, sqrtpii, epsterm, onebeps, onebrvcp ! SHOC tunable parameters - real, parameter :: lambda = 0.04d0 -! real, parameter :: min_tke = 1.0d-6 ! Minumum TKE value, m**2/s**2 - real, parameter :: min_tke = 1.0d-4 ! Minumum TKE value, m**2/s**2 -! real, parameter :: max_tke = 100.0d0 ! Maximum TKE value, m**2/s**2 - real, parameter :: max_tke = 40.0d0 ! Maximum TKE value, m**2/s**2 + real, parameter :: lambda = 0.04_kp +! real, parameter :: min_tke = 1.0e-6_kp ! Minumum TKE value, m**2/s**2 + real, parameter :: min_tke = 1.0e-4_kp ! Minumum TKE value, m**2/s**2 +! real, parameter :: max_tke = 100.0_kp ! Maximum TKE value, m**2/s**2 + real, parameter :: max_tke = 40.0_kp ! Maximum TKE value, m**2/s**2 ! Maximum turbulent eddy length scale, m -! real, parameter :: max_eddy_length_scale = 2000.0d0 - real, parameter :: max_eddy_length_scale = 1000.0d0 +! real, parameter :: max_eddy_length_scale = 2000.0_kp + real, parameter :: max_eddy_length_scale = 1000.0_kp ! Maximum "return-to-isotropy" time scale, s - real, parameter :: max_eddy_dissipation_time_scale = 2000.d0 - real, parameter :: Pr = 1.0d0 ! Prandtl number + real, parameter :: max_eddy_dissipation_time_scale = 2000.0_kp + real, parameter :: Pr = 1.0_kp ! Prandtl number ! Constants for the TKE dissipation term based on Deardorff (1980) - real, parameter :: pt19=0.19d0, pt51=0.51d0, pt01=0.01d0, atmin=0.01d0, atmax=one-atmin - real, parameter :: Cs = 0.15d0, epsln=1.0d-6 -! real, parameter :: Ck = 0.2d0 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 - real, parameter :: Ck = 0.1d0 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 + real, parameter :: pt19=0.19_kp, pt51=0.51_kp, pt01=0.01_kp, atmin=0.01_kp, atmax=one-atmin + real, parameter :: Cs = 0.15_kp, epsln=1.0e-6_kp +! real, parameter :: Ck = 0.2_kp ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 + real, parameter :: Ck = 0.1_kp ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 ! real, parameter :: Ce = Ck**3/(0.7*Cs**4) ! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.2 @@ -258,29 +259,29 @@ subroutine shoc_work (ix, nx, nzm, nz, dtn, & real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce ! real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce*3.0/0.7 -! real, parameter :: vonk=0.35 ! Von Karman constant - real, parameter :: vonk=0.4d0 ! Von Karman constant Moorthi - as in GFS - real, parameter :: tscale=400.0d0 ! time scale set based off of similarity results of BK13, s - real, parameter :: w_tol_sqd = 4.0d-04 ! Min vlaue of second moment of w -! real, parameter :: w_tol_sqd = 1.0e-04 ! Min vlaue of second moment of w - real, parameter :: w_thresh = 0.0d0, thresh = 0.0d0 - real, parameter :: w3_tol = 1.0d-20 ! Min vlaue of third moment of w +! real, parameter :: vonk=0.35 ! Von Karman constant + real, parameter :: vonk=0.4_kp ! Von Karman constant Moorthi - as in GFS + real, parameter :: tscale=400.0_kp ! time scale set based off of similarity results of BK13, s + real, parameter :: w_tol_sqd = 4.0e-04_kp ! Min vlaue of second moment of w +! real, parameter :: w_tol_sqd = 1.0e-04_kp ! Min vlaue of second moment of w + real, parameter :: w_thresh = 0.0_kp, thresh = 0.0_kp + real, parameter :: w3_tol = 1.0e-20_kp ! Min vlaue of third moment of w ! These parameters are a tie-in with a microphysical scheme ! Double check their values for the Zhao-Carr scheme. - real, parameter :: tbgmin = 233.16d0 ! Minimum temperature for cloud water., K (ZC) -! real, parameter :: tbgmin = 258.16d0 ! Minimum temperature for cloud water., K (ZC) -! real, parameter :: tbgmin = 253.16d0 ! Minimum temperature for cloud water., K - real, parameter :: tbgmax = 273.16d0 ! Maximum temperature for cloud ice, K + real, parameter :: tbgmin = 233.16_kp ! Minimum temperature for cloud water., K (ZC) +! real, parameter :: tbgmin = 258.16_kp ! Minimum temperature for cloud water., K (ZC) +! real, parameter :: tbgmin = 253.16_kp ! Minimum temperature for cloud water., K + real, parameter :: tbgmax = 273.16_kp ! Maximum temperature for cloud ice, K real, parameter :: a_bg = one/(tbgmax-tbgmin) ! ! Parameters to tune the second order moments- No tuning is performed currently -! real, parameter :: thl2tune = 2.0d0, qw2tune = 2.0d0, qwthl2tune = 2.0d0, & - real, parameter :: thl2tune = 1.0d0, qw2tune = 1.0d0, qwthl2tune = 1.0d0, & -! thl_tol = 1.0d-4, rt_tol = 1.0d-8, basetemp = 300.0d0 - thl_tol = 1.0d-2, rt_tol = 1.0d-4 +! real, parameter :: thl2tune = 2.0_kp, qw2tune = 2.0_kp, qwthl2tune = 2.0_kp, & + real, parameter :: thl2tune = 1.0_kp, qw2tune = 1.0_kp, qwthl2tune = 1.0_kp, & +! thl_tol = 1.0e-4_kp, rt_tol = 1.0e-8_kp, basetemp = 300.0_kp + thl_tol = 1.0e-2_kp, rt_tol = 1.0e-4_kp integer, parameter :: nitr=6 @@ -452,7 +453,7 @@ subroutine shoc_work (ix, nx, nzm, nz, dtn, & ! total_water(i,k) = qcl(i,k) + qci(i,k) + qv(i,k) - prespot = (100000.0d0*wrk) ** kapa ! Exner function + prespot = (100000.0_kp*wrk) ** kapa ! Exner function bet(i,k) = ggr/(tabs(i,k)*prespot) ! Moorthi thv(i,k) = thv(i,k)*prespot ! Moorthi ! @@ -615,7 +616,7 @@ subroutine tke_shoc() call eddy_length() ! Find turbulent mixing length call check_eddy() ! Make sure it's reasonable - tkef2 = 1.0 - tkef1 + tkef2 = one - tkef1 do k=1,nzm ku = k+1 kd = k @@ -634,8 +635,8 @@ subroutine tke_shoc() if (dis_opt > 0) then do i=1,nx - wrk = (zl(i,k)-zi(i,1)) / adzl(i,1) + 1.5d0 - cek(i) = (one + two / max((wrk*wrk - 3.3d0), 0.5d0)) * cefac + wrk = (zl(i,k)-zi(i,1)) / adzl(i,1) + 1.5_kp + cek(i) = (one + two / max((wrk*wrk - 3.3_kp), 0.5_kp)) * cefac enddo else if (k == 1) then @@ -659,7 +660,7 @@ subroutine tke_shoc() !Obtain Brunt-Vaisalla frequency from diagnosed SGS buoyancy flux !Presumably it is more precise than BV freq. calculated in eddy_length()? - buoy_sgs = - (a_prod_bu+a_prod_bu) / (tkh(i,ku)+tkh(i,kd) + 0.0001) ! tkh is eddy thermal diffussivity + buoy_sgs = - (a_prod_bu+a_prod_bu) / (tkh(i,ku)+tkh(i,kd) + 0.0001_kp) ! tkh is eddy thermal diffussivity !Compute $c_k$ (variable Cee) for the TKE dissipation term following Deardorff (1980) @@ -667,7 +668,7 @@ subroutine tke_shoc() if (buoy_sgs <= zero) then smix = grd else - smix = min(grd,max(0.1d0*grd, 0.76d0*sqrt(tke(i,k)/(buoy_sgs+1.0d-10)))) + smix = min(grd,max(0.1_kp*grd, 0.76_kp*sqrt(tke(i,k)/(buoy_sgs+1.0e-10_kp)))) endif ratio = smix/grd @@ -809,9 +810,9 @@ subroutine eddy_length() ! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) do i=1,nx if (denom(i) > zero .and. numer(i) > zero) then - l_inf(i) = min(0.1d0 * (numer(i)/denom(i)), 100.0d0) + l_inf(i) = min(0.1_kp * (numer(i)/denom(i)), 100.0_kp) else - l_inf(i) = 100.0d0 + l_inf(i) = 100.0_kp endif enddo @@ -847,7 +848,7 @@ subroutine eddy_length() ! Find the in-cloud Brunt-Vaisalla frequency - omn = qcl(i,k) / (wrk+1.e-20) ! Ratio of liquid water to total water + omn = qcl(i,k) / (wrk+1.0e-20_kp) ! Ratio of liquid water to total water ! Latent heat of phase transformation based on relative water phase content ! fac_cond = lcond/cp, fac_fus = lfus/cp @@ -866,7 +867,7 @@ subroutine eddy_length() ! liquid/ice moist static energy static energy divided by cp? bbb = (one + epsv*qsatt-wrk-qpl(i,k)-qpi(i,k) & - + 1.61d0*tabs(i,k)*dqsat) / (one+lstarn*dqsat) + + 1.61_kp*tabs(i,k)*dqsat) / (one+lstarn*dqsat) ! Calculate Brunt-Vaisalla frequency using centered differences in the vertical @@ -916,7 +917,7 @@ subroutine eddy_length() wrk1 = one / (tscale*tkes*vonk*zl(i,k)) wrk2 = one / (tscale*tkes*l_inf(i)) wrk1 = wrk1 + wrk2 + pt01 * brunt2(i,k) / tke(i,k) - wrk1 = sqrt(one / max(wrk1,1.0d-8)) * (one/0.3d0) + wrk1 = sqrt(one / max(wrk1,1.0e-8_kp)) * (one/0.3_kp) ! smixt(i,k) = min(max_eddy_length_scale, 2.8284*sqrt(wrk1)/0.3) smixt(i,k) = min(max_eddy_length_scale, wrk1) @@ -987,11 +988,11 @@ subroutine eddy_length() ! The calculation below finds the integral in the Eq. 10 in BK13 for the current cloud conv_var = zero do kk=kl,ku - conv_var = conv_var+ 2.5d0*adzi(i,kk)*bet(i,kk)*wthv_sec(i,kk) + conv_var = conv_var+ 2.5_kp*adzi(i,kk)*bet(i,kk)*wthv_sec(i,kk) enddo conv_var = conv_var ** oneb3 - if (conv_var > 0) then ! If convective vertical velocity scale > 0 + if (conv_var > zero) then ! If convective vertical velocity scale > 0 depth = (zl(i,ku)-zl(i,kl)) + adzl(i,kl) @@ -1004,7 +1005,7 @@ subroutine eddy_length() wrk = conv_var/(depth*depth*sqrt(tke(i,kk))) & + pt01*brunt2(i,kk)/tke(i,kk) - smixt(i,kk) = min(max_eddy_length_scale, (one/0.3d0)*sqrt(one/wrk)) + smixt(i,kk) = min(max_eddy_length_scale, (one/0.3_kp)*sqrt(one/wrk)) enddo @@ -1051,7 +1052,7 @@ subroutine conv_scale() !********************************************************************** conv_vel2(i,k) = conv_vel2(i,k-1) & - + 2.5*adzi(i,k)*bet(i,k)*wthv_sec(i,k) + + 2.5_kp*adzi(i,k)*bet(i,k)*wthv_sec(i,k) enddo enddo @@ -1082,7 +1083,7 @@ subroutine check_eddy() do i=1,nx - wrk = 0.1*adzl(i,k) + wrk = 0.1_kp*adzl(i,k) ! Minimum 0.1 of local dz smixt(i,k) = max(wrk, min(max_eddy_length_scale,smixt(i,k))) @@ -1090,7 +1091,7 @@ subroutine check_eddy() ! be not larger that that. ! if (sqrt(dx*dy) .le. 1000.) smixt(i,k)=min(sqrt(dx*dy),smixt(i,k)) - if (qcl(i,kb) == 0 .and. qcl(i,k) > 0 .and. brunt(i,k) > 1.0d-4) then + if (qcl(i,kb) == zero .and. qcl(i,k) > zero .and. brunt(i,k) > 1.0e-4_kp) then !If just above the cloud top and atmosphere is stable, set to 0.1 of local dz smixt(i,k) = wrk endif @@ -1116,10 +1117,10 @@ subroutine canuto() ! cond, wrk, wrk1, wrk2, wrk3, avew ! ! See Eq. 7 in C01 (B.7 in Pete's dissertation) - real, parameter :: c=7.0d0, a0=0.52d0/(c*c*(c-2.0d0)), a1=0.87d0/(c*c), & - a2=0.5d0/c, a3=0.6d0/(c*(c-2.0d0)), a4=2.4d0/(3.0d0*c+5.0d0), & - a5=0.6d0/(c*(3.0d0*c+5.0d0)) -!Moorthi a5=0.6d0/(c*(3.0d0+5.0d0*c)) + real, parameter :: c=7.0_kp, a0=0.52_kp/(c*c*(c-2.0_kp)), a1=0.87_kp/(c*c), & + a2=0.5_kp/c, a3=0.6_kp/(c*(c-2.0_kp)), a4=2.4_kp/(3.0_kp*c+5.0_kp), & + a5=0.6_kp/(c*(3.0_kp*c+5.0_kp)) +!Moorthi a5=0.6_kp/(c*(3.0_kp+5.0_kp*c)) ! do k=1,nzm do k=2,nzm @@ -1209,7 +1210,7 @@ subroutine canuto() omega0 = a4 / (one-a5*buoy_sgs2) omega1 = omega0 / (c+c) - omega2 = omega1*f3+(5./4.)*omega0*f4 + omega2 = omega1*f3+(5.0_kp/4.0_kp)*omega0*f4 ! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) @@ -1232,7 +1233,7 @@ subroutine canuto() !aab ! Implemetation of the C01 approach in this subroutine is nearly complete @@ -1286,7 +1287,7 @@ subroutine assumed_pdf() diag_qi = zero pval = prsl(i,k) - pfac = pval * 1.0d-5 + pfac = pval * 1.0e-5_kp pkap = pfac ** kapa ! Read in liquid/ice static energy, total water mixing ratio, @@ -1360,21 +1361,21 @@ subroutine assumed_pdf() ELSE !aab Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi ! Proportionality coefficients between widths of each vertical velocity ! gaussian and the sqrt of the second moment of w - w2_1 = 0.4 - w2_2 = 0.4 + w2_1 = 0.4_kp + w2_2 = 0.4_kp ! Compute realtive weight of the first PDF "plume" ! See Eq A4 in Pete's dissertaion - Ensure 0.01 < a < 0.99 wrk = one - w2_1 - aterm = max(atmin,min(half*(one-Skew_w*sqrt(one/(4.*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) + aterm = max(atmin,min(half*(one-Skew_w*sqrt(one/(4.0_kp*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) onema = one - aterm sqrtw2t = sqrt(wrk) @@ -1413,8 +1414,8 @@ subroutine assumed_pdf() ! wrk4 = - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 wrk = three * (thl1_2-thl1_1) if (wrk /= zero) then - thl2_1 = thlsec * min(100.0d0,max(zero,(thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - thl2_2 = thlsec * min(100.0d0,max(zero,(-thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + thl2_1 = thlsec * min(100.0_kp,max(zero,(thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + thl2_2 = thlsec * min(100.0_kp,max(zero,(-thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 else thl2_1 = zero thl2_2 = zero @@ -1448,12 +1449,12 @@ subroutine assumed_pdf() ! Skew_qw = skew_facw*Skew_w - IF (tsign > 0.4) THEN + IF (tsign > 0.4_kp) THEN Skew_qw = skew_facw*Skew_w - ELSEIF (tsign <= 0.2) THEN + ELSEIF (tsign <= 0.2_kp) THEN Skew_qw = zero ELSE - Skew_qw = (skew_facw/0.2) * Skew_w * (tsign-0.2) + Skew_qw = (skew_facw/0.2_kp) * Skew_w * (tsign-0.2_kp) ENDIF wrk1 = qw1_1 * qw1_1 @@ -1463,8 +1464,8 @@ subroutine assumed_pdf() wrk = three * (qw1_2-qw1_1) if (wrk /= zero) then - qw2_1 = qwsec * min(100.0d0,max(zero,( qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 - qw2_2 = qwsec * min(100.0d0,max(zero,(-qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + qw2_1 = qwsec * min(100.0_kp,max(zero,( qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + qw2_2 = qwsec * min(100.0_kp,max(zero,(-qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 else qw2_1 = zero qw2_2 = zero @@ -1487,7 +1488,7 @@ subroutine assumed_pdf() testvar = aterm*sqrtqw2_1*sqrtthl2_1 + onema*sqrtqw2_2*sqrtthl2_2 - IF (testvar == 0) THEN + IF (testvar == zero) THEN r_qwthl_1 = zero ELSE r_qwthl_1 = max(-one,min(one,(qwthlsec-aterm*(qw1_1-qw_first)*(thl1_1-thl_first) & @@ -1510,18 +1511,18 @@ subroutine assumed_pdf() IF (Tl1_1 >= tbgmax) THEN lstarn1 = lcond esval = min(fpvsl(Tl1_1), pval) - qs1 = eps * esval / (pval-0.378d0*esval) + qs1 = eps * esval / (pval-0.378_kp*esval) ELSE IF (Tl1_1 <= tbgmin) THEN lstarn1 = lsub esval = min(fpvsi(Tl1_1), pval) - qs1 = epss * esval / (pval-0.378d0*esval) + qs1 = epss * esval / (pval-0.378_kp*esval) ELSE om1 = max(zero, min(one, a_bg*(Tl1_1-tbgmin))) lstarn1 = lcond + (one-om1)*lfus esval = min(fpvsl(Tl1_1), pval) esval2 = min(fpvsi(Tl1_1), pval) - qs1 = om1 * eps * esval / (pval-0.378d0*esval) & - + (one-om1) * epss * esval2 / (pval-0.378d0*esval2) + qs1 = om1 * eps * esval / (pval-0.378_kp*esval) & + + (one-om1) * epss * esval2 / (pval-0.378_kp*esval2) ENDIF ! beta1 = (rgas/rv)*(lstarn1/(rgas*Tl1_1))*(lstarn1/(cp*Tl1_1)) @@ -1540,18 +1541,18 @@ subroutine assumed_pdf() IF (Tl1_2 >= tbgmax) THEN lstarn2 = lcond esval = min(fpvsl(Tl1_2), pval) - qs2 = eps * esval / (pval-0.378d0*esval) + qs2 = eps * esval / (pval-0.378_kp*esval) ELSE IF (Tl1_2 <= tbgmin) THEN lstarn2 = lsub esval = min(fpvsi(Tl1_2), pval) - qs2 = epss * esval / (pval-0.378d0*esval) + qs2 = epss * esval / (pval-0.378_kp*esval) ELSE om2 = max(zero, min(one, a_bg*(Tl1_2-tbgmin))) lstarn2 = lcond + (one-om2)*lfus esval = min(fpvsl(Tl1_2), pval) esval2 = min(fpvsi(Tl1_2), pval) - qs2 = om2 * eps * esval / (pval-0.378d0*esval) & - + (one-om2) * epss * esval2 / (pval-0.378d0*esval2) + qs2 = om2 * eps * esval / (pval-0.378_kp*esval) & + + (one-om2) * epss * esval2 / (pval-0.378_kp*esval2) ENDIF ! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 @@ -1646,8 +1647,7 @@ subroutine assumed_pdf() diag_qn = min(max(zero, aterm*qn1 + onema*qn2), total_water(i,k)) diag_ql = min(max(zero, aterm*ql1 + onema*ql2), diag_qn) - diag_qi = diag_qn - diag_ql - + diag_qi = max(zero, diag_qn - diag_ql) ! Update temperature variable based on diagnosed cloud properties om1 = max(zero, min(one, (tabs(i,k)-tbgmin)*a_bg)) @@ -1656,30 +1656,29 @@ subroutine assumed_pdf() + fac_sub *(diag_qi+qpi(i,k)) & + tkesbdiss(i,k) * (dtn/cp) ! tke dissipative heating -! Update moisture fields - ! Update ncpl and ncpi Anning Cheng 03/11/2016 ! ncpl(i,k) = diag_ql/max(qc(i,k),1.e-10)*ncpl(i,k) - qc(i,k) = diag_ql - qi(i,k) = diag_qi - qwv(i,k) = total_water(i,k) - diag_qn - cld_sgs(i,k) = diag_frac - ! Update ncpl and ncpi Moorthi 12/12/2018 if (ntlnc > 0) then ! liquid and ice number concentrations predicted if (ncpl(i,k) > nmin) then - ncpl(i,k) = diag_ql/max(qc(i,k),1.0d-10)*ncpl(i,k) + ncpl(i,k) = diag_ql/max(qc(i,k),1.0e-10_kp)*ncpl(i,k) else - ncpl(i,k) = max(diag_ql/(fourb3*pi*RL_cub*997.0d0), nmin) + ncpl(i,k) = max(diag_ql/(fourb3*pi*RL_cub*997.0_kp), nmin) endif if (ncpi(i,k) > nmin) then - ncpi(i,k) = diag_qi/max(qi(i,k),1.0d-10)*ncpi(i,k) + ncpi(i,k) = diag_qi/max(qi(i,k),1.0e-10_kp)*ncpi(i,k) else - ncpi(i,k) = max(diag_qi/(fourb3*pi*RI_cub*500.0d0), nmin) + ncpi(i,k) = max(diag_qi/(fourb3*pi*RI_cub*500.0_kp), nmin) endif endif +! Update moisture fields + qc(i,k) = diag_ql + qi(i,k) = diag_qi + qwv(i,k) = max(zero, total_water(i,k) - diag_qn) + cld_sgs(i,k) = diag_frac + ! Compute the liquid water flux wqls = aterm * ((w1_1-w_first)*ql1) + onema * ((w1_2-w_first)*ql2) wqis = aterm * ((w1_1-w_first)*qi1) + onema * ((w1_2-w_first)*qi2) diff --git a/physics/gcm_shoc.meta b/physics/gcm_shoc.meta index c1ed6fbd4..d9a58d8b5 100644 --- a/physics/gcm_shoc.meta +++ b/physics/gcm_shoc.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = shoc + type = scheme + dependencies = funcphys.f90,machine.F + +######################################################################## [ccpp-arg-table] name = shoc_run type = scheme diff --git a/physics/gcycle.F90 b/physics/gcycle.F90 index c37d39d10..2125e0ad2 100644 --- a/physics/gcycle.F90 +++ b/physics/gcycle.F90 @@ -5,8 +5,7 @@ !>\ingroup mod_GFS_phys_time_vary !! This subroutine repopulates specific time-varying surface properties for !! atmospheric forecast runs. -# 1 "physics/gcycle.F90" - SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) + SUBROUTINE GCYCLE (nblks, nthrds, Model, Grid, Sfcprop, Cldprop) ! ! USE MACHINE, only: kind_phys @@ -15,7 +14,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) GFS_sfcprop_type, GFS_cldprop_type implicit none - integer, intent(in) :: nblks + integer, intent(in) :: nblks, nthrds type(GFS_control_type), intent(in) :: Model type(GFS_grid_type), intent(in) :: Grid(nblks) type(GFS_sfcprop_type), intent(inout) :: Sfcprop(nblks) @@ -62,10 +61,12 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) STCFC1 (Model%nx*Model%ny*max(Model%lsoil,Model%lsoil_lsm)), & SLCFC1 (Model%nx*Model%ny*max(Model%lsoil,Model%lsoil_lsm)) + logical :: lake(Model%nx*Model%ny) + character(len=6) :: tile_num_ch real(kind=kind_phys), parameter :: pifac=180.0/pi real(kind=kind_phys) :: sig1t, dt_warm - integer :: npts, len, nb, ix, jx, ls, ios + integer :: npts, len, nb, ix, jx, ls, ios, ll logical :: exists ! !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @@ -82,22 +83,22 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) len = 0 do jx = Model%jsc, (Model%jsc+Model%ny-1) - do ix = Model%isc, (Model%isc+Model%nx-1) - len = len + 1 - i_index(len) = ix - j_index(len) = jx - enddo + do ix = Model%isc, (Model%isc+Model%nx-1) + len = len + 1 + i_index(len) = ix + j_index(len) = jx + enddo enddo - sig1t = 0.0 + sig1t = 0.0_kind_phys npts = Model%nx*Model%ny ! len = 0 do nb = 1,nblks do ix = 1,size(Grid(nb)%xlat,1) len = len + 1 - RLA (len) = Grid(nb)%xlat (ix) * pifac - RLO (len) = Grid(nb)%xlon (ix) * pifac + RLA (len) = Grid(nb)%xlat (ix) * pifac + RLO (len) = Grid(nb)%xlon (ix) * pifac OROG (len) = Sfcprop(nb)%oro (ix) OROG_UF (len) = Sfcprop(nb)%oro_uf (ix) SLIFCS (len) = Sfcprop(nb)%slmsk (ix) @@ -107,7 +108,12 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) TSFFCS(len) = Sfcprop(nb)%tsfc (ix) endif SNOFCS (len) = Sfcprop(nb)%weasd (ix) - ZORFCS (len) = Sfcprop(nb)%zorl (ix) + ZORFCS (len) = Sfcprop(nb)%zorll (ix) + if (SLIFCS(len) > 1.9_kind_phys .and. .not. Model%frac_grid) then + ZORFCS (len) = Sfcprop(nb)%zorli (ix) + elseif (SLIFCS(len) < 0.1_kind_phys .and. .not. Model%frac_grid) then + ZORFCS (len) = Sfcprop(nb)%zorlo (ix) + endif TG3FCS (len) = Sfcprop(nb)%tg3 (ix) CNPFCS (len) = Sfcprop(nb)%canopy (ix) ! F10MFCS (len) = Sfcprop(nb)%f10m (ix) @@ -146,17 +152,22 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) endif enddo - IF (SLIFCS(len) .LT. 0.1 .OR. SLIFCS(len) .GT. 1.5) THEN - SLMASK(len) = 0 + IF (SLIFCS(len) < 0.1_kind_phys .OR. SLIFCS(len) > 1.5_kind_phys) THEN + SLMASK(len) = 0.0_kind_phys ELSE - SLMASK(len) = 1 + SLMASK(len) = 1.0_kind_phys ENDIF - IF (SLIFCS(len) .EQ. 2) THEN - AISFCS(len) = 1. + IF (SLIFCS(len) > 1.99_kind_phys) THEN + AISFCS(len) = 1.0_kind_phys ELSE - AISFCS(len) = 0. + AISFCS(len) = 0.0_kind_phys ENDIF + if (Sfcprop(nb)%lakefrac(ix) > 0.0_kind_phys) then + lake(len) = .true. + else + lake(len) = .false. + endif ! if (Model%me .eq. 0) ! & print *,' len=',len,' rla=',rla(len),' rlo=',rlo(len) @@ -188,9 +199,10 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) SNOFCS, ZORFCS, ALBFC1, TG3FCS, CNPFCS, & SMCFC1, STCFC1, SLIFCS, AISFCS, & VEGFCS, VETFCS, SOTFCS, ALFFC1, CVFCS, & - CVBFCS, CVTFCS, Model%me, Model%nlunit, & - size(Model%input_nml_file), & + CVBFCS, CVTFCS, Model%me, nthrds, & + Model%nlunit, size(Model%input_nml_file), & Model%input_nml_file, & + lake, Model%min_lakeice, Model%min_seaice, & Model%ialb, Model%isot, Model%ivegsrc, & trim(tile_num_ch), i_index, j_index) #ifndef INTERNAL_FILE_NML @@ -215,7 +227,12 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%tsfco(ix) = TSFFCS (len) endif Sfcprop(nb)%weasd (ix) = SNOFCS (len) - Sfcprop(nb)%zorl (ix) = ZORFCS (len) + Sfcprop(nb)%zorll (ix) = ZORFCS (len) + if (SLIFCS(len) > 1.9_kind_phys .and. .not. Model%frac_grid) then + Sfcprop(nb)%zorli(ix) = ZORFCS (len) + elseif (SLIFCS(len) < 0.1_kind_phys .and. .not. Model%frac_grid) then + Sfcprop(nb)%zorlo(ix) = ZORFCS (len) + endif Sfcprop(nb)%tg3 (ix) = TG3FCS (len) Sfcprop(nb)%canopy (ix) = CNPFCS (len) ! Sfcprop(nb)%f10m (ix) = F10MFCS (len) @@ -242,18 +259,19 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) Sfcprop(nb)%alnsf (ix) = ALBFC1 (len + npts*2) Sfcprop(nb)%alnwf (ix) = ALBFC1 (len + npts*3) do ls = 1,max(Model%lsoil,Model%lsoil_lsm) + ll = len + (ls-1)*npts if(Model%lsoil == Model%lsoil_lsm) then - Sfcprop(nb)%smc (ix,ls) = SMCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%stc (ix,ls) = STCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%slc (ix,ls) = SLCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%smc (ix,ls) = SMCFC1 (ll) + Sfcprop(nb)%stc (ix,ls) = STCFC1 (ll) + Sfcprop(nb)%slc (ix,ls) = SLCFC1 (ll) else - Sfcprop(nb)%smois (ix,ls) = SMCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%tslb (ix,ls) = STCFC1 (len + (ls-1)*npts) - Sfcprop(nb)%sh2o (ix,ls) = SLCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%smois (ix,ls) = SMCFC1 (ll) + Sfcprop(nb)%tslb (ix,ls) = STCFC1 (ll) + Sfcprop(nb)%sh2o (ix,ls) = SLCFC1 (ll) endif - if (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (len + (ls-1)*npts) + if (ls<=Model%kice) Sfcprop(nb)%tiice (ix,ls) = STCFC1 (ll) enddo - ENDDO !-----END BLOCK SIZE LOOP------------------------------ + ENDDO !-----END BLOCK SIZE LOOP-------------------------- ENDDO !-----END BLOCK LOOP------------------------------- ! check diff --git a/physics/get_prs_fv3.F90 b/physics/get_prs_fv3.F90 index dd5871896..352a61895 100644 --- a/physics/get_prs_fv3.F90 +++ b/physics/get_prs_fv3.F90 @@ -8,7 +8,7 @@ module get_prs_fv3 !--- local variables real(kind=kind_phys), parameter :: zero = 0.0_kind_phys - real(kind=kind_phys), parameter :: half = 0.5_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys contains @@ -50,7 +50,7 @@ subroutine get_prs_fv3_run(ix, levs, phii, prsi, tgrs, qgrs1, del, del_gz, errms do i=1,ix del(i,k) = prsi(i,k) - prsi(i,k+1) del_gz(i,k) = (phii(i,k+1) - phii(i,k)) / & - (tgrs(i,k)*(1.+con_fvirt*max(zero,qgrs1(i,k)))) + (tgrs(i,k)*(one + con_fvirt*max(zero,qgrs1(i,k)))) enddo enddo @@ -78,6 +78,7 @@ module get_phi_fv3 !--- local variables real(kind=kind_phys), parameter :: zero = 0.0_kind_phys real(kind=kind_phys), parameter :: half = 0.5_kind_phys + real(kind=kind_phys), parameter :: one = 1.0_kind_phys contains @@ -118,7 +119,7 @@ subroutine get_phi_fv3_run(ix, levs, gt0, gq01, del_gz, phii, phil, errmsg, errf do k=1,levs do i=1,ix del_gz(i,k) = del_gz(i,k)*gt0(i,k) * & - & (1.+con_fvirt*max(zero,gq01(i,k))) + & (one + con_fvirt*max(zero,gq01(i,k))) phii(i,k+1) = phii(i,k) + del_gz(i,k) phil(i,k) = half*(phii(i,k) + phii(i,k+1)) enddo diff --git a/physics/get_prs_fv3.meta b/physics/get_prs_fv3.meta index f93d259e1..2db340300 100644 --- a/physics/get_prs_fv3.meta +++ b/physics/get_prs_fv3.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = get_prs_fv3_init +[ccpp-table-properties] + name = get_prs_fv3 type = scheme + dependencies = machine.F,physcons.F90 ######################################################################## [ccpp-arg-table] @@ -95,14 +96,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = get_prs_fv3_finalize - type = scheme - -######################################################################## -[ccpp-arg-table] - name = get_phi_fv3_init +[ccpp-table-properties] + name = get_phi_fv3 type = scheme + dependencies = machine.F,physcons.F90 ######################################################################## [ccpp-arg-table] @@ -187,7 +184,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = get_phi_fv3_finalize - type = scheme diff --git a/physics/gfdl_cloud_microphys.meta b/physics/gfdl_cloud_microphys.meta index 3d202722b..3c9a53606 100644 --- a/physics/gfdl_cloud_microphys.meta +++ b/physics/gfdl_cloud_microphys.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = gfdl_cloud_microphys + type = scheme + dependencies = machine.F,module_mp_radar.F90,module_gfdl_cloud_microphys.F90 + +######################################################################## [ccpp-arg-table] name = gfdl_cloud_microphys_init type = scheme diff --git a/physics/gfdl_fv_sat_adj.meta b/physics/gfdl_fv_sat_adj.meta index 18b37a3c5..d54baf1bb 100644 --- a/physics/gfdl_fv_sat_adj.meta +++ b/physics/gfdl_fv_sat_adj.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = fv_sat_adj + type = scheme + dependencies = machine.F,module_gfdl_cloud_microphys.F90,module_mp_radar.F90,multi_gases.F90,physcons.F90 + +######################################################################## [ccpp-arg-table] name = fv_sat_adj_init type = scheme diff --git a/physics/gmtb_scm_sfc_flux_spec.meta b/physics/gmtb_scm_sfc_flux_spec.meta index 6424789bc..2dba88b57 100644 --- a/physics/gmtb_scm_sfc_flux_spec.meta +++ b/physics/gmtb_scm_sfc_flux_spec.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = gmtb_scm_sfc_flux_spec + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = gmtb_scm_sfc_flux_spec_run type = scheme diff --git a/physics/gscond.meta b/physics/gscond.meta index 57156358f..9012cc650 100644 --- a/physics/gscond.meta +++ b/physics/gscond.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = zhaocarr_gscond + type = scheme + dependencies = funcphys.f90,machine.F,physcons.F90 + +######################################################################## [ccpp-arg-table] name = zhaocarr_gscond_run type = scheme diff --git a/physics/gwdc.meta b/physics/gwdc.meta index b9f0b669c..30f5fcbfd 100644 --- a/physics/gwdc.meta +++ b/physics/gwdc.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = gwdc_pre_init +[ccpp-table-properties] + name = gwdc_pre type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -164,14 +165,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = gwdc_pre_finalize - type = scheme - -######################################################################## -[ccpp-arg-table] - name = gwdc_init +[ccpp-table-properties] + name = gwdc type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -449,14 +446,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = gwdc_finalize - type = scheme - -######################################################################## -[ccpp-arg-table] - name = gwdc_post_init +[ccpp-table-properties] + name = gwdc_post type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -638,7 +631,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = gwdc_post_finalize - type = scheme diff --git a/physics/gwdps.meta b/physics/gwdps.meta index 655c085ac..401024729 100644 --- a/physics/gwdps.meta +++ b/physics/gwdps.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = gwdps_init +[ccpp-table-properties] + name = gwdps type = scheme + dependencies = ######################################################################## [ccpp-arg-table] @@ -366,7 +367,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = gwdps_finalize - type = scheme diff --git a/physics/h2ophys.meta b/physics/h2ophys.meta index 995e25436..27476ae08 100644 --- a/physics/h2ophys.meta +++ b/physics/h2ophys.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = h2ophys_init +[ccpp-table-properties] + name = h2ophys type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -117,7 +118,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = h2ophys_finalize - type = scheme diff --git a/physics/lsm_ruc_sfc_sice_interstitial.meta b/physics/lsm_ruc_sfc_sice_interstitial.meta index bc3618703..d78343422 100644 --- a/physics/lsm_ruc_sfc_sice_interstitial.meta +++ b/physics/lsm_ruc_sfc_sice_interstitial.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = lsm_ruc_sfc_sice_pre + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = lsm_ruc_sfc_sice_pre_run type = scheme @@ -94,6 +100,12 @@ intent = out optional = F +######################################################################## +[ccpp-table-properties] + name = lsm_ruc_sfc_sice_post + type = scheme + dependencies = machine.F + ######################################################################## [ccpp-arg-table] name = lsm_ruc_sfc_sice_post_run diff --git a/physics/m_micro.F90 b/physics/m_micro.F90 index f3420e094..69690d52e 100644 --- a/physics/m_micro.F90 +++ b/physics/m_micro.F90 @@ -18,12 +18,12 @@ module m_micro !> \section arg_table_m_micro_init Argument Table !! \htmlinclude m_micro_init.html !! -subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, cpair, & +subroutine m_micro_init(imp_physics, imp_physics_mg, fprcp, gravit, rair, rh2o, cpair,& eps, tmelt, latvap, latice, mg_dcs, mg_qcvar, mg_ts_auto_ice, & - mg_rhmini, microp_uniform, do_cldice, hetfrz_classnuc, & - mg_precip_frac_method, mg_berg_eff_factor, sed_supersat, & - do_sb_physics, mg_do_hail, mg_do_graupel, mg_nccons, & - mg_nicons, mg_ngcons, mg_ncnst, mg_ninst, mg_ngnst, & + mg_rhmini, microp_uniform, do_cldice, hetfrz_classnuc, & + mg_precip_frac_method, mg_berg_eff_factor, sed_supersat, & + do_sb_physics, mg_do_hail, mg_do_graupel, mg_nccons, & + mg_nicons, mg_ngcons, mg_ncnst, mg_ninst, mg_ngnst, & mg_do_ice_gmao, mg_do_liq_liu, errmsg, errflg) use machine, only: kind_phys @@ -167,16 +167,18 @@ subroutine m_micro_run( im, lm, flipv, dt_i & !------------------------------------ ! input ! real, parameter :: r_air = 3.47d-3 - real, parameter :: one=1.0, oneb3=one/3.0, onebcp=one/cp, & - & kapa=rgas*onebcp, cpbg=cp/grav, & - & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp,& - & qsmall=1.e-14, rainmin = 1.0e-13, & - & fourb3=4.0/3.0, RL_cub=1.0e-15, nmin=1.0 + integer, parameter :: kp = kind_phys + real, parameter :: one=1.0_kp, oneb3=one/3.0_kp, onebcp=one/cp, & + zero=0.0_kp, half=0.5_kp, onebg=one/grav, & + & kapa=rgas*onebcp, cpbg=cp/grav, & + & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp, & + & qsmall=1.0e-14_kp, rainmin = 1.0e-13_kp, & + & fourb3=4.0_kp/3.0_kp, RL_cub=1.0e-15_kp, & + & nmin=1.0_kp integer, parameter :: ncolmicro = 1 - integer,intent(in) :: im, lm, kdt, fprcp, pdfflag + integer,intent(in) :: im, lm, kdt, fprcp, pdfflag, iccn logical,intent(in) :: flipv, skip_macro - integer,intent(in) :: iccn real (kind=kind_phys), intent(in):: dt_i, alf_fac, qc_min(2) real (kind=kind_phys), dimension(im,lm),intent(in) :: & @@ -227,7 +229,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & integer kcldtopcvn,i,k,ll, kbmin, NAUX, nbincontactdust,l integer, dimension(im) :: kct real (kind=kind_phys) T_ICE_ALL, USE_AV_V,BKGTAU,LCCIRRUS, & - & NPRE_FRAC, Nct, Wct, fcn, ksa1, tauxr8, DT_Moist, dt_r8, tem, & + & NPRE_FRAC, Nct, Wct, fcn, ksa1, tauxr8, DT_Moist, dt_kp, tem, & & TMAXLL, USURF,LTS_UP, LTS_LOW, MIN_EXP, fracover, c2_gw, est3 real(kind=kind_phys), allocatable, dimension(:,:) :: & @@ -326,7 +328,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & & ncalr8, ncair8, mnuccdor8, nnucctor8, nsoutr8, nroutr8, & & nnuccdor8, nnucccor8,naair8, & & nsacwior8, nsubior8, nprcior8, npraior8, npccnor8, npsacwsor8, & - & nsubcor8, npraor8, nprc1or8, tlatauxr8,pfrz_inc_r8,sadice, & + & nsubcor8, npraor8, nprc1or8, tlatauxr8,pfrz_inc_kp,sadice, & & sadsnow, am_evp_st, reff_rain, reff_snow, & & umr,ums,qrsedten,qssedten,refl,arefl,areflz,frefl,csrfl, & & acsrfl,fcsrfl,rercld,qrout2,qsout2,nrout2,nsout2,drout2, & @@ -345,28 +347,29 @@ subroutine m_micro_run( im, lm, flipv, dt_i & sflx, gflx ! real (kind=kind_phys), parameter :: disp_liu=2., ui_scale=1.0 & -! &, dcrit=20.0e-6 & - real (kind=kind_phys), parameter :: disp_liu=1.0, ui_scale=1.0 & - &, dcrit=1.0e-6 & +! &, dcrit=20.0d-6 & + real (kind=kind_phys), parameter :: disp_liu=1.0_kp & + &, ui_scale=1.0_kp & + &, dcrit=1.0e-6_kp & ! &, ts_autice=1800.0 & ! &, ts_autice=3600.0 & !time scale - &, ninstr8 = 0.1e6 & - &, ncnstr8 = 100.0e6 + &, ninstr8 = 0.1e6_kp & + &, ncnstr8 = 100.0e6_kp - real(kind=kind_phys):: k_gw, maxkh, tausurf_gw, overscale, tx1, rh1_r8 + real(kind=kind_phys):: k_gw, maxkh, tausurf_gw, overscale, tx1, rh1_kp real(kind=kind_phys):: t_ice_denom - integer, dimension(1) :: lev_sed_strt ! sedimentation start level - real(kind=kind_phys), parameter :: sig_sed_strt=0.05 ! normalized pressure at sedimentation start + integer, dimension(1) :: lev_sed_strt ! sedimentation start level + real(kind=kind_phys), parameter :: sig_sed_strt=0.05_kp ! normalized pressure at sedimentation start real(kind=kind_phys),dimension(3) :: ccn_diag real(kind=kind_phys),dimension(58) :: cloudparams integer, parameter :: CCN_PARAM=2, IN_PARAM=5 - real(kind=kind_phys), parameter ::fdust_drop=1.0, fsoot_drop=0.1 & - &, sigma_nuc_r8=0.28,SCLMFDFR=0.03 -! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1 + real(kind=kind_phys), parameter ::fdust_drop=1.0_kp, fsoot_drop=0.1_kp & + &, sigma_nuc_kp=0.28_kp,SCLMFDFR=0.03_kp +! &, sigma_nuc_kp=0.28,SCLMFDFR=0.1 type (AerProps), dimension (IM,LM) :: AeroProps type (AerProps) :: AeroAux, AeroAux_b @@ -380,22 +383,22 @@ subroutine m_micro_run( im, lm, flipv, dt_i & !================== Start Stratiform cloud processes========================================== !set up initial values - data USE_AV_V/1./, BKGTAU/0.015/, LCCIRRUS/500./, NPRE_FRAC/1./, & - & TMAXLL/296./, fracover/1./, LTS_LOW/12./, LTS_UP/24./, & - & MIN_EXP/0.5/ - - data cloudparams/ & - & 10.0, 4.0 , 4.0 , 1.0 , 2.e-3, 8.e-4, 2.0 , 1.0 , -1.0 & - &, 0.0 , 1.3 , 1.0e-9, 3.3e-4, 20.0 , 4.8 , 4.8 , 230.0 , 1.0 & - &, 1.0 , 230.0, 14400., 50.0 , 0.01 , 0.1 , 200.0, 0.0 , 0.0 & - &, 0.5 , 0.5 , 2000.0, 0.8 , 0.5 , -40.0, 1.0 , 4.0 , 0.0 & - &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 900.0& -! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 880.0& -! &, 0.0 , 0.0 , 1.0e-3, 8.0e-4, 1.0 , 0.95 , 1.0 , 0.0 , 980.0& - &, 1.0 , 1.0 , 1.0 , 0.0 , 0.0 , 1.e-5, 2.e-5, 2.1e-5, 4.e-5& -! &, 3e-5, 0.1 , 4.0 , 250./ ! Annings version - &, 3e-5, 0.1 , 4.0 , 150./ ! Annings version -! &, 3e-5, 0.1 , 1.0 , 150./ + data USE_AV_V/1.0_kp/, BKGTAU/0.015_kp/, LCCIRRUS/500.0_kp/, NPRE_FRAC/1.0_kp/, & + & TMAXLL/296.0_kp/, fracover/1.0_kp/, LTS_LOW/12.0_kp/, LTS_UP/24.0_kp/, & + & MIN_EXP/0.5_kp/ + + data cloudparams/ & + & 10.0_kp, 4.0_kp , 4.0_kp , 1.0_kp , 2.e-3_kp, 8.e-4_kp, 2.0_kp , 1.0_kp , -1.0_kp & + &, 0.0_kp , 1.3_kp , 1.0e-9_kp, 3.3e-4_kp, 20.0_kp , 4.8_kp , 4.8_kp , 230.0_kp , 1.0_kp & + &, 1.0_kp , 230.0_kp, 14400._kp, 50.0_kp , 0.01_kp , 0.1_kp , 200.0_kp, 0.0_kp , 0.0_kp & + &, 0.5_kp , 0.5_kp , 2000.0_kp, 0.8_kp , 0.5_kp , -40.0_kp, 1.0_kp , 4.0_kp , 0.0_kp & + &, 0.0_kp , 0.0_kp , 1.0e-3_kp, 8.0e-4_kp, 1.0_kp , 0.95_kp , 1.0_kp , 0.0_kp , 900.0_kp& +! &, 0.0_kp , 0.0_kp , 1.0e-3_kp, 8.0e-4_kp, 1.0_kp , 0.95_kp , 1.0_kp , 0.0_kp , 880.0_kp& +! &, 0.0_kp , 0.0_kp , 1.0e-3_kp, 8.0e-4_kp, 1.0_kp , 0.95_kp , 1.0_kp , 0.0_kp , 980.0_kp& + &, 1.0_kp , 1.0_kp , 1.0_kp , 0.0_kp , 0.0_kp , 1.e-5_kp, 2.e-5_kp, 2.1e-5_kp, 4.e-5_kp& +! &, 3e-5_kp, 0.1_kp , 4.0_kp , 250.0_kp/ ! Annings version + &, 3e-5_kp, 0.1_kp , 4.0_kp , 150.0_kp/ ! Annings version +! &, 3e-5_kp, 0.1_kp , 1.0_kp , 150.0_kp/ ! Initialize CCPP error handling variables errmsg = '' @@ -430,9 +433,9 @@ subroutine m_micro_run( im, lm, flipv, dt_i & CNV_UPDF(i,k) = cf_upi(i,ll) CNV_DQLDT(I,K) = CNV_DQLDT_i(I,ll) CLCN(I,k) = CLCN_i(I,ll) - CLLS(I,k) = max(CLLS_io(I,ll)-CLCN_i(I,ll),0.0) - PLO(i,k) = prsl_i(i,ll)*0.01 - zlo(i,k) = phil(i,ll) * (1.0/grav) + CLLS(I,k) = max(CLLS_io(I,ll)-CLCN_i(I,ll),zero) + PLO(i,k) = prsl_i(i,ll)*0.01_kp + zlo(i,k) = phil(i,ll) * onebg temp(i,k) = t_io(i,ll) radheat(i,k) = lwheat_i(i,ll) + swheat_i(i,ll) rhc(i,k) = rhc_i(i,ll) @@ -446,8 +449,8 @@ subroutine m_micro_run( im, lm, flipv, dt_i & DO K=0, LM ll = lm-k DO I = 1,IM - PLE(i,k) = prsi_i(i,ll) *.01 ! interface pressure in hPa - zet(i,k+1) = phii(i,ll) * (1.0/grav) + PLE(i,k) = prsi_i(i,ll) * 0.01_kp ! interface pressure in hPa + zet(i,k+1) = phii(i,ll) * onebg END DO END DO if (.not. skip_macro) then @@ -475,7 +478,6 @@ subroutine m_micro_run( im, lm, flipv, dt_i & omega(i,k) = omega_i(i,k) ncpl(i,k) = ncpl_io(i,k) ncpi(i,k) = ncpi_io(i,k) - ncpi(i,k) = ncpi_io(i,k) rnw(i,k) = rnw_io(i,k) snw(i,k) = snw_io(i,k) qgl(i,k) = qgl_io(i,k) @@ -491,9 +493,9 @@ subroutine m_micro_run( im, lm, flipv, dt_i & CNV_UPDF(i,k) = cf_upi(i,k) CNV_DQLDT(I,K) = CNV_DQLDT_i(I,k) CLCN(I,k) = CLCN_i(I,k) - CLLS(I,k) = max(CLLS_io(I,k)-CLCN_i(I,k),0.0) - PLO(i,k) = prsl_i(i,k)*0.01 - zlo(i,k) = phil(i,k) * (1.0/grav) + CLLS(I,k) = max(CLLS_io(I,k)-CLCN_i(I,k),zero) + PLO(i,k) = prsl_i(i,k)*0.01_kp + zlo(i,k) = phil(i,k) * onebg temp(i,k) = t_io(i,k) radheat(i,k) = lwheat_i(i,k) + swheat_i(i,k) rhc(i,k) = rhc_i(i,k) @@ -506,8 +508,8 @@ subroutine m_micro_run( im, lm, flipv, dt_i & END DO DO K=0, LM DO I = 1,IM - PLE(i,k) = prsi_i(i,k) *.01 ! interface pressure in hPa - zet(i,k+1) = phii(i,k) * (1.0/grav) + PLE(i,k) = prsi_i(i,k) * 0.01_kp ! interface pressure in hPa + zet(i,k+1) = phii(i,k) * onebg END DO END DO if (.not. skip_macro) then @@ -533,7 +535,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! endif ! DT_MOIST = dt_i - dt_r8 = dt_i + dt_kp = dt_i if (kdt == 1) then DO K=1, LM @@ -543,19 +545,19 @@ subroutine m_micro_run( im, lm, flipv, dt_i & & QICN(I,K), CLCN(I,K), NCPL(I,K), & & NCPI(I,K), qc_min) if (rnw(i,k) <= qc_min(1)) then - ncpr(i,k) = 0.0 + ncpr(i,k) = zero elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0), nmin) + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kp), nmin) endif if (snw(i,k) <= qc_min(2)) then - ncps(i,k) = 0.0 + ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = 0.0 + ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif enddo @@ -569,8 +571,8 @@ subroutine m_micro_run( im, lm, flipv, dt_i & DO I=1, IM DO K = LM-2, 10, -1 - If ((CNV_DQLDT(I,K) <= 1.0e-9) .and. & - & (CNV_DQLDT(I,K+1) > 1.0e-9)) then + If ((CNV_DQLDT(I,K) <= 1.0e-9_kp) .and. & + & (CNV_DQLDT(I,K+1) > 1.0e-9_kp)) then KCT(I) = K+1 exit end if @@ -649,8 +651,8 @@ subroutine m_micro_run( im, lm, flipv, dt_i & do l=lm-1,1,-1 do i=1,im - tx1 = 0.5 * (temp(i,l+1) + temp(i,l)) - kh(i,l) = 3.55e-7*tx1**2.5*(rgas*0.01) / ple(i,l) !kh molecule diff only needing refinement + tx1 = half * (temp(i,l+1) + temp(i,l)) + kh(i,l) = 3.55e-7_kp*tx1**2.5_kp*(rgas*0.01_kp) / ple(i,l) !kh molecule diff only needing refinement enddo end do do i=1,im @@ -659,38 +661,38 @@ subroutine m_micro_run( im, lm, flipv, dt_i & enddo do L=LM,1,-1 do i=1,im - blk_l(i,l) = 1.0 / ( 1.0/max(0.15*ZPBL(i),0.4*zlo(i,lm-1))& - & + 1.0/(zlo(i,l)*.4) ) - - SC_ICE(i,l) = 1.0 - NCPL(i,l) = MAX( NCPL(i,l), 0.) - NCPI(i,l) = MAX( NCPI(i,l), 0.) - RAD_CF(i,l) = max(0.0, min(CLLS(i,l)+CLCN(i,l), 1.0)) - if (iccn .ne. 1) then - CDNC_NUC(i,l) = 0.0 - INC_NUC(i,l) = 0.0 + blk_l(i,l) = one / ( one/max(0.15_kp*ZPBL(i),0.4_kp*zlo(i,lm-1))& + & + one/(zlo(i,l)*0.4_kp) ) + + SC_ICE(i,l) = one + NCPL(i,l) = MAX( NCPL(i,l), zero) + NCPI(i,l) = MAX( NCPI(i,l), zero) + RAD_CF(i,l) = max(zero, min(CLLS(i,l)+CLCN(i,l), one)) + if (iccn /= 1) then + CDNC_NUC(i,l) = zero + INC_NUC(i,l) = zero endif enddo end do ! T_ICE_ALL = TICE - 40.0 T_ICE_ALL = CLOUDPARAMS(33) + TICE - t_ice_denom = 1.0 / (tice - t_ice_all) + t_ice_denom = one / (tice - t_ice_all) do l=1,lm - rhdfdar8(l) = 1.e-8 - rhu00r8(l) = 0.95 + rhdfdar8(l) = 1.e-8_kp + rhu00r8(l) = 0.95_kp - ttendr8(l) = 0. - qtendr8(l) = 0. - cwtendr8(l) = 0. + ttendr8(l) = zero + qtendr8(l) = zero + cwtendr8(l) = zero - npccninr8(l) = 0. + npccninr8(l) = zero enddo do k=1,10 do l=1,lm - rndstr8(l,k) = 2.0e-7 + rndstr8(l,k) = 2.0e-7_kp enddo enddo @@ -722,18 +724,18 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! allocate(AERMASSMIX(IM,LM,15)) - if (iccn == 2) then + if ( iccn == 2) then AERMASSMIX(:,:,1:ntrcaer) = aerfld_i(:,:,1:ntrcaer) else - AERMASSMIX(:,:,1:5) = 1.e-6 - AERMASSMIX(:,:,6:15) = 2.e-14 + AERMASSMIX(:,:,1:5) = 1.0e-6_kp + AERMASSMIX(:,:,6:15) = 2.0e-14_kp end if !> - Call aerconversion1() call AerConversion1 (AERMASSMIX, AeroProps) deallocate(AERMASSMIX) use_average_v = .false. - if (USE_AV_V > 0.0) then + if (USE_AV_V > zero) then use_average_v = .true. end if @@ -744,58 +746,58 @@ subroutine m_micro_run( im, lm, flipv, dt_i & kcldtopcvn = KCT(I) - tausurf_gw = min(0.5*SQRT(TAUOROX(I)*TAUOROX(I) & - & + TAUOROY(I)*TAUOROY(I)), 10.0) + tausurf_gw = min(half*SQRT(TAUOROX(I)*TAUOROX(I) & + & + TAUOROY(I)*TAUOROY(I)), 10.0_kp) do k=1,lm - uwind_gw(k) = min(0.5*SQRT( U1(I,k)*U1(I,k) & - & + V1(I,k)*V1(I,k)), 50.0) + uwind_gw(k) = min(half*SQRT( U1(I,k)*U1(I,k) & + & + V1(I,k)*V1(I,k)), 50.0_kp) ! tausurf_gw =tausurf_gw + max (tausurf_gw, min(0.5*SQRT(TAUX(I , J)**2+TAUY(I , J)**2), 10.0)*BKGTAU) !adds a minimum value from unresolved sources - pm_gw(k) = 100.0*PLO(I,k) + pm_gw(k) = 100.0_kp*PLO(I,k) tm_gw(k) = TEMP(I,k) - nm_gw(k) = 0.0 + nm_gw(k) = zero rho_gw(k) = pm_gw(k) /(RGAS*tm_gw(k)) ter8(k) = TEMP(I,k) - plevr8(k) = 100.*PLO(I,k) + plevr8(k) = 100.0_kp*PLO(I,k) ndropr8(k) = NCPL(I,k) qir8(k) = QILS(I,k) + QICN(I,k) qcr8(k) = QLLS(I,k) + QLCN(I,k) qcaux(k) = qcr8(k) - npccninr8(k) = 0.0 - naair8(k) = 0.0 + npccninr8(k) = zero + naair8(k) = zero - npre8(k) = 0.0 + npre8(k) = zero - if (RAD_CF(I,k) > 0.01 .and. qir8(k) > 0.0) then + if (RAD_CF(I,k) > 0.01_kp .and. qir8(k) > zero) then npre8(k) = NPRE_FRAC*NCPI(I,k) else - npre8(k) = 0.0 + npre8(k) = zero endif omegr8(k) = OMEGA(I,k) - lc_turb(k) = max(blk_l(I,k), 50.0) + lc_turb(k) = max(blk_l(I,k), 50.0_kp) ! rad_cooling(k) = RADheat(I,k) - if (npre8(k) > 0.0 .and. qir8(k) > 0.0) then - dpre8(k) = ( qir8(k)/(6.0*npre8(k)*900.0*PI))**(1.0/3.0) + if (npre8(k) > zero .and. qir8(k) > zero) then + dpre8(k) = ( qir8(k)/(6.0_kp*npre8(k)*900.0_kp*PI))**(one/3.0_kp) else - dpre8(k) = 1.0e-9 + dpre8(k) = 1.0e-9_kp endif wparc_ls(k) = -omegr8(k) / (rho_gw(k)*GRAV) & & + cpbg * radheat(i,k) ! & + cpbg * rad_cooling(k) enddo do k=0,lm - pi_gw(k) = 100.0*PLE(I,k) - rhoi_gw(k) = 0.0 - ni_gw(k) = 0.0 - ti_gw(k) = 0.0 + pi_gw(k) = 100.0_kp*PLE(I,k) + rhoi_gw(k) = zero + ni_gw(k) = zero + ti_gw(k) = zero enddo @@ -808,37 +810,37 @@ subroutine m_micro_run( im, lm, flipv, dt_i & & ti_gw, nm_gw, q1(i,:)) do k=1,lm - nm_gw(k) = max(nm_gw(k), 0.005) + nm_gw(k) = max(nm_gw(k), 0.005_kp) h_gw(k) = k_gw*rho_gw(k)*uwind_gw(k)*nm_gw(k) - if (h_gw(K) > 0.0) then - h_gw(K) = sqrt(2.0*tausurf_gw/h_gw(K)) + if (h_gw(K) > zero) then + h_gw(K) = sqrt(2.0_kp*tausurf_gw/h_gw(K)) end if - wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133 + wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133_kp - wparc_cgw(k) = 0.0 + wparc_cgw(k) = zero end do !> - Subgrid variability from convective sources according to Barahona et al. 2014 (in preparation) if (kcldtopcvn > 20) then - ksa1 = 1.0 + ksa1 = one Nct = nm_gw(kcldtopcvn) - Wct = max(CNV_CVW(I,kcldtopcvn), 0.0) + Wct = max(CNV_CVW(I,kcldtopcvn), zero) fcn = maxval(CNV_UPDF(I,kcldtopcvn:LM)) do k=1,kcldtopcvn c2_gw = (nm_gw(k) + Nct) / Nct - wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56* & - & 1.806*c2_gw*c2_gw)*Wct*0.133 + wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56_kp* & + & 1.806_kp*c2_gw*c2_gw)*Wct*0.133_kp enddo end if do k=1,lm - dummyW(k) = 0.133*k_gw*uwind_gw(k)/nm_gw(k) + dummyW(k) = 0.133_kp*k_gw*uwind_gw(k)/nm_gw(k) enddo do K=1, LM-5, 1 @@ -848,8 +850,8 @@ subroutine m_micro_run( im, lm, flipv, dt_i & end do do l=1,min(k,lm-5) - wparc_cgw(l) = 0.0 - wparc_gw(l) = 0.0 + wparc_cgw(l) = zero + wparc_gw(l) = zero enddo @@ -858,25 +860,25 @@ subroutine m_micro_run( im, lm, flipv, dt_i & kbmin = min(kbmin, LM-1) - 4 do K = 1, LM wparc_turb(k) = KH(I,k) / lc_turb(k) - dummyW(k) = 10.0 + dummyW(k) = 10.0_kp enddo - if (FRLAND(I) < 0.1 .and. ZPBL(I) < 800.0 .and. & - & TEMP(I,LM) < 298.0 .and. TEMP(I,LM) > 274.0 ) then + if (FRLAND(I) < 0.1_kp .and. ZPBL(I) < 800.0_kp .and. & + & TEMP(I,LM) < 298.0_kp .and. TEMP(I,LM) > 274.0_kp) then do K = 1, LM - dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01,10.0),-10.0) - dummyW(k) = 1.0 / (1.0+exp(dummyW(k))) + dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01_kp, 10.0_kp),-10.0_kp) + dummyW(k) = one / (one+exp(dummyW(k))) enddo maxkh = max(maxval(KH(I,kbmin:LM-1)*nm_gw(kbmin:LM-1)/ & - & 0.17), 0.3) + & 0.17_kp), 0.3_kp) do K = 1, LM - wparc_turb(k) = (1.0-dummyW(k))*wparc_turb(k) & + wparc_turb(k) = (one-dummyW(k))*wparc_turb(k) & & + dummyW(k)*maxkh enddo end if - wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2) + wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2_kp) @@ -894,11 +896,11 @@ subroutine m_micro_run( im, lm, flipv, dt_i & do K = 1, LM - if (plevr8(K) > 70.0) then + if (plevr8(K) > 70.0_kp) then - ccn_diag(1) = 0.001 - ccn_diag(2) = 0.004 - ccn_diag(3) = 0.01 + ccn_diag(1) = 0.001_kp + ccn_diag(2) = 0.004_kp + ccn_diag(3) = 0.01_kp if (K > 2 .and. K <= LM-2) then tauxr8 = (ter8(K-1) + ter8(K+1) + ter8(K)) * oneb3 @@ -913,8 +915,8 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! call init_Aer(AeroAux_b) ! endif - pfrz_inc_r8(k) = 0.0 - rh1_r8 = 0.0 !related to cnv_dql_dt, needed to changed soon + pfrz_inc_kp(k) = zero + rh1_kp = zero !related to cnv_dql_dt, needed to changed soon ! if (lprnt) write(0,*)' bef aero npccninr8=',npccninr8(k),' k=',k & ! &,' ccn_param=',ccn_param,' in_param=',in_param & @@ -930,12 +932,12 @@ subroutine m_micro_run( im, lm, flipv, dt_i & & sc_icer8(k), dust_immr8(K), dust_depr8(k), & & dust_dhfr8(k), nlimicer8(k), use_average_v, & & CCN_PARAM, IN_PARAM, fdust_drop, & - & fsoot_drop,pfrz_inc_r8(K),sigma_nuc_r8, rh1_r8, & + & fsoot_drop,pfrz_inc_kp(K),sigma_nuc_kp, rh1_kp, & & size(ccn_diag)) ! & size(ccn_diag), lprnt) ! if (lprnt) write(0,*)' aft aero npccninr8=',npccninr8(k),' k=',k - if (npccninr8(k) < 1.0e-12) npccninr8(k) = 0.0 + if (npccninr8(k) < 1.0e-12_kp) npccninr8(k) = zero ! CCN01(I,K) = max(ccn_diag(1)*1e-6, 0.0) ! CCN04(I,K) = max(ccn_diag(2)*1e-6, 0.0) @@ -944,63 +946,63 @@ subroutine m_micro_run( im, lm, flipv, dt_i & else - ccn_diag(:) = 0.0 - smaxliq(K) = 0.0 - swparc(K) = 0.0 - smaxicer8(K) = 0.0 - nheticer8(K) = 0.0 - sc_icer8(K) = 2.0 -! sc_icer8(K) = 1.0 - naair8(K) = 0.0 - npccninr8(K) = 0.0 - nlimicer8(K) = 0.0 - nhet_immr8(K) = 0.0 - dnhet_immr8(K) = 0.0 - nhet_depr8(K) = 0.0 - nhet_dhfr8(K) = 0.0 - dust_immr8(K) = 0.0 - dust_depr8(K) = 0.0 - dust_dhfr8(K) = 0.0 + ccn_diag(:) = zero + smaxliq(K) = zero + swparc(K) = zero + smaxicer8(K) = zero + nheticer8(K) = zero + sc_icer8(K) = 2.0_kp +! sc_icer8(K) = 1.0d0 + naair8(K) = zero + npccninr8(K) = zero + nlimicer8(K) = zero + nhet_immr8(K) = zero + dnhet_immr8(K) = zero + nhet_depr8(K) = zero + nhet_dhfr8(K) = zero + dust_immr8(K) = zero + dust_depr8(K) = zero + dust_dhfr8(K) = zero end if ! SMAXL(I,k) = smaxliq(k) * 100.0 ! SMAXI(I,k) = smaxicer8(k) * 100.0 - NHET_NUC(I,k) = nheticer8(k) * 1e-6 - NLIM_NUC(I,k) = nlimicer8(k) * 1e-6 - SC_ICE(I,k) = min(max(sc_icer8(k),1.0),2.0) + NHET_NUC(I,k) = nheticer8(k) * 1.0e-6_kp + NLIM_NUC(I,k) = nlimicer8(k) * 1.0e-6_kp + SC_ICE(I,k) = min(max(sc_icer8(k),one),2.0_kp) ! SC_ICE(I,k) = min(max(sc_icer8(k),1.0),1.2) ! if(temp(i,k) < T_ICE_ALL) SC_ICE(i,k) = max(SC_ICE(I,k), 1.2) ! if(temp(i,k) < T_ICE_ALL) SC_ICE(i,k) = max(SC_ICE(I,k), 1.5) ! if(temp(i,k) > T_ICE_ALL) SC_ICE(i,k) = 1.0 ! if(temp(i,k) > TICE) SC_ICE(i,k) = rhc(i,k) ! - if(iccn == 0) then + if (iccn == 0) then if(temp(i,k) < T_ICE_ALL) then ! SC_ICE(i,k) = max(SC_ICE(I,k), 1.2) - SC_ICE(i,k) = max(SC_ICE(I,k), 1.5) + SC_ICE(i,k) = max(SC_ICE(I,k), 1.5_kp) elseif(temp(i,k) > TICE) then SC_ICE(i,k) = rhc(i,k) else ! SC_ICE(i,k) = 1.0 ! tx1 = max(SC_ICE(I,k), 1.2) - tx1 = max(SC_ICE(I,k), 1.5) + tx1 = max(SC_ICE(I,k), 1.5_kp) SC_ICE(i,k) = ((tice-temp(i,k))*tx1 + (temp(i,k)-t_ice_all)*rhc(i,k)) & - * t_ice_denom + * t_ice_denom endif endif - if (iccn .ne. 1) then + if (iccn /= 1) then CDNC_NUC(I,k) = npccninr8(k) INC_NUC (I,k) = naair8(k) endif - NHET_IMM(I,k) = max(nhet_immr8(k), 0.0) - DNHET_IMM(I,k) = max(dnhet_immr8(k), 0.0) - NHET_DEP(I,k) = nhet_depr8(k) * 1e-6 - NHET_DHF(I,k) = nhet_dhfr8(k) * 1e-6 - DUST_IMM(I,k) = max(dust_immr8(k), 0.0)*1e-6 - DUST_DEP(I,k) = max(dust_depr8(k), 0.0)*1e-6 - DUST_DHF(I,k) = max(dust_dhfr8(k), 0.0)*1e-6 - WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8 + NHET_IMM(I,k) = max(nhet_immr8(k), zero) + DNHET_IMM(I,k) = max(dnhet_immr8(k), zero) + NHET_DEP(I,k) = nhet_depr8(k) * 1.0e-6_kp + NHET_DHF(I,k) = nhet_dhfr8(k) * 1.0e-6_kp + DUST_IMM(I,k) = max(dust_immr8(k), zero)*1.0e-6_kp + DUST_DEP(I,k) = max(dust_depr8(k), zero)*1.0e-6_kp + DUST_DHF(I,k) = max(dust_dhfr8(k), zero)*1.0e-6_kp + WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8_kp SIGW_GW (I,k) = wparc_gw(k) * wparc_gw(k) SIGW_CNV (I,k) = wparc_cgw(k) * wparc_cgw(k) SIGW_TURB (I,k) = wparc_turb(k) * wparc_turb(k) @@ -1113,24 +1115,24 @@ subroutine m_micro_run( im, lm, flipv, dt_i & do k=1,lm do i=1,im - if (CNV_MFD(i,k) > 1.0e-6) then - tx1 = 1.0 / CNV_MFD(i,k) + if (CNV_MFD(i,k) > 1.0e-6_kp) then + tx1 = one / CNV_MFD(i,k) CNV_NDROP(i,k) = CNV_NDROP(i,k) * tx1 CNV_NICE(i,k) = CNV_NICE(i,k) * tx1 else - CNV_NDROP(i,k) = 0.0 - CNV_NICE(i,k) = 0.0 + CNV_NDROP(i,k) = zero + CNV_NICE(i,k) = zero endif ! temp(i,k) = th1(i,k) * PK(i,k) - RAD_CF(i,k) = min(CLLS(i,k)+CLCN(i,k), 1.0) + RAD_CF(i,k) = min(CLLS(i,k)+CLCN(i,k), one) ! - if (iccn .ne. 1) then - if (PFRZ(i,k) > 0.0) then + if (iccn /= 1) then + if (PFRZ(i,k) > zero) then INC_NUC(i,k) = INC_NUC(i,k) * PFRZ(i,k) NHET_NUC(i,k) = NHET_NUC(i,k) * PFRZ(i,k) else - INC_NUC(i,k) = 0.0 - NHET_NUC(i,k) = 0.0 + INC_NUC(i,k) = zero + NHET_NUC(i,k) = zero endif endif @@ -1187,21 +1189,21 @@ subroutine m_micro_run( im, lm, flipv, dt_i & QL_TOT(i,k) = QLCN(i,k) + QLLS(i,k) QI_TOT(i,k) = QICN(i,k) + QILS(i,k) ! Anning if negative, borrow water and ice from vapor 11/23/2016 - if (QL_TOT(i,k) < 0.0) then + if (QL_TOT(i,k) < zero) then Q1(i,k) = Q1(i,k) + QL_TOT(i,k) TEMP(i,k) = TEMP(i,k) - lvbcp*QL_TOT(i,k) - QL_TOT(i,k) = 0.0 + QL_TOT(i,k) = zero endif - if (QI_TOT(i,k) < 0.0) then + if (QI_TOT(i,k) < zero) then Q1(i,k) = Q1(i,k) + QI_TOT(i,k) TEMP(i,k) = TEMP(i,k) - lsbcp*QI_TOT(i,k) - QI_TOT(i,k) = 0.0 + QI_TOT(i,k) = zero endif QTOT = QL_TOT(i,k) + QI_TOT(i,k) - if (QTOT > 0.0) then - FQA(i,k) = min(max(QCNTOT / QTOT, 0.0), 1.0) + if (QTOT > zero) then + FQA(i,k) = min(max(QCNTOT / QTOT, zero), one) else - FQA(i,k) = 0.0 + FQA(i,k) = zero endif enddo enddo @@ -1214,35 +1216,35 @@ subroutine m_micro_run( im, lm, flipv, dt_i & !! Gettelman (2008) microphysics \cite Morrison_2008 do I=1,IM - LS_SNR(i) = 0.0 - LS_PRC2(i) = 0.0 + LS_SNR(i) = zero + LS_PRC2(i) = zero nbincontactdust = 1 do l=1,10 do k=1,lm - naconr8(k,l) = 0.0 - rndstr8(k,l) = 2.0e-7 + naconr8(k,l) = zero + rndstr8(k,l) = 2.0e-7_kp enddo enddo do k=1,lm - npccninr8(k) = 0.0 - naair8(k) = 0.0 - omegr8(k) = 0.0 + npccninr8(k) = zero + naair8(k) = zero + omegr8(k) = zero ! tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) - tx1 = MIN(CLLS(I,k) + CLCN(I,k), 1.00) - if (tx1 > 0.0) then - cldfr8(k) = min(max(tx1, 0.00001), 1.0) + tx1 = MIN(CLLS(I,k) + CLCN(I,k), one) + if (tx1 > zero) then + cldfr8(k) = min(max(tx1, 0.00001_kp), one) else - cldfr8(k) = 0.0 + cldfr8(k) = zero endif if (temp(i,k) > tice) then liqcldfr8(k) = cldfr8(k) - icecldfr8(k) = 0.0 + icecldfr8(k) = zero elseif (temp(i,k) <= t_ice_all) then - liqcldfr8(k) = 0.0 + liqcldfr8(k) = zero icecldfr8(k) = cldfr8(k) else icecldfr8(k) = cldfr8(k) * (tice - temp(i,k))/(tice-t_ice_all) @@ -1256,23 +1258,23 @@ subroutine m_micro_run( im, lm, flipv, dt_i & qcr8(k) = QL_TOT(I,k) qir8(k) = QI_TOT(I,k) - ncr8(k) = MAX(NCPL(I,k), 0.0) - nir8(k) = MAX(NCPI(I,k), 0.0) + ncr8(k) = MAX(NCPL(I,k), zero) + nir8(k) = MAX(NCPI(I,k), zero) qrr8(k) = rnw(I,k) qsr8(k) = snw(I,k) qgr8(k) = qgl(I,k) - nrr8(k) = MAX(NCPR(I,k), 0.0) - nsr8(k) = MAX(NCPS(I,k), 0.0) - ngr8(k) = MAX(ncgl(I,k), 0.0) + nrr8(k) = MAX(NCPR(I,k), zero) + nsr8(k) = MAX(NCPS(I,k), zero) + ngr8(k) = MAX(ncgl(I,k), zero) naair8(k) = INC_NUC(I,k) npccninr8(k) = CDNC_NUC(I,k) - if (cldfr8(k) >= 0.001) then + if (cldfr8(k) >= 0.001_kp) then nimmr8(k) = min(DNHET_IMM(I,k),ncr8(k)/(cldfr8(k)*DT_MOIST)) else - nimmr8(k) = 0.0 + nimmr8(k) = zero endif @@ -1288,7 +1290,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & nbincontactdust = naux endif naconr8(K, 1:naux) = AeroAux_b%num(1:naux) - rndstr8(K, 1:naux) = AeroAux_b%dpg(1:naux) * 0.5 + rndstr8(K, 1:naux) = AeroAux_b%dpg(1:naux) * half ! The following moved inside of if(fprcp <= 0) then loop ! Get black carbon properties for contact ice nucleation @@ -1297,11 +1299,11 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! naux = AeroAux_b%nmods ! rnsootr8 (K) = sum(AeroAux_b%dpg(1:naux))/naux - pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0 - rpdelr8(k) = 1. / pdelr8(k) - plevr8(k) = 100. * PLO(I,k) + pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0_kp + rpdelr8(k) = one / pdelr8(k) + plevr8(k) = 100.0_kp * PLO(I,k) zmr8(k) = ZLO(I,k) - ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.e-10) + ficer8(k) = qir8(k) / (qcr8(k)+qir8(k) + 1.0e-10_kp) omegr8(k) = WSUB(I,k) ! alphar8(k) = max(alpht_x(i,k)/maxval(alpht_x(i,:))*8.,0.5) ! alphar8(k) = qcvar2 @@ -1309,12 +1311,12 @@ subroutine m_micro_run( im, lm, flipv, dt_i & END DO do k=1,lm+1 - pintr8(k) = PLE(I,k-1) * 100.0 + pintr8(k) = PLE(I,k-1) * 100.0_kp kkvhr8(k) = KH(I,k-1) END DO lev_sed_strt = 0 - tx1 = 1.0 / pintr8(lm+1) + tx1 = one / pintr8(lm+1) do k=1,lm if (plevr8(k)*tx1 < sig_sed_strt) then lev_sed_strt(1) = k @@ -1356,7 +1358,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & enddo call mmicro_pcond ( ncolmicro, ncolmicro, & - & dt_r8, ter8, ttendr8, & + & dt_kp, ter8, ttendr8, & & ncolmicro, LM , qvr8, & & qtendr8, cwtendr8, qcr8, qir8, ncr8, nir8, & & abs(fprcp), qrr8, qsr8, nrr8, nsr8, & @@ -1394,29 +1396,29 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! if (lprint) write(0,*)' prectr8=',prectr8(1), & ! & ' precir8=',precir8(1) - LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) - LS_SNR(I) = max(1000.*precir8(1), 0.0) + LS_PRC2(I) = max(1000.0_kp*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_kp*precir8(1), zero) do k=1,lm - QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 - QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 - Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_R8 + QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_kp + QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_kp + Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_kp ! if(lprnt .and. i == ipr) write(0,*)' k=',k,' q1aftm=',q1(i,k) & ! &,' qvlatr8=',qvlatr8(k) - TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp + TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_kp*onebcp - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, 0.0) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, 0.0) + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_kp, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_kp, zero) rnw(I,k) = qrr8(k) snw(I,k) = qsr8(k) NCPR(I,k) = nrr8(k) NCPS(I,k) = nsr8(k) - CLDREFFL(I,k) = min(max(effcr8(k), 10.), 150.) - CLDREFFI(I,k) = min(max(effir8(k), 20.), 150.) - CLDREFFR(I,k) = max(droutr8(k)*0.5*1.e6, 150.) - CLDREFFS(I,k) = max(0.192*dsoutr8(k)*0.5*1.e6, 250.) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_kp), 150.0_kp) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_kp), 150.0_kp) + CLDREFFR(I,k) = max(droutr8(k)*0.5_kp*1.0e6_kp, 150.0_kp) + CLDREFFS(I,k) = max(0.192_kp*dsoutr8(k)*0.5_kp*1.0e6_kp, 250.0_kp) enddo ! K loop @@ -1424,7 +1426,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! -------- ! if (lprnt .and. i == ipr) then ! write(0,*)' bef micro_mg_tend ter8= ', ter8(:) -! write(0,*)' bef micro_mg_tend qvr8= ', qvr8(:),'dt_r8=',dt_r8 +! write(0,*)' bef micro_mg_tend qvr8= ', qvr8(:),'dt_kp=',dt_kp ! write(0,*)' bef micro_mg_tend rhr8= ', rhr8(:) ! endif lprint = lprnt .and. i == ipr @@ -1443,7 +1445,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! endif call micro_mg_tend2_0 ( & - & ncolmicro, lm, dt_r8, & + & ncolmicro, lm, dt_kp, & & ter8, qvr8, & & qcr8, qir8, & & ncr8, nir8, & @@ -1498,25 +1500,25 @@ subroutine m_micro_run( im, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, & & lev_sed_strt) ! - LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) - LS_SNR(I) = max(1000.*precir8(1), 0.0) + LS_PRC2(I) = max(1000.0_kp*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_kp*precir8(1), zero) do k=1,lm - QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 - QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 - Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_R8 - TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp - rnw(I,k) = rnw(I,k) + qrtend(k)*dt_r8 - snw(I,k) = snw(I,k) + qstend(k)*dt_r8 - - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, 0.0) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, 0.0) - NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, 0.0) - NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, 0.0) - - CLDREFFL(I,k) = min(max(effcr8(k), 10.),150.) - CLDREFFI(I,k) = min(max(effir8(k), 20.),150.) - CLDREFFR(I,k) = max(reff_rain(k),150.) - CLDREFFS(I,k) = max(reff_snow(k),250.) + QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_kp + QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_kp + Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_kp + TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_kp*onebcp + rnw(I,k) = rnw(I,k) + qrtend(k)*dt_kp + snw(I,k) = snw(I,k) + qstend(k)*dt_kp + + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_kp, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_kp, zero) + NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_kp, zero) + NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_kp, zero) + + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_kp), 150.0_kp) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_kp), 150.0_kp) + CLDREFFR(I,k) = max(reff_rain(k), 150.0_kp) + CLDREFFS(I,k) = max(reff_snow(k), 250.0_kp) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1524,13 +1526,13 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! write(0,*)' aft micro_mg_tend LS_PRC2= ', LS_PRC2(i),' ls_snr=',ls_snr(i) ! endif else - LS_PRC2(I) = 0. - LS_SNR(I) = 0. + LS_PRC2(I) = zero + LS_SNR(I) = zero do k=1,lm - CLDREFFL(I,k) = 10. - CLDREFFI(I,k) = 50. - CLDREFFR(I,k) = 1000. - CLDREFFS(I,k) = 250. + CLDREFFL(I,k) = 10.0_kp + CLDREFFI(I,k) = 50.0_kp + CLDREFFR(I,k) = 1000.0_kp + CLDREFFS(I,k) = 250.0_kp enddo ! K loop endif ! @@ -1556,7 +1558,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & !> - Call micro_mg3_0::micro_mg_tend(), which is the main microphysics routine to !! calculate microphysical processes and other utilities. call micro_mg_tend3_0 ( & - & ncolmicro, lm, dt_r8, & + & ncolmicro, lm, dt_kp, & & ter8, qvr8, & & qcr8, qir8, & & ncr8, nir8, & @@ -1635,28 +1637,28 @@ subroutine m_micro_run( im, lm, flipv, dt_i & & prer_evap, xlat(i), xlon(i), lprint, iccn, & & lev_sed_strt) - LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) - LS_SNR(I) = max(1000.*precir8(1), 0.0) + LS_PRC2(I) = max(1000.0_kp*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0_kp*precir8(1), zero) do k=1,lm - QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 - QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 - Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_R8 - TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp - rnw(I,k) = rnw(I,k) + qrtend(k)*dt_r8 - snw(I,k) = snw(I,k) + qstend(k)*dt_r8 - qgl(I,k) = qgl(I,k) + qgtend(k)*dt_r8 - - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, 0.0) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, 0.0) - NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, 0.0) - NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, 0.0) - NCGL(I,k) = max(NCGL(I,k) + ngtend(k)*dt_r8, 0.0) - - CLDREFFL(I,k) = min(max(effcr8(k), 10.),150.) - CLDREFFI(I,k) = min(max(effir8(k), 20.),150.) - CLDREFFR(I,k) = max(reff_rain(k),150.) - CLDREFFS(I,k) = max(reff_snow(k),250.) - CLDREFFG(I,k) = max(reff_grau(k),250.) + QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_kp + QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_kp + Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_kp + TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_kp*onebcp + rnw(I,k) = rnw(I,k) + qrtend(k)*dt_kp + snw(I,k) = snw(I,k) + qstend(k)*dt_kp + qgl(I,k) = qgl(I,k) + qgtend(k)*dt_kp + + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_kp, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_kp, zero) + NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_kp, zero) + NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_kp, zero) + NCGL(I,k) = max(NCGL(I,k) + ngtend(k)*dt_kp, zero) + + CLDREFFL(I,k) = min(max(effcr8(k), 10.0_kp), 150.0_kp) + CLDREFFI(I,k) = min(max(effir8(k), 20.0_kp), 150.0_kp) + CLDREFFR(I,k) = max(reff_rain(k), 150.0_kp) + CLDREFFS(I,k) = max(reff_snow(k), 250.0_kp) + CLDREFFG(I,k) = max(reff_grau(k), 250.0_kp) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1664,14 +1666,14 @@ subroutine m_micro_run( im, lm, flipv, dt_i & ! write(0,*)' aft micro_mg_tend LS_PRC2= ', LS_PRC2(i),' ls_snr=',ls_snr(i) ! endif else - LS_PRC2(I) = 0. - LS_SNR(I) = 0. + LS_PRC2(I) = zero + LS_SNR(I) = zero do k=1,lm - CLDREFFL(I,k) = 10. - CLDREFFI(I,k) = 50. - CLDREFFR(I,k) = 1000. - CLDREFFS(I,k) = 250. - CLDREFFG(I,k) = 250. + CLDREFFL(I,k) = 10.0_kp + CLDREFFI(I,k) = 50.0_kp + CLDREFFR(I,k) = 1000.0_kp + CLDREFFS(I,k) = 250.0_kp + CLDREFFG(I,k) = 250.0_kp enddo ! K loop endif endif @@ -1697,19 +1699,19 @@ subroutine m_micro_run( im, lm, flipv, dt_i & QL_TOT(I,K) = QLLS(I,K) + QLCN(I,K) QI_TOT(I,K) = QILS(I,K) + QICN(I,K) if (rnw(i,k) <= qc_min(1)) then - ncpl(i,k) = 0.0 - elseif (ncpl(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpl(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0), nmin) + ncpr(i,k) = zero + elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kp), nmin) endif if (snw(i,k) <= qc_min(2)) then - ncpl(i,k) = 0.0 + ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = 0.0 + ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif enddo enddo @@ -1737,19 +1739,19 @@ subroutine m_micro_run( im, lm, flipv, dt_i & QI_TOT(I,K) = QILS(I,K) + QICN(I,K) ! if (rnw(i,k) <= qc_min(1)) then - ncpl(i,k) = 0.0 - elseif (ncpl(i,k) <= nmin) then ! make sure NL > 0 if Q >0 - ncpl(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0), nmin) + ncpr(i,k) = zero + elseif (ncpr(i,k) <= nmin) then ! make sure NL > 0 if Q >0 + ncpr(i,k) = max(rnw(i,k) / (fourb3 * PI *RL_cub*997.0_kp), nmin) endif if (snw(i,k) <= qc_min(2)) then - ncpl(i,k) = 0.0 + ncps(i,k) = zero elseif (ncps(i,k) <= nmin) then - ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncps(i,k) = max(snw(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif if (qgl(i,k) <= qc_min(2)) then - ncgl(i,k) = 0.0 + ncgl(i,k) = zero elseif (ncgl(i,k) <= nmin) then - ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0), nmin) + ncgl(i,k) = max(qgl(i,k) / (fourb3 * PI *RL_cub*500.0_kp), nmin) endif enddo enddo @@ -1763,8 +1765,8 @@ subroutine m_micro_run( im, lm, flipv, dt_i & do K= 1, LM do I=1,IM - if (QI_TOT(i,k) <= 0.0) NCPI(i,k) = 0.0 - if (QL_TOT(i,k) <= 0.0) NCPL(i,k) = 0.0 + if (QI_TOT(i,k) <= zero) NCPI(i,k) = zero + if (QL_TOT(i,k) <= zero) NCPL(i,k) = zero end do end do @@ -1796,7 +1798,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & DO K=1, LM ll = lm-k+1 DO I = 1,IM - CLLS_io(i,k) = max(0.0, min(CLLS(i,ll)+CLCN(i,ll),1.0)) + CLLS_io(i,k) = max(zero, min(CLLS(i,ll)+CLCN(i,ll),one)) enddo enddo else @@ -1827,7 +1829,7 @@ subroutine m_micro_run( im, lm, flipv, dt_i & if (skip_macro) then DO K=1, LM DO I = 1,IM - CLLS_io(i,k) = max(0.0, min(CLLS(i,k)+CLCN(i,k),1.0)) + CLLS_io(i,k) = max(zero, min(CLLS(i,k)+CLCN(i,k),one)) enddo enddo else @@ -1841,12 +1843,12 @@ subroutine m_micro_run( im, lm, flipv, dt_i & DO I = 1,IM tx1 = LS_PRC2(i) + LS_SNR(i) - rn_o(i) = tx1 * dt_i * 0.001 + rn_o(i) = tx1 * dt_i * 0.001_kp if (rn_o(i) < rainmin) then - sr_o(i) = 0. + sr_o(i) = zero else - sr_o(i) = LS_SNR(i) / tx1 + sr_o(i) = max(zero, min(one, LS_SNR(i)/tx1)) endif ENDDO @@ -1894,6 +1896,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & use physcons, grav => con_g, cp => con_cp, rgas => con_rd, & fv => con_fvirt implicit none + integer, parameter :: kp = kind_phys !----------------------------------------------------------------------- ! Compute profiles of background state quantities for the multiple ! gravity wave drag parameterization. @@ -1917,7 +1920,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & real(kind=kind_phys), intent(out) :: nm(pcols,pver) real(kind=kind_phys), parameter :: r=rgas, cpair=cp, g=grav, & - oneocp=1.0/cp, n2min=1.e-8 + oneocp=1.0_kp/cp, n2min=1.0e-8_kp !---------------------------Local storage------------------------------- integer :: ix,kx @@ -1933,15 +1936,15 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & kx = 0 do ix = 1, ncol ti(ix,kx) = t(ix,kx+1) - rhoi(ix,kx) = pi(ix,kx) / (r*(ti(ix,kx)*(1.0+fv*sph(ix,kx+1)))) + rhoi(ix,kx) = pi(ix,kx) / (r*(ti(ix,kx)*(1.0_kp+fv*sph(ix,kx+1)))) ni(ix,kx) = sqrt (g*g / (cpair*ti(ix,kx))) end do ! Interior points use centered differences do kx = 1, pver-1 do ix = 1, ncol - ti(ix,kx) = 0.5 * (t(ix,kx) + t(ix,kx+1)) - rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0+0.5*fv*(sph(ix,kx)+sph(ix,kx+1)))) + ti(ix,kx) = 0.5_kp * (t(ix,kx) + t(ix,kx+1)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0_kp+0.5_kp*fv*(sph(ix,kx)+sph(ix,kx+1)))) dtdp = (t(ix,kx+1)-t(ix,kx)) / (pm(ix,kx+1)-pm(ix,kx)) n2 = g*g/ti(ix,kx) * (oneocp - rhoi(ix,kx)*dtdp) ni(ix,kx) = sqrt (max (n2min, n2)) @@ -1953,7 +1956,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & kx = pver do ix = 1, ncol ti(ix,kx) = t(ix,kx) - rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0+fv*sph(ix,kx))) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0_kp+fv*sph(ix,kx))) ni(ix,kx) = ni(ix,kx-1) end do @@ -1962,7 +1965,7 @@ subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, & !----------------------------------------------------------------------------- do kx=1,pver do ix=1,ncol - nm(ix,kx) = 0.5 * (ni(ix,kx-1) + ni(ix,kx)) + nm(ix,kx) = 0.5_kp * (ni(ix,kx-1) + ni(ix,kx)) end do end do @@ -1985,7 +1988,7 @@ subroutine find_cldtop(ncol, pver, cf, kcldtop) ibot = pver-1 kcldtop = ibot+1 kuppest = 20 - cfcrit = 1e-2 + cfcrit = 1.0d-2 do k = kuppest , ibot diff --git a/physics/m_micro.meta b/physics/m_micro.meta index 00b0b39f3..f61e6511f 100644 --- a/physics/m_micro.meta +++ b/physics/m_micro.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = m_micro + type = scheme + dependencies = aer_cloud.F,aerclm_def.F,cldmacro.F,cldwat2m_micro.F,machine.F,micro_mg_utils.F90,micro_mg2_0.F90,micro_mg3_0.F90,physcons.F90,wv_saturation.F + +######################################################################## [ccpp-arg-table] name = m_micro_init type = scheme @@ -292,11 +298,6 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = m_micro_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = m_micro_run diff --git a/physics/m_micro_interstitial.meta b/physics/m_micro_interstitial.meta index 24fccdef0..ec0944f28 100644 --- a/physics/m_micro_interstitial.meta +++ b/physics/m_micro_interstitial.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = m_micro_pre_init +[ccpp-table-properties] + name = m_micro_pre type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -289,14 +290,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = m_micro_pre_finalize - type = scheme - -######################################################################## -[ccpp-arg-table] - name = m_micro_post_init +[ccpp-table-properties] + name = m_micro_post type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -505,7 +502,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = m_micro_post_finalize - type = scheme diff --git a/physics/machine.meta b/physics/machine.meta index d93f50e09..a000aa469 100644 --- a/physics/machine.meta +++ b/physics/machine.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = machine + type = module + dependencies = + +######################################################################## [ccpp-arg-table] name = machine type = module diff --git a/physics/maximum_hourly_diagnostics.meta b/physics/maximum_hourly_diagnostics.meta index 5146ce2f0..48223113c 100644 --- a/physics/maximum_hourly_diagnostics.meta +++ b/physics/maximum_hourly_diagnostics.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = maximum_hourly_diagnostics + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = maximum_hourly_diagnostics_run type = scheme diff --git a/physics/micro_mg3_0.F90 b/physics/micro_mg3_0.F90 index 6164cf544..636293b86 100644 --- a/physics/micro_mg3_0.F90 +++ b/physics/micro_mg3_0.F90 @@ -324,7 +324,7 @@ subroutine micro_mg_init( & !----------------------------------------------------------------------- - dcs = micro_mg_dcs * 1.0e-6 + dcs = micro_mg_dcs * 1.0e-6_r8 ts_au_min = ts_auto(1) ts_au = ts_auto(2) qcvar = mg_qcvar @@ -613,7 +613,6 @@ subroutine micro_mg_tend ( & integer, intent(in) :: iccn !< flag for IN and CCN forcing for Morrison-Gettelman microphysics - ! used for scavenging ! Inputs for aerosol activation real(r8), intent(inout) :: naai(mgncol,nlev) !< ice nucleation number (from microp_aero_ts) (1/kg) @@ -1091,7 +1090,7 @@ subroutine micro_mg_tend ( & ! logical, parameter :: do_ice_gmao=.true., do_liq_liu=.false. ! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & ! real(r8), parameter :: qimax=0.010, qimin=0.001, qiinv=one/(qimax-qimin), & - real(r8), parameter :: qimax=0.010, qimin=0.005, qiinv=one/(qimax-qimin) + real(r8), parameter :: qimax=0.010_r8, qimin=0.005_r8, qiinv=one/(qimax-qimin) ! ts_au_min=180.0 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc @@ -3194,9 +3193,9 @@ subroutine micro_mg_tend ( & !++ag Add graupel dumg(i,k) = (qg(i,k)+qgtend(i,k)*deltat) * tx1 ! Moorthi testing - if (dumg(i,k) > 0.01) then - tx2 = dumg(i,k) - 0.01 - dumg(i,k) = 0.01 + if (dumg(i,k) > 0.01_r8) then + tx2 = dumg(i,k) - 0.01_r8 + dumg(i,k) = 0.01_r8 dums(i,k) = dums(i,k) + tx2 qstend(i,k) = (dums(i,k)*precip_frac(i,k) - qs(i,k)) * oneodt qgtend(i,k) = (dumg(i,k)*precip_frac(i,k) - qg(i,k)) * oneodt @@ -3798,9 +3797,9 @@ subroutine micro_mg_tend ( & !++ag dumg(i,k) = max(qg(i,k)+qgtend(i,k)*deltat, zero) ! Moorthi testing - if (dumg(i,k) > 0.01) then - tx2 = dumg(i,k) - 0.01 - dumg(i,k) = 0.01 + if (dumg(i,k) > 0.01_r8) then + tx2 = dumg(i,k) - 0.01_r8 + dumg(i,k) = 0.01_r8 dums(i,k) = dums(i,k) + tx2 qstend(i,k) = (dums(i,k) - qs(i,k)) * oneodt qgtend(i,k) = (dumg(i,k) - qg(i,k)) * oneodt @@ -4049,7 +4048,7 @@ subroutine micro_mg_tend ( & ! qvn = epsqs*esn/(p(i,k)-omeps*esn) - if (qtmp > qvn .and. qvn > 0 .and. allow_sed_supersat) then + if (qtmp > qvn .and. qvn > zero .and. allow_sed_supersat) then ! expression below is approximate since there may be ice deposition dum = (qtmp-qvn)/(one+xxlv_squared*qvn/(cpp*rv*ttmp*ttmp)) * oneodt ! add to output cme diff --git a/physics/micro_mg_utils.F90 b/physics/micro_mg_utils.F90 index 74da36df4..5bce3fd9c 100644 --- a/physics/micro_mg_utils.F90 +++ b/physics/micro_mg_utils.F90 @@ -480,15 +480,15 @@ elemental subroutine size_dist_param_liq_line(props, qcic, ncic, rho, pgam, lamc if (liq_gmao) then pgam = 0.0005714_r8*1.e-6_r8*ncic*rho + 0.2714_r8 ! Anning modified lamc - if ((ncic > 1.0e-3) .and. (qcic > 1.0e-11)) then + if ((ncic > 1.0e-3_r8) .and. (qcic > 1.0e-11_r8)) then xs = 0.07_r8*(1000._r8*qcic/ncic) ** (-0.14_r8) else - xs = 1.2 + xs = 1.2_r8 end if xs = max(min(xs, 1.7_r8), 1.1_r8) xs = xs*xs*xs - xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.)/8.0_r8 + xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.0_r8)/8.0_r8 pgam = sqrt(xs) else @@ -549,15 +549,15 @@ subroutine size_dist_param_liq_vect(props, qcic, ncic, rho, pgam, lamc, mgncol) if (liq_gmao) then pgam(i) = 0.0005714_r8*1.e-6_r8*ncic(i)*rho(i) + 0.2714_r8 - if ((ncic(i) > 1.0e-3) .and. (qcic(i) > 1.0e-11)) then + if ((ncic(i) > 1.0e-3_r8) .and. (qcic(i) > 1.0e-11_r8)) then xs = 0.07_r8*(1000._r8*qcic(i)/ncic(i)) **(-0.14_r8) else - xs = 1.2 + xs = 1.2_r8 end if xs = max(min(xs, 1.7_r8), 1.1_r8) xs = xs*xs*xs - xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.)/8.0_r8 + xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - 4.0_r8)/8.0_r8 pgam(i) = sqrt(xs) else pgam(i) = one - 0.7_r8 * exp(-0.008_r8*1.e-6_r8*ncic(i)*rho(i)) @@ -705,14 +705,14 @@ elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) lam = (props%shape_coef * nic/qic)**(1._r8/props%eff_dim) if (ice_sep) then miu_ice = max(min(0.008_r8*(lam*0.01)**0.87_r8, 10.0_r8), 0.1_r8) - tx1 = 1. + miu_ice - tx2 = 1. / gamma(tx1) - aux = (gamma(tx1+3.)*tx2) ** (1./3.) + tx1 = 1.0_r8 + miu_ice + tx2 = 1.0_r8 / gamma(tx1) + aux = (gamma(tx1+3.0_r8)*tx2) ** (1.0_r8/3.0_r8) lam = lam*aux else - aux = 1. - tx1 = 1.0 - tx2 = 1.0 + aux = 1.0_r8 + tx1 = 1.0_r8 + tx2 = 1.0_r8 end if if (present(n0)) n0 = nic * lam**tx1*tx2 @@ -729,7 +729,7 @@ elemental subroutine size_dist_param_ice_line(props, qic, nic, lam, n0) end if else - lam = 0._r8 + lam = 0.0_r8 end if @@ -762,14 +762,14 @@ subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) lam(i) = (props%shape_coef * nic(i)/qic(i))**(1._r8/props%eff_dim) if (ice_sep) then miu_ice = max(min(0.008_r8*(lam(i)*0.01)**0.87_r8, 10.0_r8), 0.1_r8) - tx1 = 1. + miu_ice - tx2 = 1. / gamma(tx1) - aux = (gamma(tx1+3.)*tx2) ** (1./3.) + tx1 = 1.0_r8 + miu_ice + tx2 = 1.0_r8 / gamma(tx1) + aux = (gamma(tx1+3.0_r8)*tx2) ** (1.0_r8/3.0_r8) lam(i) = lam(i)*aux else - aux = 1. - tx1 = 1.0 - tx2 = 1.0 + aux = 1.0_r8 + tx1 = 1.0_r8 + tx2 = 1.0_r8 end if if (present(n0)) n0(i) = nic(i) * lam(i)**tx1*tx2 @@ -786,7 +786,7 @@ subroutine size_dist_param_ice_vect(props, qic, nic, lam, mgncol, n0) end if else - lam(i) = 0._r8 + lam(i) = 0.0_r8 end if enddo @@ -1094,12 +1094,12 @@ subroutine liu_liq_autoconversion(pgam,qc,nc,qr,rho,relvar, & beta6 = (one+three*xs)*(one+four*xs)*(one+five*xs) & / ((one+xs)*(one+xs+xs)) LW = 1.0e-3_r8 * qc(i) * rho(i) - NW = nc(i) * rho(i) * 1.e-6_r8 + NW = nc(i) * rho(i) * 1.e-6_r8 - xs = min(20.0, 1.03e16*(LW*LW)/(NW*SQRT(NW))) - au(i) = 1.1e10*beta6*LW*LW*LW & + xs = min(20.0_r8, 1.03e16_r8*(LW*LW)/(NW*SQRT(NW))) + au(i) = 1.1e10_r8*beta6*LW*LW*LW & * (one-exp(-(xs**miu_disp))) / NW - au(i) = au(i)*1.0e3/rho(i) + au(i) = au(i)*1.0e3_r8/rho(i) au(i) = au(i) * gamma(two+relvar(i)) & / (gamma(relvar(i))*(relvar(i)*relvar(i))) @@ -2149,7 +2149,7 @@ subroutine graupel_collecting_snow(qsic,qric,umr,ums,rho,lamr,n0r,lams,n0s, & tx5 = tx4 * tx4 * tx3 psacr(i) = cons31 * tx1 * rho(i) * n0r(i) * n0s(i) * tx5 & - * (5.0*tx4+tx3*(tx2+tx2+0.5*tx3)) + * (5.0_r8*tx4+tx3*(tx2+tx2+0.5_r8*tx3)) ! psacr(i) = cons31*(((1.2_r8*umr(i)-0.95_r8*ums(i))**2+ & ! 0.08_r8*ums(i)*umr(i))**0.5_r8*rho(i)* & @@ -2201,7 +2201,7 @@ subroutine graupel_collecting_cld_water(qgic,qcic,ncic,rho,n0g,lamg,bg,agn, & do i=1,mgncol - if (qgic(i) >= 1.e-8 .and. qcic(i) >= qsmall) then + if (qgic(i) >= 1.e-8_r8 .and. qcic(i) >= qsmall) then tx1 = cons*agn(i)*rho(i)*n0g(i) / lamg(i)**(bg+three) @@ -2346,8 +2346,8 @@ subroutine graupel_collecting_rain(qric,qgic,umg,umr,ung,unr,rho,n0r,lamr,n0g,la ! pracg is mixing ratio of rain per sec collected by graupel/hail tx1 = 1.2_r8*umr(i) - 0.95_r8*umg(i) tx1 = sqrt(tx1*tx1+0.08_r8*umg(i)*umr(i)) - tx2 = 1.0 / lamr(i) - tx3 = 1.0 / lamg(i) + tx2 = 1.0_r8 / lamr(i) + tx3 = 1.0_r8 / lamg(i) tx4 = tx2 * tx2 tx5 = tx4 * tx4 * tx3 tx6 = rho(i) * n0r(i) * n0g(i) @@ -2710,10 +2710,10 @@ FUNCTION gamma_incomp(muice, x) real(r8) :: gamma_incomp REAL(r8), intent(in) :: muice, x REAL(r8) :: xog, kg, alfa, auxx - alfa = min(max(muice+1., 1.), 20._r8) + alfa = min(max(muice+1._r8, 1._r8), 20._r8) xog = log(alfa -0.3068_r8) - kg = 1.44818*(alfa**0.5357_r8) + kg = 1.44818_r8*(alfa**0.5357_r8) auxx = max(min(kg*(log(x)-xog), 30._r8), -30._r8) gamma_incomp = max(one/(one+exp(-auxx)), 1.0e-20) diff --git a/physics/mo_cloud_sampling.F90 b/physics/mo_cloud_sampling.F90 deleted file mode 100644 index 02741439f..000000000 --- a/physics/mo_cloud_sampling.F90 +++ /dev/null @@ -1,398 +0,0 @@ -! This code is part of RRTM for GCM Applications - Parallel (RRTMGP) -! -! Contacts: Robert Pincus and Eli Mlawer -! email: rrtmgp@aer.com -! -! Copyright 2015-2019, Atmospheric and Environmental Research and -! Regents of the University of Colorado. All right reserved. -! -! Use and duplication is permitted under the terms of the -! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause -! ------------------------------------------------------------------------------------------------- -! -! This module provides a simple implementation of sampling for the -! Monte Carlo Independent Pixel Approximation (McICA, doi:10.1029/2002jd003322) -! Cloud optical properties, defined by band and assumed homogenous within each cell (column/layer), -! are randomly sampled to preserve the mean cloud fraction and one of several possible overlap assumptions -! Users supply random numbers with order ngpt,nlay,ncol -! These are only accessed if cloud_fraction(icol,ilay) > 0 so many values don't need to be filled in -! -! ------------------------------------------------------------------------------------------------- -module mo_cloud_sampling - use mo_rte_kind, only: wp, wl - use mo_optical_props, only: ty_optical_props_arry, & - ty_optical_props_1scl, & - ty_optical_props_2str, & - ty_optical_props_nstr - implicit none - private - public :: draw_samples, sampled_mask_max_ran, sampled_mask_exp_dcorr, sampled_mask_exp_ran -contains - ! ------------------------------------------------------------------------------------------------- - ! - ! Apply a T/F sampled cloud mask to cloud optical properties defined by band to produce - ! McICA-sampled cloud optical properties - ! - function draw_samples(cloud_mask,clouds,clouds_sampled) result(error_msg) - logical, dimension(:,:,:), intent(in ) :: cloud_mask ! Dimensions ncol,nlay,ngpt - class(ty_optical_props_arry), intent(in ) :: clouds ! Defined by band - class(ty_optical_props_arry), intent(inout) :: clouds_sampled ! Defined by g-point - character(len=128) :: error_msg - ! ------------------------ - integer :: ncol,nlay,nbnd,ngpt - integer :: imom - ! ------------------------ - ! - ! Error checking - ! - error_msg = "" - if(.not. clouds%is_initialized()) then - error_msg = "draw_samples: cloud optical properties are not initialized" - return - end if - if(.not. clouds_sampled%is_initialized()) then - error_msg = "draw_samples: sampled cloud optical properties are not initialized" - return - end if - - ! - ! Variables clouds and clouds_sampled have to be of the same type (have the same set of fields) - ! nstr isn't supported - ! 2str is checked at assignment - ! - select type(clouds) - type is (ty_optical_props_1scl) - select type(clouds_sampled) - type is (ty_optical_props_2str) - error_msg = "draw_samples: by-band and sampled cloud properties need to be the same variable type" - return - type is (ty_optical_props_nstr) - error_msg = "draw_samples: by-band and sampled cloud properties need to be the same variable type" - return - end select - type is (ty_optical_props_nstr) - error_msg = "draw_samples: sampling isn't implemented yet for ty_optical_props_nstr" - return - end select - - ! - ! Spectral discretization - ! - if(.not. clouds%bands_are_equal(clouds_sampled)) then - error_msg = "draw_samples: by-band and sampled cloud properties spectral structure is different" - return - end if - - ! - ! Array extents - ! - ncol = clouds%get_ncol() - nlay = clouds%get_nlay() - nbnd = clouds%get_nband() - ngpt = clouds_sampled%get_ngpt() - if (any([size(cloud_mask,1), size(cloud_mask,2), size(cloud_mask,3)] /= [ncol,nlay,ngpt])) then - error_msg = "draw_samples: cloud mask and cloud optical properties have different ncol and/or nlay" - return - end if - if (any([clouds_sampled%get_ncol(), clouds_sampled%get_nlay()] /= [ncol,nlay])) then - error_msg = "draw_samples: sampled/unsampled cloud optical properties have different ncol and/or nlay" - return - end if - ! ------------------------ - ! - ! Finally - sample fields according to the cloud mask - ! - ! Optical depth assignment works for 1scl, 2str (also nstr) - call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%tau,clouds_sampled%tau) - ! - ! For 2-stream - ! - select type(clouds) - type is (ty_optical_props_2str) - select type(clouds_sampled) - type is (ty_optical_props_2str) - call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%ssa,clouds_sampled%ssa) - call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%g, clouds_sampled%g ) - class default - error_msg = "draw_samples: by-band and sampled cloud properties need to be the same variable type" - end select - end select - end function draw_samples - ! ------------------------------------------------------------------------------------------------- - ! - ! Generate a McICA-sampled cloud mask for maximum-random overlap - ! - function sampled_mask_max_ran(randoms,cloud_frac,cloud_mask) result(error_msg) - real(wp), dimension(:,:,:), intent(in ) :: randoms !ngpt,nlay,ncol - real(wp), dimension(:,:), intent(in ) :: cloud_frac ! ncol,nlay - logical, dimension(:,:,:), intent(out) :: cloud_mask ! ncol,nlay,ngpt - character(len=128) :: error_msg - ! ------------------------ - integer :: ncol, nlay, ngpt, icol, ilay, igpt - integer :: cloud_lay_fst, cloud_lay_lst - real(wp), dimension(size(randoms,1)) :: local_rands - logical, dimension(size(randoms,2)) :: cloud_mask_layer - ! ------------------------ - ! - ! Error checking - ! - error_msg = "" - ncol = size(randoms, 3) - nlay = size(randoms, 2) - ngpt = size(randoms, 1) - if(any([ncol,nlay] /= [size(cloud_frac, 1),size(cloud_frac, 2)])) then - error_msg = "sampled_mask_max_ran: sizes of randoms(ngpt,nlay,ncol) and cloud_frac(ncol,nlay) are inconsistent" - return - end if - if(any([ncol,nlay,ngpt] /= [size(cloud_mask, 1),size(cloud_mask, 2), size(cloud_mask,3)])) then - error_msg = "sampled_mask_max_ran: sizes of randoms(ngpt,nlay,ncol) and cloud_mask(ncol,nlay,ngpt) are inconsistent" - return - end if - if(any(cloud_frac > 1._wp) .or. any(cloud_frac < 0._wp)) then - error_msg = "sampled_mask_max_ran: cloud fraction values out of range [0,1]" - return - end if - ! - ! We chould check the random numbers but that would be computationally heavy - ! - ! ------------------------ - ! - ! Construct the cloud mask for each column - ! - do icol = 1, ncol - cloud_mask_layer(1:nlay) = cloud_frac(icol,1:nlay) > 0._wp - if(.not. any(cloud_mask_layer)) then - cloud_mask(icol,1:nlay,1:ngpt) = .false. - cycle - end if - cloud_lay_fst = findloc(cloud_mask_layer, .true., dim=1) - cloud_lay_lst = findloc(cloud_mask_layer, .true., dim=1, back = .true.) - cloud_mask(icol,1:cloud_lay_fst,1:ngpt) = .false. - - ilay = cloud_lay_fst - local_rands(1:ngpt) = randoms(1:ngpt,cloud_lay_fst,icol) - cloud_mask(icol,ilay,1:ngpt) = local_rands(1:ngpt) > (1._wp - cloud_frac(icol,ilay)) - do ilay = cloud_lay_fst+1, cloud_lay_lst - if(cloud_mask_layer(ilay)) then - ! - ! Max-random overlap: - ! new random deviates if the adjacent layer isn't cloudy - ! same random deviates if the adjacent layer is cloudy - ! - if(.not. cloud_mask_layer(ilay-1)) local_rands(1:ngpt) = randoms(1:ngpt,ilay,icol) - cloud_mask(icol,ilay,1:ngpt) = local_rands(1:ngpt) > (1._wp - cloud_frac(icol,ilay)) - else - cloud_mask(icol,ilay,1:ngpt) = .false. - end if - end do - - cloud_mask(icol,cloud_lay_lst+1:nlay, 1:ngpt) = .false. - end do - - end function sampled_mask_max_ran - ! ------------------------------------------------------------------------------------------------- - ! - ! Generate a McICA-sampled cloud mask for exponential-random overlap - ! The overlap parameter alpha is defined between pairs of layers - ! for layer i, alpha(i) describes the overlap betwen cloud_frac(i) and cloud_frac(i+1) - ! By skipping layers with 0 cloud fraction the code forces alpha(i) = 0 for cloud_frac(i) = 0. - ! - function sampled_mask_exp_ran(randoms,cloud_frac,overlap_param,cloud_mask) result(error_msg) - real(wp), dimension(:,:,:), intent(in ) :: randoms ! ngpt,nlay,ncol - real(wp), dimension(:,:), intent(in ) :: cloud_frac ! ncol,nlay - real(wp), dimension(:,:), intent(in ) :: overlap_param ! ncol,nlay-1 - logical, dimension(:,:,:), intent(out) :: cloud_mask ! ncol,nlay,ngpt - character(len=128) :: error_msg - ! ------------------------ - integer :: ncol, nlay, ngpt, icol, ilay, igpt - integer :: cloud_lay_fst, cloud_lay_lst - real(wp) :: rho ! correlation coefficient - real(wp), dimension(size(randoms,1)) :: local_rands - logical, dimension(size(randoms,2)) :: cloud_mask_layer - ! ------------------------ - ! - ! Error checking - ! - error_msg = "" - ncol = size(randoms, 3) - nlay = size(randoms, 2) - ngpt = size(randoms, 1) - if(any([ncol,nlay] /= [size(cloud_frac, 1),size(cloud_frac, 2)])) then - error_msg = "sampled_mask_max_ran: sizes of randoms(ngpt,nlay,ncol) and cloud_frac(ncol,nlay) are inconsistent" - return - end if - if(any([ncol,nlay-1] /= [size(overlap_param, 1),size(overlap_param, 2)])) then - error_msg = "sampled_mask_max_ran: sizes of randoms(ngpt,nlay,ncol) and overlap_param(ncol,nlay-1) are inconsistent" - return - end if - if(any([ncol,nlay,ngpt] /= [size(cloud_mask, 1),size(cloud_mask, 2), size(cloud_mask,3)])) then - error_msg = "sampled_mask_max_ran: sizes of randoms(ngpt,nlay,ncol) and cloud_mask(ncol,nlay,ngpt) are inconsistent" - return - end if - - if(any(cloud_frac > 1._wp) .or. any(cloud_frac < 0._wp)) then - error_msg = "sampled_mask_max_ran: cloud fraction values out of range [0,1]" - return - end if - if(any(overlap_param > 1._wp) .or. any(overlap_param < -1._wp)) then - error_msg = "sampled_mask_max_ran: overlap_param values out of range [-1,1]" - return - end if - ! - ! We chould check the random numbers but that would be computationally heavy - ! - ! ------------------------ - ! Construct the cloud mask for each column - ! - do icol = 1, ncol - cloud_mask_layer(1:nlay) = cloud_frac(icol,1:nlay) > 0._wp - if(.not. any(cloud_mask_layer)) then - cloud_mask(icol,1:nlay,1:ngpt) = .false. - cycle - end if - cloud_lay_fst = findloc(cloud_mask_layer, .true., dim=1) - cloud_lay_lst = findloc(cloud_mask_layer, .true., dim=1, back = .true.) - cloud_mask(icol,1:cloud_lay_fst,1:ngpt) = .false. - - ilay = cloud_lay_fst - local_rands(1:ngpt) = randoms(1:ngpt,ilay,icol) - cloud_mask(icol,ilay,1:ngpt) = local_rands(1:ngpt) > (1._wp - cloud_frac(icol,ilay)) - do ilay = cloud_lay_fst+1, cloud_lay_lst - if(cloud_mask_layer(ilay)) then - ! - ! Exponential-random overlap: - ! new random deviates if the adjacent layer isn't cloudy - ! correlated deviates if the adjacent layer is cloudy - ! - if(cloud_mask_layer(ilay-1)) then - ! - ! Create random deviates correlated between this layer and the previous layer - ! (have to remove mean value before enforcing correlation) - ! - rho = overlap_param(icol,ilay-1) - local_rands(1:ngpt) = rho*(local_rands(1:ngpt) -0.5_wp) + & - sqrt(1._wp-rho*rho)*(randoms(1:ngpt,ilay,icol)-0.5_wp) + 0.5_wp - else - local_rands(1:ngpt) = randoms(1:ngpt,ilay,icol) - end if - cloud_mask(icol,ilay,1:ngpt) = local_rands(1:ngpt) > (1._wp - cloud_frac(icol,ilay)) - end if - end do - - cloud_mask(icol,cloud_lay_lst+1:nlay, 1:ngpt) = .false. - end do - end function sampled_mask_exp_ran - - ! ------------------------------------------------------------------------------------------------- - ! - ! Generate a McICA-sampled cloud mask for exponential-decorrelation overlap - ! The overlap parameter is defined between pairs of layers - ! - function sampled_mask_exp_dcorr(randoms1,randoms2,cloud_frac,overlap_param,cloud_mask) result(error_msg) - real(wp), dimension(:,:,:), intent(in ) :: randoms1,randoms2 ! ngpt,nlay,ncol - real(wp), dimension(:,:), intent(in ) :: cloud_frac ! ncol,nlay - real(wp), dimension(:,:), intent(in ) :: overlap_param ! ncol,nlay-1 - logical, dimension(:,:,:), intent(out) :: cloud_mask ! ncol,nlay,ngpt - character(len=128) :: error_msg - ! ------------------------ - integer :: ncol, nlay, ngpt, icol, ilay, igpt - integer :: cloud_lay_fst, cloud_lay_lst - logical, dimension(size(randoms1,2)) :: cloud_mask_layer - ! ------------------------ - ! - ! Error checking - ! - error_msg = "" - ncol = size(randoms1, 3) - nlay = size(randoms1, 2) - ngpt = size(randoms1, 1) - if(any([ncol,nlay] /= [size(cloud_frac, 1),size(cloud_frac, 2)])) then - error_msg = "sampled_mask_max_ran: sizes of randoms1(ngpt,nlay,ncol) and cloud_frac(ncol,nlay) are inconsistent" - return - end if - if(any([ncol,nlay-1] /= [size(overlap_param, 1),size(overlap_param, 2)])) then - error_msg = "sampled_mask_max_ran: sizes of randoms1(ngpt,nlay,ncol) and overlap_param(ncol,nlay-1) are inconsistent" - return - end if - if(any([ncol,nlay,ngpt] /= [size(cloud_mask, 1),size(cloud_mask, 2), size(cloud_mask,3)])) then - error_msg = "sampled_mask_max_ran: sizes of randoms1(ngpt,nlay,ncol) and cloud_mask(ncol,nlay,ngpt) are inconsistent" - return - end if - - if(any(cloud_frac > 1._wp) .or. any(cloud_frac < 0._wp)) then - error_msg = "sampled_mask_max_ran: cloud fraction values out of range [0,1]" - return - end if - if(any(overlap_param > 1._wp) .or. any(overlap_param < -1._wp)) then - error_msg = "sampled_mask_max_ran: overlap_param values out of range [-1,1]" - return - end if - - ! - do icol = 1, ncol - ! Column cloud-mask - cloud_mask_layer(1:nlay) = cloud_frac(icol,1:nlay) > 0._wp - - ! Skip column if no clouds - if(.not. any(cloud_mask_layer)) then - cloud_mask(icol,1:nlay,1:ngpt) = .false. - cycle - end if - - ! Pull out indices for First/Last cloudy layers - cloud_lay_fst = findloc(cloud_mask_layer, .true., dim=1) - cloud_lay_lst = findloc(cloud_mask_layer, .true., dim=1, back = .true.) - - ! Set cloud-mask in layers above cloud to false - cloud_mask(icol,1:cloud_lay_fst,1:ngpt) = .false. - - ! Loop over cloudy-layers - ! - ! First layer - ! - ilay = cloud_lay_fst - cloud_mask(icol,ilay,1:ngpt) = randoms1(1:ngpt,iLay,iCol) > (1._wp - cloud_frac(iCol,iLay)) - ! - ! Subsequent-layers - ! - do ilay = cloud_lay_fst+1, cloud_lay_lst - !if(cloud_mask_layer(ilay) .and. cloud_mask_layer(ilay-1)) then - where(randoms2(1:nGpt,iLay,iCol) .le. overlap_param(iCol,iLay)) - cloud_mask(iCol,iLay,1:nGpt) = randoms1(1:ngpt,iLay-1,iCol) > (1._wp - cloud_frac(iCol,iLay)) - elsewhere - cloud_mask(iCol,iLay,1:nGpt) = randoms1(1:ngpt,iLay,iCol) > (1._wp - cloud_frac(iCol,iLay)) - endwhere - !else - ! cloud_mask(iCol,iLay,1:nGpt) = .false. - !endif - end do - - ! Set cloud-mask in layer below clouds to false - cloud_mask(icol,cloud_lay_lst+1:nlay, 1:ngpt) = .false. - end do - - end function sampled_mask_exp_dcorr - ! ------------------------------------------------------------------------------------------------- - ! - ! Apply a true/false cloud mask to a homogeneous field - ! This could be a kernel - ! - subroutine apply_cloud_mask(ncol,nlay,nbnd,ngpt,band_lims_gpt,cloud_mask,input_field,sampled_field) - integer, intent(in ) :: ncol,nlay,nbnd,ngpt - integer, dimension(2,nbnd), intent(in ) :: band_lims_gpt - logical, dimension(ncol,nlay,ngpt), intent(in ) :: cloud_mask - real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: input_field - real(wp), dimension(ncol,nlay,ngpt), intent(out) :: sampled_field - - integer :: icol,ilay,ibnd,igpt - - do ibnd = 1, nbnd - do igpt = band_lims_gpt(1,ibnd), band_lims_gpt(2,ibnd) - do ilay = 1, nlay - sampled_field(1:ncol,ilay,igpt) = merge(input_field(1:ncol,ilay,ibnd), 0._wp, cloud_mask(1:ncol,ilay,igpt)) - end do - end do - end do - end subroutine apply_cloud_mask - -end module mo_cloud_sampling diff --git a/physics/module_BL_MYJPBL.F90 b/physics/module_BL_MYJPBL.F90 old mode 100755 new mode 100644 diff --git a/physics/module_MYJPBL_wrapper.F90 b/physics/module_MYJPBL_wrapper.F90 index d239013b4..5924de96f 100644 --- a/physics/module_MYJPBL_wrapper.F90 +++ b/physics/module_MYJPBL_wrapper.F90 @@ -40,7 +40,9 @@ SUBROUTINE myjpbl_wrapper_run( & & dusfc,dvsfc,dtsfc,dqsfc, & & dkt,xkzm_m, xkzm_h,xkzm_s, gamt,gamq, & & con_cp,con_g,con_rd, & - & me, lprnt, errmsg, errflg ) + & me, lprnt, dt3dt_PBL, du3dt_PBL, dv3dt_PBL, & + & dq3dt_PBL, gen_tend, ldiag3d, qdiag3d, & + & errmsg, errflg ) ! @@ -79,7 +81,7 @@ SUBROUTINE myjpbl_wrapper_run( & integer,intent(in) :: im, levs integer,intent(in) :: kdt, me integer,intent(in) :: ntrac,ntke,ntcw,ntiw,ntrw,ntsw,ntgl - logical,intent(in) :: restart,do_myjsfc,lprnt + logical,intent(in) :: restart,do_myjsfc,lprnt,ldiag3d,qdiag3d,gen_tend real(kind=kind_phys),intent(in) :: con_cp, con_g, con_rd real(kind=kind_phys),intent(in) :: dt_phs, xkzm_m, xkzm_h, xkzm_s @@ -111,6 +113,8 @@ SUBROUTINE myjpbl_wrapper_run( & dudt, dvdt, dtdt real(kind=kind_phys),dimension(im,levs-1),intent(out) :: & dkt + real(kind=kind_phys),dimension(:,:),intent(inout) :: & + du3dt_PBL, dv3dt_PBL, dt3dt_PBL, dq3dt_PBL !MYJ-4D real(kind=kind_phys),dimension(im,levs,ntrac),intent(inout) :: & @@ -576,6 +580,24 @@ SUBROUTINE myjpbl_wrapper_run( & dqdt(i,k,ntcw)=dqdt(i,k,ntcw)+rqcblten(i,k1) end do end do + if (ldiag3d .and. .not. gen_tend) then + do k=1,levs + k1=levs+1-k + do i=1,im + du3dt_PBL(i,k) = rublten(i,k1)*dt_phs + dv3dt_PBL(i,k) = rvblten(i,k1)*dt_phs + dt3dt_PBL(i,k) = rthblten(i,k1)*exner(i,k1)*dt_phs + end do + end do + if (qdiag3d) then + do k=1,levs + k1=levs+1-k + do i=1,im + dq3dt_PBL(i,k) = rqvblten(i,k1)*dt_phs + end do + end do + end if + end if if (lprnt1) then diff --git a/physics/module_MYJPBL_wrapper.meta b/physics/module_MYJPBL_wrapper.meta index fa1fe17c4..26f9bb9eb 100644 --- a/physics/module_MYJPBL_wrapper.meta +++ b/physics/module_MYJPBL_wrapper.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = myjpbl_wrapper + type = scheme + dependencies = module_BL_MYJPBL.F90 + +######################################################################## [ccpp-arg-table] name = myjpbl_wrapper_run type = scheme @@ -624,6 +630,59 @@ type = logical intent = in optional = F +[dt3dt_PBL] + standard_name = cumulative_change_in_temperature_due_to_PBL + long_name = cumulative change in temperature due to PBL + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[du3dt_PBL] + standard_name = cumulative_change_in_x_wind_due_to_PBL + long_name = cumulative change in x wind due to PBL + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dv3dt_PBL] + standard_name = cumulative_change_in_y_wind_due_to_PBL + long_name = cumulative change in y wind due to PBL + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dq3dt_PBL] + standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL + long_name = cumulative change in water vapor specific humidity due to PBL + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[gen_tend] + standard_name = flag_for_generic_planetary_boundary_layer_tendency + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_MYJSFC_wrapper.meta b/physics/module_MYJSFC_wrapper.meta index c26728f0f..8938aeccd 100644 --- a/physics/module_MYJSFC_wrapper.meta +++ b/physics/module_MYJSFC_wrapper.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = myjsfc_wrapper + type = scheme + dependencies = module_SF_JSFC.F90 + +######################################################################## [ccpp-arg-table] name = myjsfc_wrapper_run type = scheme diff --git a/physics/module_MYNNPBL_wrapper.F90 b/physics/module_MYNNPBL_wrapper.F90 index 8fd727148..6011c203e 100644 --- a/physics/module_MYNNPBL_wrapper.F90 +++ b/physics/module_MYNNPBL_wrapper.F90 @@ -82,6 +82,7 @@ SUBROUTINE mynnedmf_wrapper_run( & & dqdt_ice_cloud, dqdt_ozone, & & dqdt_cloud_droplet_num_conc, dqdt_ice_num_conc, & & dqdt_water_aer_num_conc, dqdt_ice_aer_num_conc, & + & flag_for_pbl_generic_tend, & & du3dt_PBL, du3dt_OGWD, dv3dt_PBL, dv3dt_OGWD, & & do3dt_PBL, dq3dt_PBL, dt3dt_PBL, & & htrsw, htrlw, xmu, & @@ -190,7 +191,8 @@ SUBROUTINE mynnedmf_wrapper_run( & ! NAMELIST OPTIONS (INPUT): LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect, ltaerosol, & - lprnt, do_mynnsfclay + lprnt, do_mynnsfclay, & + flag_for_pbl_generic_tend INTEGER, INTENT(IN) :: & & bl_mynn_cloudpdf, & & bl_mynn_mixlength, & @@ -700,7 +702,7 @@ SUBROUTINE mynnedmf_wrapper_run( & enddo enddo accum_duvt3dt: if(lssav) then - if(ldiag3d) then + if(ldiag3d .and. .not. flag_for_pbl_generic_tend) then do k = 1, levs do i = 1, im du3dt_PBL(i,k) = du3dt_PBL(i,k) + RUBLTEN(i,k)*dtf @@ -708,16 +710,14 @@ SUBROUTINE mynnedmf_wrapper_run( & enddo enddo endif - if_lsidea: if (lsidea) then - dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + RTHBLTEN(i,k)*exner(i,k)*dtf - elseif(ldiag3d) then - do k=1,levs - do i=1,im - tem = RTHBLTEN(i,k)*exner(i,k) - (htrlw(i,k)+htrsw(i,k)*xmu(i)) - dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + tem*dtf - enddo - enddo - endif if_lsidea + + if (lsidea .or. (ldiag3d .and. .not. flag_for_pbl_generic_tend)) then + do k = 1, levs + do i = 1, im + dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + RTHBLTEN(i,k)*exner(i,k)*dtf + enddo + enddo + endif endif accum_duvt3dt !Update T, U and V: !do k = 1, levs @@ -739,13 +739,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !dqdt_ozone(i,k) = 0.0 enddo enddo - if(lssav .and. ldiag3d .and. qdiag3d) then - do k=1,levs - do i=1,im - dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + dqdt_water_vapor(i,k)*dtf - enddo - enddo - endif !Update moist species: !do k=1,levs ! do i=1,im @@ -770,13 +763,6 @@ SUBROUTINE mynnedmf_wrapper_run( & dqdt_ice_aer_num_conc(i,k) = RQNIFABLTEN(i,k) enddo enddo - if(lssav .and. ldiag3d .and. qdiag3d) then - do k=1,levs - do i=1,im - dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + dqdt_water_vapor(i,k)*dtf - enddo - enddo - endif !do k=1,levs ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt @@ -800,13 +786,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !dqdt_ozone(i,k) = 0.0 enddo enddo - if(lssav .and. ldiag3d .and. qdiag3d) then - do k=1,levs - do i=1,im - dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + dqdt_water_vapor(i,k)*dtf - enddo - enddo - endif !do k=1,levs ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt @@ -830,13 +809,6 @@ SUBROUTINE mynnedmf_wrapper_run( & !dqdt_ozone(i,k) = 0.0 enddo enddo - if(lssav .and. ldiag3d .and. qdiag3d) then - do k=1,levs - do i=1,im - dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + dqdt_water_vapor(i,k)*dtf - enddo - enddo - endif !do k=1,levs ! do i=1,im ! qgrs_water_vapor(i,k) = qgrs_water_vapor(i,k) + (RQVBLTEN(i,k)/(1.0+RQVBLTEN(i,k)))*delt @@ -858,15 +830,15 @@ SUBROUTINE mynnedmf_wrapper_run( & !dqdt_ozone(i,k) = 0.0 enddo enddo - if(lssav .and. ldiag3d .and. qdiag3d) then - do k=1,levs - do i=1,im - dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + dqdt_water_vapor(i,k)*dtf - enddo - enddo - endif endif - + + if(lssav .and. (ldiag3d .and. qdiag3d .and. .not. flag_for_pbl_generic_tend)) then + do k=1,levs + do i=1,im + dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + dqdt_water_vapor(i,k)*dtf + enddo + enddo + endif if (lprnt) then print* diff --git a/physics/module_MYNNPBL_wrapper.meta b/physics/module_MYNNPBL_wrapper.meta index 43f14ad5f..37595e591 100644 --- a/physics/module_MYNNPBL_wrapper.meta +++ b/physics/module_MYNNPBL_wrapper.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = mynnedmf_wrapper + type = scheme + dependencies = machine.F,module_bl_mynn.F90,physcons.F90 + +######################################################################## [ccpp-arg-table] name = mynnedmf_wrapper_init type = scheme @@ -997,11 +1003,19 @@ kind = kind_phys intent = inout optional = F +[flag_for_pbl_generic_tend] + standard_name = flag_for_generic_planetary_boundary_layer_tendency + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in + optional = F [du3dt_PBL] standard_name = cumulative_change_in_x_wind_due_to_PBL long_name = cumulative change in x wind due to PBL units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1019,7 +1033,7 @@ standard_name = cumulative_change_in_y_wind_due_to_PBL long_name = cumulative change in y wind due to PBL units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1037,7 +1051,7 @@ standard_name = cumulative_change_in_ozone_mixing_ratio_due_to_PBL long_name = cumulative change in ozone mixing ratio due to PBL units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1046,7 +1060,7 @@ standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL long_name = cumulative change in water vapor specific humidity due to PBL units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -1055,7 +1069,7 @@ standard_name = cumulative_change_in_temperature_due_to_PBL long_name = cumulative change in temperature due to PBL units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout diff --git a/physics/module_MYNNSFC_wrapper.meta b/physics/module_MYNNSFC_wrapper.meta index 655c65769..59df18419 100644 --- a/physics/module_MYNNSFC_wrapper.meta +++ b/physics/module_MYNNSFC_wrapper.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = mynnsfc_wrapper + type = scheme + dependencies = machine.F,module_sf_mynn.F90 + +######################################################################## [ccpp-arg-table] name = mynnsfc_wrapper_run type = scheme diff --git a/physics/module_SF_JSFC.F90 b/physics/module_SF_JSFC.F90 old mode 100755 new mode 100644 diff --git a/physics/module_SGSCloud_RadPost.meta b/physics/module_SGSCloud_RadPost.meta index da4191aad..089c770c2 100644 --- a/physics/module_SGSCloud_RadPost.meta +++ b/physics/module_SGSCloud_RadPost.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sgscloud_radpost + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = sgscloud_radpost_run type = scheme diff --git a/physics/module_SGSCloud_RadPre.F90 b/physics/module_SGSCloud_RadPre.F90 index 5a1a2744f..ebc5ea2ae 100644 --- a/physics/module_SGSCloud_RadPre.F90 +++ b/physics/module_SGSCloud_RadPre.F90 @@ -49,6 +49,7 @@ subroutine sgscloud_radpre_run( & nlay, plyr, xlat, dz,de_lgth, & cldsa,mtopa,mbota, & imp_physics, imp_physics_gfdl,& + iovr, & errmsg, errflg ) ! should be moved to inside the mynn: @@ -81,6 +82,7 @@ subroutine sgscloud_radpre_run( & real(kind=kind_phys), dimension(im,nlay), intent(in) :: plyr, dz real(kind=kind_phys), dimension(im,5), intent(inout) :: cldsa integer, dimension(im,3), intent(inout) :: mbota, mtopa + integer, intent(in) :: iovr character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! Local variables @@ -93,6 +95,9 @@ subroutine sgscloud_radpre_run( & real(kind=kind_phys), dimension(im) :: rxlat real (kind=kind_phys):: Tc, iwc integer :: i, k, id + ! DH* 20200723 - see comment at the end of this routine around 'gethml' + real(kind=kind_phys), dimension(im,nlay) :: alpha_dummy + ! *DH ! PARAMETERS FOR RANDALL AND XU (1996) CLOUD FRACTION REAL, PARAMETER :: coef_p = 0.25, coef_gamm = 0.49, coef_alph = 100. @@ -123,7 +128,7 @@ subroutine sgscloud_radpre_run( & if (h2oliq > clwt) then onemrh= max( 1.e-10, 1.0-rhgrid ) - tem1 = min(max((onemrh*qsat)**0.49,0.0001),1.0) !jhan + tem1 = min(max((onemrh*qsat)**0.49,0.0001),1.0) !jhan tem1 = 100.0 / tem1 value = max( min( tem1*(h2oliq-clwt), 50.0 ), 0.0 ) tem2 = sqrt( sqrt(rhgrid) ) @@ -304,12 +309,35 @@ subroutine sgscloud_radpre_run( & cldcnv = 0. +! DH* 20200723 +! iovr == 4 or 5 requires alpha, which is computed in GFS_rrmtg_pre, +! which comes after SGSCloud_RadPre. Computing alpha here requires +! a lot more input variables and computations (dzlay etc.), and +! recomputing it in GFS_rrmtg_pre is a waste of time. Workaround: +! pass a dummy array initialized to zero to gethml for other values of iovr. + if ( iovr == 4 .or. iovr == 5 ) then + errmsg = 'Logic error in sgscloud_radpre: iovr==4 or 5 not implemented' + errflg = 1 + return + end if +!! Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options +! if ( iovr == 4 .or. iovr == 5 ) then +! call get_alpha_exp & +!! --- inputs: +! (im, nlay, dzlay, iovr, latdeg, julian, yearlen, clouds1, & +!! --- outputs: +! alpha & +! ) +! endif + alpha_dummy = 0.0 +! *DH 2020723 + !> - Recompute the diagnostic high, mid, low, total and bl cloud fraction call gethml & ! --- inputs: - ( plyr, ptop1, clouds1, cldcnv, dz, de_lgth, im, nlay, & + ( plyr, ptop1, clouds1, cldcnv, dz, de_lgth, alpha_dummy, & ! --- outputs: - cldsa, mtopa, mbota) + im, nlay, cldsa, mtopa, mbota) !print*,"===Finished adding subgrid clouds to the resolved-scale clouds" !print*,"qc_save:",qc_save(1,1)," qi_save:",qi_save(1,1) diff --git a/physics/module_SGSCloud_RadPre.meta b/physics/module_SGSCloud_RadPre.meta index 2658e8638..f7db379d7 100644 --- a/physics/module_SGSCloud_RadPre.meta +++ b/physics/module_SGSCloud_RadPre.meta @@ -1,11 +1,7 @@ -[ccpp-arg-table] - name = sgscloud_radpre_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = sgscloud_radpre_finalize +[ccpp-table-properties] + name = sgscloud_radpre type = scheme + dependencies = funcphys.f90,iounitdef.f,machine.F,module_bfmicrophysics.f,physcons.F90,radcons.f90,radiation_clouds.f ######################################################################## [ccpp-arg-table] @@ -341,6 +337,14 @@ type = integer intent = in optional = F +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/module_bl_mynn.F90 b/physics/module_bl_mynn.F90 index 2c1ce9fe0..fa892eba8 100644 --- a/physics/module_bl_mynn.F90 +++ b/physics/module_bl_mynn.F90 @@ -3132,7 +3132,7 @@ SUBROUTINE mynn_tendencies(kts,kte, & & 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) c(k)= -dtz(k)*khdz(k+1)*rhoinv(k) - 0.5*dtz(k)*s_aw(k+1) d(k)=thl(k) + tcd(k)*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) + & - & + diss_heat(k)*delt*dheat_opt + & + & diss_heat(k)*delt*dheat_opt + & & sub_thl(k)*delt + det_thl(k)*delt ENDDO diff --git a/physics/module_mp_thompson.F90 b/physics/module_mp_thompson.F90 index 304afc6d5..14604e625 100644 --- a/physics/module_mp_thompson.F90 +++ b/physics/module_mp_thompson.F90 @@ -1,12 +1,6 @@ !>\file module_mp_thompson.F90 !! This file contains the entity of GSD Thompson MP scheme. -! DH* 2020-06-05 -! Use the following preprocessor directive to roll back -! to the WRFv3.8.1, used in RAPv5/HRRRv4 for more reasonable -! representation of mesoscale storms and reflectivity values -!#define WRF381 - !>\ingroup aathompson !! This module computes the moisture tendencies of water vapor, @@ -463,13 +457,6 @@ SUBROUTINE thompson_init(nwfa2d, nifa2d, nwfa, nifa, & if (.NOT. ALLOCATED(tcg_racg) ) then ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) micro_init = .TRUE. - if (mpirank==mpiroot) then -#ifdef WRF381 - write(0,*) "Using Thompson MP from WRFv3.8.1 (RAPv5/HRRRv4)" -#else - write(0,*) "Using Thompson MP from WRFv4.0+" -#endif - endif endif if (.NOT. ALLOCATED(tmr_racg)) ALLOCATE(tmr_racg(ntb_g1,ntb_g,ntb_r1,ntb_r)) @@ -2715,13 +2702,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !! supersat again. sump = pri_inu(k) + pri_ide(k) + prs_ide(k) & + prs_sde(k) + prg_gde(k) + pri_iha(k) -! DH* 2020-06-02 I believe that the WRF381 version -! is wrong, because the units do not match. -#ifdef WRF381 - rate_max = (qv(k)-qvsi(k))*odts*0.999 -#else rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 -#endif if ( (sump.gt. eps .and. sump.gt. rate_max) .or. & (sump.lt. -eps .and. sump.lt. rate_max) ) then ratio = rate_max/sump @@ -3598,7 +3579,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(1)) enddo -#ifdef WRF381 +#if 1 if (rr(kts).gt.R1*10.) & #else if (rr(kts).gt.R1*1000.) & @@ -3653,7 +3634,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(2)) enddo -#ifdef WRF381 +#if 1 if (ri(kts).gt.R1*10.) & #else if (ri(kts).gt.R1*1000.) & @@ -3684,7 +3665,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(3)) enddo -#ifdef WRF381 +#if 1 if (rs(kts).gt.R1*10.) & #else if (rs(kts).gt.R1*1000.) & @@ -3715,7 +3696,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(4)) enddo -#ifdef WRF381 +#if 1 if (rg(kts).gt.R1*10.) & #else if (rg(kts).gt.R1*1000.) & @@ -3760,21 +3741,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) qc1d(k) = qc1d(k) + qcten(k)*DT nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) -! DH* 2020-06-05 I believe WRF381 is wrong in terms of units; -! dividing by rho turns number concentration per volume into -! number concentration per mass. -#ifdef WRF381 nwfa1d(k) = MAX(11.1E6/rho(k), MIN(9999.E6/rho(k), & (nwfa1d(k)+nwfaten(k)*DT))) nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6/rho(k), & (nifa1d(k)+nifaten(k)*DT))) -#else - nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & - (nwfa1d(k)+nwfaten(k)*DT))) - nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & - (nifa1d(k)+nifaten(k)*DT))) -#endif - if (qc1d(k) .le. R1) then qc1d(k) = 0.0 nc1d(k) = 0.0 @@ -5275,31 +5245,14 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & ! are consistent with the WRFv3.8.1 settings, but inconsistent ! with the WRFv4+ settings. In order to apply the same bounds ! as before this change, use the WRF v3.8.1 settings throughout. -#if 1 -!ifdef WRF381 re_qc1d(:) = 2.49E-6 re_qi1d(:) = 4.99E-6 re_qs1d(:) = 9.99E-6 -#else - re_qc1d(:) = 2.49E-6 - re_qi1d(:) = 2.49E-6 - re_qs1d(:) = 4.99E-6 -#endif do k = kts, kte rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) rc(k) = MAX(R1, qc1d(k)*rho(k)) -#ifdef WRF381 - nc(k) = MAX(R2, MIN(nc1d(k)*rho(k), Nt_c_max)) -#else - ! DH* 2020-06-05 is using 2.0 instead of R2 - ! a bug in the WRFv4.0+ version of Thompson? - ! For ni(k) a few lines below, it is still R2. - ! Note that R2 is defined as R2 = 1.E-6, and is - ! used in other parts of Thompson MP for ni/nr - ! calculations (but not for nc calculations) nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) -#endif if (.NOT. is_aerosol_aware) nc(k) = Nt_c if (rc(k).gt.R1 .and. nc(k).gt.R2) has_qc = .true. ri(k) = MAX(R1, qi1d(k)*rho(k)) @@ -5328,12 +5281,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & do k = kts, kte if (ri(k).le.R1 .or. ni(k).le.R2) CYCLE lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi -#if 1 -!ifdef WRF381 re_qi1d(k) = MAX(5.01E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) -#else - re_qi1d(k) = MAX(2.51E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) -#endif enddo endif @@ -5373,12 +5321,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) smoc = a_ * smo2**b_ -#if 1 -!ifdef WRF381 re_qs1d(k) = MAX(10.E-6, MIN(0.5*(smoc/smob), 999.E-6)) -#else - re_qs1d(k) = MAX(5.01E-6, MIN(0.5*(smoc/smob), 999.E-6)) -#endif enddo endif diff --git a/physics/module_nst_model.f90 b/physics/module_nst_model.f90 index 53bfb6be3..1e4d1a704 100644 --- a/physics/module_nst_model.f90 +++ b/physics/module_nst_model.f90 @@ -889,7 +889,7 @@ subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q zcsq = z_c * z_c a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4) - if ( hb > 0.0 ) then + if ( hb > 0.0 .and. zcsq > 0.0 .and. alpha > 0.0) then bc1 = zcsq * (q_ts+cc3*hl_ts) bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq) zc_ts = bc1/bc2 diff --git a/physics/module_nst_water_prop.f90 b/physics/module_nst_water_prop.f90 index 3f3916396..39020526c 100644 --- a/physics/module_nst_water_prop.f90 +++ b/physics/module_nst_water_prop.f90 @@ -60,8 +60,8 @@ subroutine rhocoef(t, s, rhoref, alpha, beta) tc = t - t0k - alpha = & - 6.793952e-2 & + alpha = & + 6.793952e-2 & - 2.0 * 9.095290e-3 * tc + 3.0 * 1.001685e-4 * tc**2 & - 4.0 * 1.120083e-6 * tc**3 + 5.0 * 6.536332e-9 * tc**4 & - 4.0899e-3 * s & @@ -73,7 +73,7 @@ subroutine rhocoef(t, s, rhoref, alpha, beta) ! alpha = -alpha/rhoref - beta = & + beta = & 8.24493e-1 - 4.0899e-3 * tc & + 7.6438e-5 * tc**2 - 8.2467e-7 * tc**3 & + 5.3875e-9 * tc**4 - 1.5 * 5.72466e-3 * s**.5 & @@ -109,10 +109,10 @@ subroutine density(t, s, rho) ! effect of temperature on density (lines 1-3) ! effect of temperature and salinity on density (lines 4-8) - rho = & - 999.842594 + 6.793952e-2 * tc & - - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & - - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & + rho = & + 999.842594 + 6.793952e-2 * tc & + - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & + - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & + 8.24493e-1 * s - 4.0899e-3 * tc * s & + 7.6438e-5 * tc**2 * s - 8.2467e-7 * tc**3 * s & + 5.3875e-9 * tc**4 * s - 5.72466e-3 * s**1.5 & @@ -415,9 +415,9 @@ elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) real(kind=kind_phys),intent(out):: df_sol_z ! if(z>0) then - df_sol_z=f_sol_0*(1.0 & - -(0.28*0.014*(1.-exp(-z/0.014)) & - +0.27*0.357*(1.-exp(-z/0.357)) & + df_sol_z=f_sol_0*(1.0 & + -(0.28*0.014*(1.-exp(-z/0.014)) & + +0.27*0.357*(1.-exp(-z/0.357)) & +.45*12.82*(1.-exp(-z/12.82)))/z & ) else @@ -444,9 +444,9 @@ elemental subroutine sw_soloviev_3exp_v2_aw(z,aw) real(kind=kind_phys):: fxp ! if(z>0) then - fxp=(1.0 & - -(0.28*0.014*(1.-exp(-z/0.014)) & - + 0.27*0.357*(1.-exp(-z/0.357)) & + fxp=(1.0 & + -(0.28*0.014*(1.-exp(-z/0.014)) & + + 0.27*0.357*(1.-exp(-z/0.357)) & + 0.45*12.82*(1.-exp(-z/12.82)))/z & ) aw=1.0-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82)) @@ -657,7 +657,7 @@ subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm) end subroutine get_dtzm_point !>\ingroup waterprop - subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) + subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,nth,dtm) !subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,icy,z1,z2,nx,ny,dtm) ! ===================================================================== ! ! ! @@ -687,6 +687,7 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) ! ny - integer, dimension in y-direction (meridional) 1 ! ! z1 - lower bound of depth of sea temperature 1 ! ! z2 - upper bound of depth of sea temperature 1 ! +! nth - integer, num of openmp thread 1 ! ! outputs: ! ! dtm - mean of dT(z) (z1 to z2) 1 ! ! @@ -694,7 +695,7 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) implicit none - integer, intent(in) :: nx,ny + integer, intent(in) :: nx,ny, nth real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc logical, dimension(nx,ny), intent(in) :: wet ! logical, dimension(nx,ny), intent(in) :: wet,icy @@ -702,69 +703,59 @@ subroutine get_dtzm_2d(xt,xz,dt_cool,zc,wet,z1,z2,nx,ny,dtm) real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm ! Local variables integer :: i,j - real (kind=kind_phys), dimension(nx,ny) :: dtw,dtc - real (kind=kind_phys) :: dt_warm + real (kind=kind_phys) :: dt_warm, dtw, dtc, xzi + real (kind=kind_phys), parameter :: zero=0.0, half=0.5, one=1.0 -!$omp parallel do private(j,i) +!$omp parallel do num_threads (nth) private(j,i,dtw,dtc,xzi) do j = 1, ny do i= 1, nx -! -! initialize dtw & dtc as zeros -! - dtw(i,j) = 0.0 - dtc(i,j) = 0.0 -! if ( wet(i,j) .and. .not.icy(i,j) ) then + + dtm(i,j) = zero ! initialize dtm + if ( wet(i,j) ) then ! ! get the mean warming in the range of z=z1 to z=z2 ! - if ( xt(i,j) > 0.0 ) then - dt_warm = (xt(i,j)+xt(i,j))/xz(i,j) ! Tw(0) - if ( z1 < z2) then + dtw = zero + if ( xt(i,j) > zero ) then + xzi = one / xz(i,j) + dt_warm = (xt(i,j)+xt(i,j)) * xzi ! Tw(0) + if (z1 < z2) then if ( z2 < xz(i,j) ) then - dtw(i,j) = dt_warm*(1.0-(z1+z2)/(xz(i,j)+xz(i,j))) - elseif ( z1 < xz(i,j) .and. z2 >= xz(i,j) ) then - dtw(i,j) = 0.5*(1.0-z1/xz(i,j))*dt_warm*(xz(i,j)-z1)/(z2-z1) + dtw = dt_warm * (one-half*(z1+z2)*xzi) + elseif (z1 < xz(i,j) .and. z2 >= xz(i,j) ) then + dtw = half*(one-z1*xzi)*dt_warm*(xz(i,j)-z1)/(z2-z1) endif - elseif ( z1 == z2 ) then - if ( z1 < xz(i,j) ) then - dtw(i,j) = dt_warm*(1.0-z1/xz(i,j)) + elseif (z1 == z2 ) then + if (z1 < xz(i,j) ) then + dtw = dt_warm * (one-z1*xzi) endif endif endif ! ! get the mean cooling in the range of z=0 to z=zsea ! - if ( zc(i,j) > 0.0 ) then + dtc = zero + if ( zc(i,j) > zero ) then if ( z1 < z2) then if ( z2 < zc(i,j) ) then - dtc(i,j) = dt_cool(i,j)*(1.0-(z1+z2)/(zc(i,j)+zc(i,j))) + dtc = dt_cool(i,j) * (one-(z1+z2)/(zc(i,j)+zc(i,j))) elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then - dtc(i,j) = 0.5*(1.0-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) + dtc = half*(one-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) endif elseif ( z1 == z2 ) then if ( z1 < zc(i,j) ) then - dtc(i,j) = dt_cool(i,j)*(1.0-z1/zc(i,j)) + dtc = dt_cool(i,j) * (one-z1/zc(i,j)) endif endif endif - endif ! if ( wet(i,j) .and. .not.icy(i,j) ) then - enddo - enddo -! ! get the mean T departure from Tf in the range of z=z1 to z=z2 - -! DH* NEED NTHREADS HERE! TODO -!$omp parallel do private(j,i) - do j = 1, ny - do i= 1, nx -! if ( wet(i,j) .and. .not.icy(i,j)) then - if ( wet(i,j) ) then - dtm(i,j) = dtw(i,j) - dtc(i,j) - endif + dtm(i,j) = dtw - dtc + endif ! if ( wet(i,j)) then enddo enddo +! end subroutine get_dtzm_2d diff --git a/physics/moninedmf.f b/physics/moninedmf.f index 63edc3486..c8bf103fc 100644 --- a/physics/moninedmf.f +++ b/physics/moninedmf.f @@ -64,7 +64,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & & prsi,del,prsl,prslk,phii,phil,delt,dspheat, & & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & - & xkzminv,moninq_fac,lssav,ldiag3d,qdiag3d,lsidea,ntoz, & + & xkzminv,moninq_fac,lssav,ldiag3d,qdiag3d,ntoz, & & du3dt_PBL,dv3dt_PBL,dt3dt_PBL,dq3dt_PBL,do3dt_PBL, & & flag_for_pbl_generic_tend, errmsg,errflg) ! @@ -76,7 +76,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & ! ! arguments ! - logical, intent(in) :: lprnt,lssav,ldiag3d,qdiag3d,lsidea + logical, intent(in) :: lprnt,lssav,ldiag3d,qdiag3d logical, intent(in) :: flag_for_pbl_generic_tend integer, intent(in) :: ipr integer, intent(in) :: im, km, ntrac, ntcw, kinver(im), ntoz @@ -1043,14 +1043,9 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend if(lssav .and. ldiag3d .and. .not. & & flag_for_pbl_generic_tend) then - if(lsidea) then - dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + ttend*rdt - else - dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + & - & ((ttend-hlw(i,k)-swh(i,k)*xmu(i))*rdt) - endif + dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + ttend*delt if(qdiag3d) then - dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + qtend*rdt + dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + qtend*delt endif endif enddo @@ -1071,7 +1066,7 @@ subroutine hedmf_run (im,km,ntrac,ntcw,dv,du,tau,rtg, & is = (kk-1) * km do k = 1, km do i = 1, im - qtend = (a2(i,k+is)-q1(i,k,kk))*rdt + qtend = (a2(i,k+is)-q1(i,k,kk)) do3dt_PBL(i,k) = do3dt_PBL(i,k)+qtend enddo enddo diff --git a/physics/moninedmf.meta b/physics/moninedmf.meta index 196862ae6..da1268daf 100644 --- a/physics/moninedmf.meta +++ b/physics/moninedmf.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = hedmf + type = scheme + dependencies = funcphys.f90,machine.F,mfpbl.f,physcons.F90,tridi.f + +######################################################################## [ccpp-arg-table] name = hedmf_init type = scheme @@ -515,14 +521,6 @@ type = logical intent = in optional = F -[lsidea] - standard_name = flag_idealized_physics - long_name = flag for idealized physics - units = flag - dimensions = () - type = logical - intent = in - optional = F [ntoz] standard_name = index_for_ozone long_name = tracer index for ozone mixing ratio @@ -535,7 +533,7 @@ standard_name = cumulative_change_in_x_wind_due_to_PBL long_name = cumulative change in x wind due to PBL units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -544,7 +542,7 @@ standard_name = cumulative_change_in_y_wind_due_to_PBL long_name = cumulative change in y wind due to PBL units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -553,7 +551,7 @@ standard_name = cumulative_change_in_temperature_due_to_PBL long_name = cumulative change in temperature due to PBL units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -562,7 +560,7 @@ standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL long_name = cumulative change in water vapor specific humidity due to PBL units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -571,7 +569,7 @@ standard_name = cumulative_change_in_ozone_mixing_ratio_due_to_PBL long_name = cumulative change in ozone mixing ratio due to PBL units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout diff --git a/physics/moninedmf_hafs.meta b/physics/moninedmf_hafs.meta index 2883e6847..d79245330 100644 --- a/physics/moninedmf_hafs.meta +++ b/physics/moninedmf_hafs.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = hedmf_hafs + type = scheme + dependencies = funcphys.f90,machine.F,mfpbl.f,physcons.F90 + +######################################################################## [ccpp-arg-table] name = hedmf_hafs_init type = scheme diff --git a/physics/moninshoc.f b/physics/moninshoc.f index 86cab9643..eb9a5d963 100644 --- a/physics/moninshoc.f +++ b/physics/moninshoc.f @@ -31,7 +31,9 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, & prsi,del,prsl,prslk,phii,phil,delt, & dusfc,dvsfc,dtsfc,dqsfc,dkt,hpbl, & kinver,xkzm_m,xkzm_h,xkzm_s,xkzminv, - & grav, rd, cp, hvap, fv, + & grav,rd,cp,hvap,fv,ntoz,dt3dt_PBL, + & du3dt_PBL,dv3dt_PBL,dq3dt_PBL,do3dt_PBL, + & gen_tend,ldiag3d,qdiag3d, & errmsg,errflg) ! use machine , only : kind_phys @@ -42,7 +44,7 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! arguments ! integer, intent(in) :: im, - & km, ntrac, ntcw, ncnd, ntke + & km, ntrac, ntcw, ncnd, ntke, ntoz integer, dimension(im), intent(in) :: kinver real(kind=kind_phys), intent(in) :: delt, @@ -60,6 +62,11 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, & tau real(kind=kind_phys), dimension(im,km,ntrac), intent(inout) :: rtg + real(kind=kind_phys), dimension(:,:), intent(inout) :: + & du3dt_PBL, dv3dt_PBL, dt3dt_PBL, dq3dt_PBL, do3dt_PBL + logical, intent(in) :: ldiag3d, + & qdiag3d, gen_tend + integer, dimension(im), intent(out) :: kpbl real(kind=kind_phys), dimension(im), intent(out) :: dusfc, & dvsfc, dtsfc, dqsfc, hpbl @@ -71,6 +78,7 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! ! locals ! + integer, parameter :: kp = kind_phys integer i,is,k,kk,km1,kmpbl,kp1, ntloc ! logical pblflg(im), sfcflg(im), flg(im) @@ -91,21 +99,23 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, &, ttend, utend, vtend, qtend &, spdk2, rbint, ri, zol1, robn, bvf2 ! - real(kind=kind_phys), parameter :: zolcr=0.2, - & zolcru=-0.5, rimin=-100., sfcfrac=0.1, - & crbcon=0.25, crbmin=0.15, crbmax=0.35, - & qmin=1.e-8, zfmin=1.e-8, qlmin=1.e-12, - & aphi5=5., aphi16=16., f0=1.e-4 - &, dkmin=0.0, dkmax=1000. -! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 - &, prmin=0.25, prmax=4.0, vk=0.4, cfac=6.5 - real(kind=kind_phys) :: gravi, cont, conq, conw, gocp + real(kind=kind_phys), parameter :: one=1.0_kp, zero=0.0_kp + &, zolcr=0.2_kp, + & zolcru=-0.5_kp, rimin=-100.0_kp, sfcfrac=0.1_kp, + & crbcon=0.25_kp, crbmin=0.15_kp, crbmax=0.35_kp, + & qmin=1.0e-8_kp, zfmin=1.0d-8, qlmin=1.0e-12_kp, + & aphi5=5.0_kp, aphi16=16.0_kp, f0=1.0e-4_kp + &, dkmin=zero, dkmax=1000.0_kp +! &, dkmin=zero, dkmax=1000., xkzminv=0.3 + &, prmin=0.25_kp, prmax=4.0_kp, vk=0.4_kp, + & cfac=6.5_kp + real(kind=kind_phys) :: gravi, cont, conq, gocp, go2 - gravi = 1.0/grav - cont = cp/grav - conq = hvap/grav - conw = 1.0/grav - gocp = grav/cp + gravi = one / grav + cont = cp * gravi + conq = hvap * gravi + gocp = grav / cp + go2 = grav * 0.5_kp ! Initialize CCPP error handling variables errmsg = '' @@ -116,11 +126,11 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! compute preliminary variables ! dt2 = delt - rdt = 1. / dt2 + rdt = one / dt2 km1 = km - 1 kmpbl = km / 2 ! - rtg = 0.0 + rtg = zero ! do k=1,km do i=1,im @@ -135,24 +145,24 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! do k = 1,km1 do i=1,im - rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) - prnum(i,k) = 1.0 + rdzt(i,k) = one / (zl(i,k+1) - zl(i,k)) + prnum(i,k) = one enddo enddo ! Setup backgrond diffision do i=1,im - prnum(i,km) = 1.0 - tx1(i) = 1.0 / prsi(i,1) + prnum(i,km) = one + tx1(i) = one / prsi(i,1) enddo do k = 1,km1 do i=1,im - xkzo(i,k) = 0.0 - xkzmo(i,k) = 0.0 + xkzo(i,k) = zero + xkzmo(i,k) = zero ! if (k < kinver(i)) then if (k <= kinver(i)) then ! vertical background diffusivity for heat and momentum - tem1 = 1.0 - prsi(i,k+1) * tx1(i) - tem1 = min(1.0, exp(-tem1 * tem1 * 10.0)) + tem1 = one - prsi(i,k+1) * tx1(i) + tem1 = min(one, exp(-tem1 * tem1 * 10.0_kp)) xkzo(i,k) = xkzm_h * tem1 xkzmo(i,k) = xkzm_m * tem1 endif @@ -163,9 +173,9 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! do k = 1,kmpbl do i=1,im - if(zi(i,k+1) > 250.) then + if(zi(i,k+1) > 250.0_kp) then tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 > 1.e-5) then + if(tem1 > 1.0e-5_kp) then xkzo(i,k) = min(xkzo(i,k),xkzminv) endif endif @@ -174,21 +184,21 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! ! do i = 1,im - z0(i) = 0.01 * zorl(i) + z0(i) = 0.01_kp * zorl(i) kpbl(i) = 1 hpbl(i) = zi(i,1) pblflg(i) = .true. sfcflg(i) = .true. - if(rbsoil(i) > 0.) sfcflg(i) = .false. - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. + if(rbsoil(i) > zero) sfcflg(i) = .false. + dusfc(i) = zero + dvsfc(i) = zero + dtsfc(i) = zero + dqsfc(i) = zero enddo ! do k = 1,km do i=1,im - tx1(i) = 0.0 + tx1(i) = zero enddo do kk=1,ncnd do i=1,im @@ -197,13 +207,13 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo do i = 1,im theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) - thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-tx1(i)) + thvx(i,k) = theta(i,k)*(one+fv*max(q1(i,k,1),qmin)-tx1(i)) enddo enddo ! do i = 1,im sflux(i) = heat(i) + evap(i)*fv*theta(i,1) - if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + if (.not.sfcflg(i) .or. sflux(i) <= zero) pblflg(i)=.false. beta(i) = dt2 / (zi(i,2)-zi(i,1)) enddo ! @@ -214,22 +224,23 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, flg(i) = .false. rbup(i) = rbsoil(i) ! - if(pblflg(i)) then + if (pblflg(i)) then thermal(i) = thvx(i,1) crb(i) = crbcon else - thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) - tem = max(1.0, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i))) + thermal(i) = tsea(i)*(one+fv*max(q1(i,1,1),qmin)) + tem = max(one, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i))) robn = tem / (f0 * z0(i)) - tem1 = 1.e-7 * robn - crb(i) = max(min(0.16 * (tem1 ** (-0.18)), crbmax), crbmin) + tem1 = 1.0e-7_kp * robn + crb(i) = max(min(0.16_kp * (tem1 ** (-0.18_kp)), crbmax), + & crbmin) endif enddo do k = 1, kmpbl do i = 1, im - if(.not.flg(i)) then + if (.not.flg(i)) then rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), 1.) + spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), one) rbup(i) = (thvx(i,k)-thermal(i))*phil(i,k) & / (thvx(i,1)*spdk2) kpbl(i) = k @@ -240,10 +251,10 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, do i = 1,im if(kpbl(i) > 1) then k = kpbl(i) - if(rbdn(i) >= crb(i)) then - rbint = 0. + if (rbdn(i) >= crb(i)) then + rbint = zero elseif(rbup(i) <= crb(i)) then - rbint = 1. + rbint = one else rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i)) endif @@ -259,20 +270,20 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! do i=1,im zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) - if(sfcflg(i)) then + if (sfcflg(i)) then zol(i) = min(zol(i),-zfmin) else zol(i) = max(zol(i),zfmin) endif zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) - if(sfcflg(i)) then + if (sfcflg(i)) then ! phim(i) = (1.-aphi16*zol1)**(-1./4.) ! phih(i) = (1.-aphi16*zol1)**(-1./2.) - tem = 1.0 / max(1. - aphi16*zol1, 1.0e-8) + tem = one / max(one - aphi16*zol1, 1.0e-8_kp) phih(i) = sqrt(tem) phim(i) = sqrt(phih(i)) else - phim(i) = 1. + aphi5*zol1 + phim(i) = one + aphi5*zol1 phih(i) = phim(i) endif enddo @@ -288,9 +299,9 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo do k = 2, kmpbl do i = 1, im - if(.not.flg(i)) then + if (.not.flg(i)) then rbdn(i) = rbup(i) - spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), 1.) + spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)), one) rbup(i) = (thvx(i,k)-thermal(i)) * phil(i,k) & / (thvx(i,1)*spdk2) kpbl(i) = k @@ -302,9 +313,9 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, if (pblflg(i)) then k = kpbl(i) if(rbdn(i) >= crb(i)) then - rbint = 0. + rbint = zero elseif(rbup(i) <= crb(i)) then - rbint = 1. + rbint = one else rbint = (crb(i)-rbdn(i)) / (rbup(i)-rbdn(i)) endif @@ -342,19 +353,18 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, tem = u1(i,k) - u1(i,kp1) tem1 = v1(i,k) - v1(i,kp1) tem = (tem*tem + tem1*tem1) * rdz * rdz - bvf2 = (0.5*grav)*(thvx(i,kp1)-thvx(i,k))*rdz - & / (t1(i,k)+t1(i,kp1)) + bvf2 = go2*(thvx(i,kp1)-thvx(i,k))*rdz / (t1(i,k)+t1(i,kp1)) ri = max(bvf2/tem,rimin) - if(ri < 0.) then ! unstable regime - prnum(i,kp1) = 1.0 + if(ri < zero) then ! unstable regime + prnum(i,kp1) = one else - prnum(i,kp1) = min(1.0 + 2.1*ri, prmax) + prnum(i,kp1) = min(one + 2.1_kp*ri, prmax) endif elseif (k > 1) then prnum(i,kp1) = prnum(i,1) endif ! -! prnum(i,kp1) = 1.0 +! prnum(i,kp1) = one prnum(i,kp1) = max(prmin, min(prmax, prnum(i,kp1))) tem = tkh(i,kp1) * prnum(i,kp1) dku(i,k) = max(min(tem+xkzmo(i,k), dkmax), xkzmo(i,k)) @@ -365,7 +375,7 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! compute tridiagonal matrix elements for heat and moisture ! do i=1,im - ad(i,1) = 1. + ad(i,1) = one a1(i,1) = t1(i,1) + beta(i) * heat(i) a2(i,1) = q1(i,1,1) + beta(i) * evap(i) enddo @@ -397,7 +407,7 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, al(i,k) = -dtodsu*dsdz2 ! ad(i,k) = ad(i,k)-au(i,k) - ad(i,kp1) = 1.-al(i,k) + ad(i,kp1) = one - al(i,k) dsdzt = tem1 * gocp a1(i,k) = a1(i,k) + dtodsd*dsdzt a1(i,kp1) = t1(i,kp1) - dtodsu*dsdzt @@ -421,7 +431,7 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo endif ! -! solve tridiagonal problem for heat and moisture +! solve tridiagonal problem for heat, moisture and tracers ! call tridin(im,km,ntloc,al,ad,au,a1,a2,au,a1,a2) @@ -429,14 +439,34 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! recover tendencies of heat and moisture ! do k = 1,km - do i = 1,im - ttend = (a1(i,k)-t1(i,k)) * rdt - qtend = (a2(i,k)-q1(i,k,1)) * rdt - tau(i,k) = tau(i,k) + ttend - rtg(i,k,1) = rtg(i,k,1) + qtend - dtsfc(i) = dtsfc(i) + cont*del(i,k)*ttend - dqsfc(i) = dqsfc(i) + conq*del(i,k)*qtend - enddo + do i = 1,im + ttend = (a1(i,k)-t1(i,k)) * rdt + qtend = (a2(i,k)-q1(i,k,1)) * rdt + tau(i,k) = tau(i,k) + ttend + rtg(i,k,1) = rtg(i,k,1) + qtend + dtsfc(i) = dtsfc(i) + del(i,k)*ttend + dqsfc(i) = dqsfc(i) + del(i,k)*qtend + enddo + enddo + if(ldiag3d .and. .not. gen_tend) then + do k = 1,km + do i = 1,im + ttend = (a1(i,k)-t1(i,k)) + dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + ttend + enddo + enddo + if(qdiag3d) then + do k = 1,km + do i = 1,im + qtend = (a2(i,k)-q1(i,k,1)) + dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + qtend + enddo + enddo + endif + endif + do i = 1,im + dtsfc(i) = dtsfc(i) * cont + dqsfc(i) = dqsfc(i) * conq enddo if(ntrac > 1) then is = 0 @@ -451,12 +481,22 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, enddo endif enddo + if(ldiag3d .and. ntoz>0 .and. qdiag3d .and. .not. gen_tend) then + kk = ntoz + is = (kk-1) * km + do k = 1, km + do i = 1, im + qtend = (a2(i,k+is)-q1(i,k,kk)) + do3dt_PBL(i,k) = do3dt_PBL(i,k)+qtend + enddo + enddo + endif endif ! ! compute tridiagonal matrix elements for momentum ! do i=1,im - ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) + ad(i,1) = one + beta(i) * stress(i) / spd1(i) a1(i,1) = u1(i,1) a2(i,1) = v1(i,1) enddo @@ -474,7 +514,7 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, al(i,k) = -dtodsu*dsdz2 ! ad(i,k) = ad(i,k) - au(i,k) - ad(i,kp1) = 1.0 - al(i,k) + ad(i,kp1) = one - al(i,k) a1(i,kp1) = u1(i,kp1) a2(i,kp1) = v1(i,kp1) ! @@ -491,17 +531,28 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, vtend = (a2(i,k)-v1(i,k))*rdt du(i,k) = du(i,k) + utend dv(i,k) = dv(i,k) + vtend - dusfc(i) = dusfc(i) + conw*del(i,k)*utend - dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend + tem = del(i,k) * gravi + dusfc(i) = dusfc(i) + tem * utend + dvsfc(i) = dvsfc(i) + tem * vtend enddo enddo + if (ldiag3d .and. .not. gen_tend) then + do k = 1,km + do i = 1,im + utend = (a1(i,k)-u1(i,k)) + vtend = (a2(i,k)-v1(i,k)) + du3dt_PBL(i,k) = du3dt_PBL(i,k) + utend + dv3dt_PBL(i,k) = dv3dt_PBL(i,k) + vtend + enddo + enddo + endif ! if (ntke > 0) then ! solve tridiagonal problem for momentum and tke ! ! compute tridiagonal matrix elements for tke ! do i=1,im - ad(i,1) = 1.0 + ad(i,1) = one a1(i,1) = q1(i,1,ntke) enddo ! @@ -518,7 +569,7 @@ subroutine moninshoc_run (im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, al(i,k) = -dtodsu*dsdz2 ! ad(i,k) = ad(i,k) - au(i,k) - ad(i,kp1) = 1.0 - al(i,k) + ad(i,kp1) = one - al(i,k) a1(i,kp1) = q1(i,kp1,ntke) enddo enddo diff --git a/physics/moninshoc.meta b/physics/moninshoc.meta index e8da8478d..b960fdaa1 100644 --- a/physics/moninshoc.meta +++ b/physics/moninshoc.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = moninshoc + type = scheme + dependencies = funcphys.f90,machine.F,tridi.f + +######################################################################## [ccpp-arg-table] name = moninshoc_run type = scheme @@ -461,6 +467,76 @@ kind = kind_phys intent = in optional = F +[ntoz] + standard_name = index_for_ozone + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in + optional = F +[dt3dt_PBL] + standard_name = cumulative_change_in_temperature_due_to_PBL + long_name = cumulative change in temperature due to PBL + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[du3dt_PBL] + standard_name = cumulative_change_in_x_wind_due_to_PBL + long_name = cumulative change in x wind due to PBL + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dv3dt_PBL] + standard_name = cumulative_change_in_y_wind_due_to_PBL + long_name = cumulative change in y wind due to PBL + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dq3dt_PBL] + standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL + long_name = cumulative change in water vapor specific humidity due to PBL + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[do3dt_PBL] + standard_name = cumulative_change_in_ozone_mixing_ratio_due_to_PBL + long_name = cumulative change in ozone mixing ratio due to PBL + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[gen_tend] + standard_name = flag_for_generic_planetary_boundary_layer_tendency + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/mp_fer_hires.meta b/physics/mp_fer_hires.meta index a7a33378a..a0591ade8 100644 --- a/physics/mp_fer_hires.meta +++ b/physics/mp_fer_hires.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = mp_fer_hires + type = scheme + dependencies = machine.F,module_MP_FER_HIRES.F90 + +######################################################################## [ccpp-arg-table] name = mp_fer_hires_init type = scheme @@ -127,10 +133,6 @@ intent = out optional = F ######################################################################## -[ccpp-arg-table] - name = mp_fer_hires_finalize - type = scheme -######################################################################## [ccpp-arg-table] name = mp_fer_hires_run type = scheme diff --git a/physics/mp_thompson.meta b/physics/mp_thompson.meta index 5bbd85732..427b2bc84 100644 --- a/physics/mp_thompson.meta +++ b/physics/mp_thompson.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = mp_thompson + type = scheme + dependencies = machine.F,module_mp_radar.F90,module_mp_thompson.F90,module_mp_thompson_make_number_concentrations.F90 + +######################################################################## [ccpp-arg-table] name = mp_thompson_init type = scheme diff --git a/physics/mp_thompson_post.meta b/physics/mp_thompson_post.meta index eeaeeb65d..2c68fc78a 100644 --- a/physics/mp_thompson_post.meta +++ b/physics/mp_thompson_post.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = mp_thompson_post + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = mp_thompson_post_init type = scheme diff --git a/physics/mp_thompson_pre.meta b/physics/mp_thompson_pre.meta index 5782c10f6..2511ba3bc 100644 --- a/physics/mp_thompson_pre.meta +++ b/physics/mp_thompson_pre.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = mp_thompson_pre + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = mp_thompson_pre_run type = scheme diff --git a/physics/num_parthds.F b/physics/num_parthds.F deleted file mode 100644 index 922ae4a4f..000000000 --- a/physics/num_parthds.F +++ /dev/null @@ -1,23 +0,0 @@ - function num_parthds() -#ifdef _OPENMP -#include -!$OMP PARALLEL - num_parthds=omp_get_num_threads() -!$OMP END PARALLEL -#else -! num_parthds=8 - num_parthds=1 -#endif - return - end - -!GFDL function num_parthds() -!GFDL integer:: number_of_openMP_threads -!GFDL character(2) :: omp_threads -!GFDL integer :: stat -!GFDL call get_environment_variable("OMP_NUM_THREADS",omp_threads) -!GFDL read(omp_threads,*,iostat=stat)number_of_openMP_threads -!GFDL num_parthds = number_of_openMP_threads -!GFDL return -!GFDL end - diff --git a/physics/ozphys.meta b/physics/ozphys.meta index 4f0e6aa9d..b43f7931c 100644 --- a/physics/ozphys.meta +++ b/physics/ozphys.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = ozphys + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = ozphys_init type = scheme @@ -27,11 +33,6 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = ozphys_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = ozphys_run diff --git a/physics/ozphys_2015.meta b/physics/ozphys_2015.meta index bfc010358..2db91982f 100644 --- a/physics/ozphys_2015.meta +++ b/physics/ozphys_2015.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = ozphys_2015 + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = ozphys_2015_init type = scheme @@ -27,11 +33,6 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = ozphys_2015_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = ozphys_2015_run diff --git a/physics/phys_tend.meta b/physics/phys_tend.meta index 48c189c07..b5637063c 100644 --- a/physics/phys_tend.meta +++ b/physics/phys_tend.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = phys_tend + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = phys_tend_run type = scheme diff --git a/physics/physparam.f b/physics/physparam.f index 0747b2a14..c71b62e5b 100644 --- a/physics/physparam.f +++ b/physics/physparam.f @@ -251,7 +251,7 @@ module physparam !!\n =0:use constant decorrelation length defined by decorr_con (in module physcons) !!\n =1:use day-of-year and latitude-varying decorrelation length integer, save :: idcor = 1 - + !> sub-column cloud approx flag in SW radiation !!\n =0:no McICA approximation in SW radiation !!\n =1:use McICA with precribed permutation seeds (test mode) diff --git a/physics/precpd.meta b/physics/precpd.meta index 6df3f35af..3d76d18ed 100644 --- a/physics/precpd.meta +++ b/physics/precpd.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = zhaocarr_precpd_init +[ccpp-table-properties] + name = zhaocarr_precpd type = scheme + dependencies = funcphys.f90,machine.F,physcons.F90 ######################################################################## [ccpp-arg-table] @@ -191,7 +192,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = zhaocarr_precpd_finalize - type = scheme diff --git a/physics/radiation_clouds.f b/physics/radiation_clouds.f index f6d7e32cb..828db4ed0 100644 --- a/physics/radiation_clouds.f +++ b/physics/radiation_clouds.f @@ -25,16 +25,18 @@ ! IX, NLAY, NLP1, ! ! uni_cld, lmfshal, lmfdeep2, cldcov, ! ! effrl,effri,effrr,effrs,effr_in, ! +! dzlay, latdeg, julian, yearlen, ! ! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! +! clouds,clds,mtop,mbot,de_lgth,alpha) ! ! ! ! 'progcld2' --- ferrier prognostic cloud microphysics ! ! inputs: ! ! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! ! xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, ! ! IX, NLAY, NLP1, lmfshal, lmfdeep2, ! +! dzlay, latdeg, julian, yearlen, ! ! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! +! clouds,clds,mtop,mbot,de_lgth,alpha) ! ! ! ! 'progcld3' --- zhao/moorthi prognostic cloud + pdfcld! ! inputs: ! @@ -42,16 +44,18 @@ ! xlat,xlon,slmsk, dz, delp, ! ! ix, nlay, nlp1, ! ! deltaq,sup,kdt,me, ! +! dzlay, latdeg, julian, yearlen, ! ! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! +! clouds,clds,mtop,mbot,de_lgth,alpha) ! ! ! ! 'progcld4' --- gfdl-lin cloud microphysics ! ! inputs: ! ! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, ! ! xlat,xlon,slmsk, dz, delp, ! ! ix, nlay, nlp1, ! +! dzlay, latdeg, julian, yearlen, ! ! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! +! clouds,clds,mtop,mbot,de_lgth,alpha) ! ! ! ! 'progcld4o' --- inactive ! ! ! @@ -63,16 +67,18 @@ ! ix, nlay, nlp1, ! ! uni_cld, lmfshal, lmfdeep2, cldcov, ! ! re_cloud,re_ice,re_snow, ! +! dzlay, latdeg, julian, yearlen, ! ! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! +! clouds,clds,mtop,mbot,de_lgth,alpha) ! ! ! ! 'progclduni' --- for unified clouds with MG microphys! ! inputs: ! ! (plyr,plvl,tlyr,tvly,ccnd,ncnd, ! ! xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, ! ! effrl,effri,effrr,effrs,effr_in, ! +! dzlay, latdeg, julian, yearlen, ! ! outputs: ! -! clouds,clds,mtop,mbot,de_lgth) ! +! clouds,clds,mtop,mbot,de_lgth,alpha) ! ! ! ! internal accessable only subroutines: ! ! 'gethml' --- get diagnostic hi, mid, low clouds ! @@ -154,6 +160,10 @@ ! 'diagcld1' for diagnostic cloud scheme, added new cloud ! ! overlapping method of de-correlation length, and optimized ! ! the code structure. ! +! jul 2020, m.j. iacono - added rrtmg/mcica cloud overlap options ! +! exponential and exponential-random. each method can use ! +! either a constant or a latitude-varying and day-of-year ! +! varying decorrelation length selected with parameter "idcor". ! ! ! !!!!! ========================================================== !!!!! !!!!! end descriptions !!!!! @@ -181,6 +191,10 @@ !! Cloud overlapping method (namelist control parameter - \b IOVR_LW, \b IOVR_SW) !!\n IOVR=0: randomly overlapping vertical cloud layers !!\n IOVR=1: maximum-random overlapping vertical cloud layers +!!\n IOVR=2: maximum overlapping vertical cloud layers +!!\n IOVR=3: decorrelation length overlapping vertical cloud layers +!!\n IOVR=4: exponential overlapping vertical cloud layers +!!\n IOVR=5: exponential-random overlapping vertical cloud layers !! !! Sub-grid cloud approximation (namelist control parameter - \b ISUBC_LW=2, \b ISUBC_SW=2) !!\n ISUBC=0: grid averaged quantities, without sub-grid cloud approximation @@ -244,7 +258,7 @@ module module_radiation_clouds public progcld1, progcld2, progcld3, progcld4, progclduni, & & cld_init, progcld5, progcld4o, gethml, & - & get_alpha_dcorr, get_alpha_exp + & get_alpha_dcorr, get_alpha_exp ! ================= @@ -303,6 +317,8 @@ subroutine cld_init & ! =1: max/ran overlapping clouds ! ! =2: maximum overlap clouds (mcica only) ! ! =3: decorrelation-length overlap (mcica only) ! +! =4: exponential cloud overlap (AER; mcica only) ! +! =5: exponential-random overlap (AER; mcica only) ! ! ivflip : control flag for direction of vertical index ! ! =0: index from toa to surface ! ! =1: index from surface to toa ! @@ -418,6 +434,10 @@ end subroutine cld_init !!\param effrr effective radius for rain water !!\param effrs effective radius for snow water !!\param effr_in logical, if .true. use input effective radii +!!\param dzlay(ix,nlay) distance between model layer centers +!!\param latdeg(ix) latitude (in degrees 90 -> -90) +!!\param julian day of the year (fractional julian day) +!!\param yearlen current length of the year (365/366 days) !!\param clouds (IX,NLAY,NF_CLDS), cloud profiles !!\n (:,:,1) - layer total cloud fraction !!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ @@ -431,7 +451,8 @@ end subroutine cld_init !!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl !!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops !!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases -!!\param de_lgth (IX), clouds decorrelation length (km) +!!\param de_lgth (IX), clouds decorrelation length (km) +!!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progcld1 progcld1 General Algorithm !> @{ subroutine progcld1 & @@ -439,7 +460,8 @@ subroutine progcld1 & & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & effrl,effri,effrr,effrs,effr_in, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & dzlay, latdeg, julian, yearlen, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -486,6 +508,10 @@ subroutine progcld1 & ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! latdeg(ix) : latitude (in degrees 90 -> -90) ! +! julian : day of the year (fractional julian day) ! +! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -503,6 +529,7 @@ subroutine progcld1 & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -528,16 +555,21 @@ subroutine progcld1 & real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov, delp, dz, & - & effrl, effri, effrr, effrs + & effrl, effri, effrr, effrs, dzlay real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian + integer, intent(in) :: yearlen + ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds real (kind=kind_phys), dimension(:,:), intent(out) :: clds real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(out) :: alpha integer, dimension(:,:), intent(out) :: mtop,mbot @@ -805,6 +837,16 @@ subroutine progcld1 & enddo endif +!> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options + if ( iovr == 4 .or. iovr == 5 ) then + call get_alpha_exp & +! --- inputs: + & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & +! --- outputs: + & alpha & + & ) + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. The three cloud domain boundaries are defined by @@ -812,7 +854,7 @@ subroutine progcld1 & !! 'iovr', which may be different for lw and sw radiation programs. call gethml & ! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & & IX,NLAY, & ! --- outputs: & clds, mtop, mbot & @@ -851,6 +893,10 @@ end subroutine progcld1 !!\param NLAY,NLP1 vertical layer/level dimensions !!\param lmfshal flag for mass-flux shallow convection scheme in the cloud fraction calculation !!\param lmfdeep2 flag for mass-flux deep convection scheme in the cloud fraction calculation +!!\param dzlay(ix,nlay) distance between model layer centers +!!\param latdeg(ix) latitude (in degrees 90 -> -90) +!!\param julian day of the year (fractional julian day) +!!\param yearlen current length of the year (365/366 days) !!\param clouds (IX,NLAY,NF_CLDS), cloud profiles !!\n (:,:,1) - layer total cloud fraction !!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ @@ -865,13 +911,15 @@ end subroutine progcld1 !!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops !!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases !!\param de_lgth (IX), clouds decorrelation length (km) +!!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progcld2 progcld2 General Algorithm !> @{ subroutine progcld2 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, f_ice,f_rain,r_rime,flgmin, & & IX, NLAY, NLP1, lmfshal, lmfdeep2, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & dzlay, latdeg, julian, yearlen, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -918,6 +966,10 @@ subroutine progcld2 & ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! latdeg(ix) : latitude (in degrees 90 -> -90) ! +! julian : day of the year (fractional julian day) ! +! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -935,6 +987,7 @@ subroutine progcld2 & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! external module variables: ! ! ivflip : control flag of vertical index direction ! @@ -965,17 +1018,22 @@ subroutine progcld2 & real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, f_ice, f_rain, r_rime, & - & dz, delp + & dz, delp, dzlay real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk real (kind=kind_phys), dimension(:), intent(in) :: flgmin + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian + integer, intent(in) :: yearlen + ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds real (kind=kind_phys), dimension(:,:), intent(out) :: clds real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(out) :: alpha integer, dimension(:,:), intent(out) :: mtop,mbot @@ -1251,6 +1309,16 @@ subroutine progcld2 & enddo endif +!> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options + if ( iovr == 4 .or. iovr == 5 ) then + call get_alpha_exp & +! --- inputs: + & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & +! --- outputs: + & alpha & + & ) + endif + !> - Call gethml(), to compute low, mid, high, total, and boundary !! layer cloud fractions and clouds top/bottom layer indices for low, !! mid, and high clouds. @@ -1260,7 +1328,7 @@ subroutine progcld2 & call gethml & ! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & & IX,NLAY, & ! --- outputs: & clds, mtop, mbot & @@ -1299,6 +1367,10 @@ end subroutine progcld2 !!\param sup supersaturation !!\param kdt !!\param me print control flag +!!\param dzlay(ix,nlay) distance between model layer centers +!!\param latdeg(ix) latitude (in degrees 90 -> -90) +!!\param julian day of the year (fractional julian day) +!!\param yearlen current length of the year (365/366 days) !!\param clouds (ix,nlay,nf_clds), cloud profiles !!\n (:,:,1) - layer total cloud fraction !!\n (:,:,2) - layer cloud liq water path (g/m**2) @@ -1313,6 +1385,7 @@ end subroutine progcld2 !!\param mtop (ix,3), vertical indices for low, mid, hi cloud tops !!\param mbot (ix,3), vertical indices for low, mid, hi cloud bases !!\param de_lgth (ix), clouds decorrelation length (km) +!!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progcld3 progcld3 General Algorithm !! @{ subroutine progcld3 & @@ -1320,7 +1393,8 @@ subroutine progcld3 & & xlat,xlon,slmsk, dz, delp, & & ix, nlay, nlp1, & & deltaq,sup,kdt,me, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & dzlay, latdeg, julian, yearlen, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -1367,6 +1441,10 @@ subroutine progcld3 & ! cnvc (ix,nlay) : layer convective cloud cover ! ! deltaq(ix,nlay) : half total water distribution width ! ! sup : supersaturation ! +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! latdeg(ix) : latitude (in degrees 90 -> -90) ! +! julian : day of the year (fractional julian day) ! +! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! @@ -1385,6 +1463,7 @@ subroutine progcld3 & ! mtop (ix,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (ix,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -1405,7 +1484,7 @@ subroutine progcld3 & integer, intent(in) :: ix, nlay, nlp1,kdt real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp + & tlyr, tvly, qlyr, qstl, rhly, clw, dz, delp, dzlay ! & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc ! real (kind=kind_phys), dimension(:,:), intent(in) :: deltaq real (kind=kind_phys), dimension(:,:) :: deltaq, cnvw, cnvc @@ -1417,11 +1496,16 @@ subroutine progcld3 & & slmsk integer :: me + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian + integer, intent(in) :: yearlen + ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds real (kind=kind_phys), dimension(:,:), intent(out) :: clds real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(out) :: alpha integer, dimension(:,:), intent(out) :: mtop,mbot @@ -1648,6 +1732,16 @@ subroutine progcld3 & enddo endif +!> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options + if ( iovr == 4 .or. iovr == 5 ) then + call get_alpha_exp & +! --- inputs: + & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & +! --- outputs: + & alpha & + & ) + endif + !> -# Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -1658,7 +1752,7 @@ subroutine progcld3 & call gethml & ! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & & ix,nlay, & ! --- outputs: & clds, mtop, mbot & @@ -1697,6 +1791,10 @@ end subroutine progcld3 !!\param ix horizontal dimension !!\param nlay vertical layer dimension !!\param nlp1 vertical level dimension +!!\param dzlay(ix,nlay) distance between model layer centers +!!\param latdeg(ix) latitude (in degrees 90 -> -90) +!!\param julian day of the year (fractional julian day) +!!\param yearlen current length of the year (365/366 days) !!\param clouds (ix,nlay,nf_clds), cloud profiles !!\n clouds(:,:,1) - layer total cloud fraction !!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) @@ -1711,13 +1809,15 @@ end subroutine progcld3 !!\param mtop vertical indices for low, mid, hi cloud tops !!\param mbot vertical indices for low, mid, hi cloud bases !!\param de_lgth clouds decorrelation length (km) +!!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progcld4 progcld4 General Algorithm !! @{ subroutine progcld4 & & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: & xlat,xlon,slmsk,cldtot, dz, delp, & & IX, NLAY, NLP1, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & dzlay, latdeg, julian, yearlen, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -1762,6 +1862,10 @@ subroutine progcld4 & ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! latdeg(ix) : latitude (in degrees 90 -> -90) ! +! julian : day of the year (fractional julian day) ! +! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -1779,6 +1883,7 @@ subroutine progcld4 & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -1801,16 +1906,21 @@ subroutine progcld4 & real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot, cnvw, cnvc, & - & delp, dz + & delp, dz, dzlay real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian + integer, intent(in) :: yearlen + ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds real (kind=kind_phys), dimension(:,:), intent(out) :: clds real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(out) :: alpha integer, dimension(:,:), intent(out) :: mtop,mbot @@ -1985,6 +2095,16 @@ subroutine progcld4 & enddo endif +!> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options + if ( iovr == 4 .or. iovr == 5 ) then + call get_alpha_exp & +! --- inputs: + & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & +! --- outputs: + & alpha & + & ) + endif + ! --- compute low, mid, high, total, and boundary layer cloud fractions ! and clouds top/bottom layer indices for low, mid, and high clouds. ! The three cloud domain boundaries are defined by ptopc. The cloud @@ -1993,7 +2113,7 @@ subroutine progcld4 & call gethml & ! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & & IX,NLAY, & ! --- outputs: & clds, mtop, mbot & @@ -2037,6 +2157,10 @@ end subroutine progcld4 !>\param ix horizontal dimension !>\param nlay vertical layer dimension !>\param nlp1 vertical level dimension +!!\param dzlay(ix,nlay) distance between model layer centers +!!\param latdeg(ix) latitude (in degrees 90 -> -90) +!!\param julian day of the year (fractional julian day) +!!\param yearlen current length of the year (365/366 days) !>\param clouds (ix,nlay,nf_clds), cloud profiles !!\n clouds(:,:,1) - layer totoal cloud fraction !!\n clouds(:,:,2) - layer cloud liquid water path (\f$g m^{-2}\f$) @@ -2051,6 +2175,7 @@ end subroutine progcld4 !>\param mtop (ix,3), vertical indices for low, mid, hi cloud tops !>\param mbot (ix,3), vertical indices for low, mid, hi cloud bases !>\param de_lgth clouds decorrelation length (km) +!!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progcld4o progcld4o General Algorithm !! @{ subroutine progcld4o & @@ -2058,7 +2183,8 @@ subroutine progcld4o & & xlat,xlon,slmsk, dz, delp, & & ntrac,ntcw,ntiw,ntrw,ntsw,ntgl,ntclamt, & & IX, NLAY, NLP1, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & dzlay, latdeg, julian, yearlen, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -2102,6 +2228,10 @@ subroutine progcld4o & ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! ! IX : horizontal dimention ! ! NLAY,NLP1 : vertical layer/level dimensions ! +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! latdeg(ix) : latitude (in degrees 90 -> -90) ! +! julian : day of the year (fractional julian day) ! +! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -2119,6 +2249,7 @@ subroutine progcld4o & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -2142,18 +2273,23 @@ subroutine progcld4o & & ntclamt real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, tvly, qlyr, qstl, rhly, delp, dz + & tlyr, tvly, qlyr, qstl, rhly, delp, dz, dzlay real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian + integer, intent(in) :: yearlen + ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds real (kind=kind_phys), dimension(:,:), intent(out) :: clds real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(out) :: alpha integer, dimension(:,:), intent(out) :: mtop,mbot @@ -2313,6 +2449,16 @@ subroutine progcld4o & enddo endif +!> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options + if ( iovr == 4 .or. iovr == 5 ) then + call get_alpha_exp & +! --- inputs: + & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & +! --- outputs: + & alpha & + & ) + endif + !> - Call gethml() to compute low, mid, high, total, and boundary layer cloud fractions !! and clouds top/bottom layer indices for low, mid, and high clouds. !! The three cloud domain boundaries are defined by ptopc. The cloud @@ -2321,7 +2467,7 @@ subroutine progcld4o & call gethml & ! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & & IX,NLAY, & ! --- outputs: & clds, mtop, mbot & @@ -2346,7 +2492,8 @@ subroutine progcld5 & & IX, NLAY, NLP1, & & uni_cld, lmfshal, lmfdeep2, cldcov, & & re_cloud,re_ice,re_snow, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & dzlay, latdeg, julian, yearlen, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -2393,6 +2540,10 @@ subroutine progcld5 & ! lmfshal : logical - true for mass flux shallow convection ! ! lmfdeep2 : logical - true for mass flux deep convection ! ! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! latdeg(ix) : latitude (in degrees 90 -> -90) ! +! julian : day of the year (fractional julian day) ! +! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -2410,6 +2561,7 @@ subroutine progcld5 & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -2435,7 +2587,7 @@ subroutine progcld5 & logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & - & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, & + & tlyr, qlyr, qstl, rhly, cldcov, delp, dz, dzlay, & & re_cloud, re_ice, re_snow real (kind=kind_phys), dimension(:,:,:), intent(in) :: clw @@ -2443,11 +2595,16 @@ subroutine progcld5 & real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian + integer, intent(in) :: yearlen + ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds real (kind=kind_phys), dimension(:,:), intent(out) :: clds real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(out) :: alpha integer, dimension(:,:), intent(out) :: mtop,mbot @@ -2660,6 +2817,16 @@ subroutine progcld5 & enddo endif +!> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options + if ( iovr == 4 .or. iovr == 5 ) then + call get_alpha_exp & +! --- inputs: + & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & +! --- outputs: + & alpha & + & ) + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -2671,7 +2838,7 @@ subroutine progcld5 & call gethml & ! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & & IX,NLAY, & ! --- outputs: & clds, mtop, mbot & @@ -2707,6 +2874,10 @@ end subroutine progcld5 !!\param effrr (IX,NLAY), effective radius for rain water !!\param effrs (IX,NLAY), effective radius for snow water !!\param effr_in logical - if .true. use input effective radii +!!\param dzlay(ix,nlay) distance between model layer centers +!!\param latdeg(ix) latitude (in degrees 90 -> -90) +!!\param julian day of the year (fractional julian day) +!!\param yearlen current length of the year (365/366 days) !!\param clouds (IX,NLAY,NF_CLDS), cloud profiles !!\n (:,:,1) - layer total cloud fraction !!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ @@ -2721,13 +2892,15 @@ end subroutine progcld5 !!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops !!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases !!\param de_lgth (IX), clouds decorrelation length (km) +!!\param alpha (IX,NLAY), alpha decorrelation parameter !>\section gen_progclduni progclduni General Algorithm !> @{ subroutine progclduni & & ( plyr,plvl,tlyr,tvly,ccnd,ncnd, & ! --- inputs: & xlat,xlon,slmsk,dz,delp, IX, NLAY, NLP1, cldtot, & & effrl,effri,effrr,effrs,effr_in, & - & clouds,clds,mtop,mbot,de_lgth & ! --- outputs: + & dzlay, latdeg, julian, yearlen, & + & clouds,clds,mtop,mbot,de_lgth,alpha & ! --- outputs: & ) ! ================= subprogram documentation block ================ ! @@ -2775,6 +2948,10 @@ subroutine progclduni & ! effr_in : logical - if .true. use input effective radii ! ! dz (ix,nlay) : layer thickness (km) ! ! delp (ix,nlay) : model layer pressure thickness in mb (100Pa) ! +! dzlay(ix,nlay) : thickness between model layer centers (km) ! +! latdeg(ix) : latitude (in degrees 90 -> -90) ! +! julian : day of the year (fractional julian day) ! +! yearlen : current length of the year (365/366 days) ! ! ! ! output variables: ! ! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! @@ -2792,6 +2969,7 @@ subroutine progclduni & ! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! ! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! ! de_lgth(ix) : clouds decorrelation length (km) ! +! alpha(ix,nlay) : alpha decorrelation parameter ! ! ! module variables: ! ! ivflip : control flag of vertical index direction ! @@ -2816,11 +2994,16 @@ subroutine progclduni & real (kind=kind_phys), dimension(:,:,:), intent(in) :: ccnd real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr,& - & tlyr, tvly, cldtot, effrl, effri, effrr, effrs, dz, delp + & tlyr, tvly, cldtot, effrl, effri, effrr, effrs, dz, delp, & + & dzlay real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & & slmsk + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: julian + integer, intent(in) :: yearlen + ! --- outputs real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds @@ -2828,6 +3011,8 @@ subroutine progclduni & real (kind=kind_phys), dimension(:), intent(out) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(out) :: alpha + integer, dimension(:,:), intent(out) :: mtop,mbot ! --- local variables: @@ -3027,6 +3212,16 @@ subroutine progclduni & enddo endif +!> - Call subroutine get_alpha_exp to define alpha parameter for EXP and ER cloud overlap options + if ( iovr == 4 .or. iovr == 5 ) then + call get_alpha_exp & +! --- inputs: + & (ix, nlay, dzlay, iovr, latdeg, julian, yearlen, cldtot, & +! --- outputs: + & alpha & + & ) + endif + !> - Call gethml() to compute low,mid,high,total, and boundary layer !! cloud fractions and clouds top/bottom layer indices for low, mid, !! and high clouds. @@ -3038,7 +3233,7 @@ subroutine progclduni & call gethml & ! --- inputs: - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & & IX,NLAY, & ! --- outputs: & clds, mtop, mbot & @@ -3065,6 +3260,7 @@ end subroutine progclduni !> \param cldcnv (IX,NLAY), convective cloud (for diagnostic scheme only) !> \param dz (IX,NLAY), layer thickness (km) !> \param de_lgth (IX), clouds decorrelation length (km) +!> \param alpha (IX,NLAY), alpha decorrelation parameter !> \param IX horizontal dimension !> \param NLAY vertical layer dimensions !> \param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl @@ -3074,7 +3270,7 @@ end subroutine progclduni !>\section detail Detailed Algorithm !! @{ subroutine gethml & - & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, & ! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, dz, de_lgth, alpha, & ! --- inputs: & IX, NLAY, & & clds, mtop, mbot & ! --- outputs: & ) @@ -3106,6 +3302,7 @@ subroutine gethml & ! cldcnv(IX,NLAY) : convective cloud (for diagnostic scheme only) ! ! dz (ix,nlay) : layer thickness (km) ! ! de_lgth(ix) : clouds vertical de-correlation length (km) ! +! alpha(ix,nlay) : alpha decorrelation parameter ! IX : horizontal dimention ! ! NLAY : vertical layer dimensions ! ! ! @@ -3125,6 +3322,8 @@ subroutine gethml & ! =1 max/ran overlapping clouds ! ! =2 maximum overlapping ( for mcica only ) ! ! =3 decorr-length ovlp ( for mcica only ) ! +! =4: exponential cloud overlap (AER; mcica only) ! +! =5: exponential-random overlap (AER; mcica only) ! ! ! ! ==================== end of description ===================== ! ! @@ -3136,6 +3335,7 @@ subroutine gethml & real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & & cldtot, cldcnv, dz real (kind=kind_phys), dimension(:), intent(in) :: de_lgth + real (kind=kind_phys), dimension(:,:), intent(in) :: alpha ! --- outputs real (kind=kind_phys), dimension(:,:), intent(out) :: clds @@ -3271,6 +3471,33 @@ subroutine gethml & clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud enddo + elseif ( iovr == 4 .or. iovr == 5 ) then ! exponential overlap (iovr=4), or + ! exponential-random (iovr=5); + ! distinction defined by alpha + + do k = kstr, kend, kinc + do i = 1, ix + ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) + if (ccur >= climit) then ! cloudy layer + cl2(i) = alpha(i,k) * min(cl2(i), (1.0 - ccur)) & ! maximum part + & + (1.0 - alpha(i,k)) * (cl2(i) * (1.0 - ccur)) ! random part + else ! clear layer + cl1(i) = cl1(i) * cl2(i) + cl2(i) = 1.0 + endif + enddo + + if (k == llyr) then + do i = 1, ix + clds(i,5) = 1.0 - cl1(i) * cl2(i) ! save bl cloud + enddo + endif + enddo + + do i = 1, ix + clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud + enddo + endif ! end_if_iovr ! --- high, mid, low clouds, where cl1, cl2 are cloud fractions @@ -3487,7 +3714,7 @@ end subroutine get_alpha_dcorr !! This program derives the exponential transition, alpha, from maximum to !! random overlap needed to define the fractional cloud vertical correlation !! for the exponential (EXP, iovrlp=4) or the exponential-random (ER, iovrlp=5) -!! cloud overlap options for RRTMGP. For exponential, the transition from +!! cloud overlap options for RRTMG/RRTMGP. For exponential, the transition from !! maximum to random with distance through model layers occurs without regard !! to the configuration of clear and cloudy layers. For the ER method, each !! block of adjacent cloudy layers is treated with a separate transition from @@ -3514,9 +3741,14 @@ end subroutine get_alpha_dcorr !! !>\section detail Detailed Algorithm !! @{ - subroutine get_alpha_exp(nlon, nlay, dzlay, iovrlp, latdeg, & - & juldat, yearlen, cldf, alpha) -! =================================================================== ! + subroutine get_alpha_exp & +! --- inputs: + & (nlon, nlay, dzlay, iovrlp, latdeg, juldat, yearlen, cldf, & +! --- outputs: + & alpha & + & ) + +! =================================================================== ! ! ! ! abstract: Derives the exponential transition, alpha, from maximum to ! ! random overlap needed to define the fractional cloud vertical ! @@ -3529,7 +3761,7 @@ subroutine get_alpha_exp(nlon, nlay, dzlay, iovrlp, latdeg, & ! random, and blocks of cloudy layers separated by one or more ! ! clear layers are correlated randomly. ! ! ! -! usage: call get_alpha ! +! usage: call get_alpha_exp ! ! ! ! subprograms called: none ! ! ! @@ -3572,31 +3804,38 @@ subroutine get_alpha_exp(nlon, nlay, dzlay, iovrlp, latdeg, & ! ! ! ==================== end of description ===================== ! ! - use physparam, only: idcor use physcons, only: decorr_con + use physparam, only: idcor + implicit none -! Input + +! Input integer, intent(in) :: nlon, nlay integer, intent(in) :: iovrlp integer, intent(in) :: yearlen - real(kind_phys), dimension(:,:), intent(in) :: dzlay - real(kind_phys), dimension(:,:), intent(in) :: cldf - real(kind_phys), dimension(:), intent(in) :: latdeg - real(kind_phys), intent(in) :: juldat + real(kind=kind_phys), dimension(:,:), intent(in) :: dzlay + real(kind=kind_phys), dimension(:,:), intent(in) :: cldf + real(kind=kind_phys), dimension(:), intent(in) :: latdeg + real(kind=kind_phys), intent(in) :: juldat + ! Output - real(kind_phys), dimension(:,:), intent(out):: alpha + real(kind=kind_phys), dimension(:,:), intent(out):: alpha + ! Local integer :: i, k - real(kind_phys) :: decorr_len(nlon) ! Decorrelation length (km) + real(kind=kind_phys) :: decorr_len(nlon) ! Decorrelation length (km) + ! Constants for latitude and day-of-year dependent decorrlation length (Oreopoulos et al, 2012) ! Used when idcor = 1 - real(kind_phys), parameter :: am1 = 1.4315_kind_phys - real(kind_phys), parameter :: am2 = 2.1219_kind_phys - real(kind_phys), parameter :: am4 = -25.584_kind_phys - real(kind_phys), parameter :: amr = 7.0_kind_phys - real(kind_phys) :: am3 - real(kind_phys), parameter :: zero = 0.0d0 - real(kind_phys), parameter :: one = 1.0d0 + real(kind=kind_phys), parameter :: am1 = 1.4315_kind_phys + real(kind=kind_phys), parameter :: am2 = 2.1219_kind_phys + real(kind=kind_phys), parameter :: am4 = -25.584_kind_phys + real(kind=kind_phys), parameter :: amr = 7.0_kind_phys + real(kind=kind_phys) :: am3 + + real(kind=kind_phys), parameter :: zero = 0.0d0 + real(kind=kind_phys), parameter :: one = 1.0d0 + ! !===> ... begin here ! @@ -3607,20 +3846,21 @@ subroutine get_alpha_exp(nlon, nlay, dzlay, iovrlp, latdeg, & if (iovrlp == 4 .or. iovrlp == 5) then if (idcor .eq. 1) then if (juldat .gt. 181._kind_phys) then - am3 = -4._kind_phys * amr * (juldat - 272._kind_phys)/& - & yearlen + am3 = -4._kind_phys * amr * (juldat - 272._kind_phys) + & / yearlen else - am3 = 4._kind_phys * amr * (juldat - 91._kind_phys) / & - & yearlen + am3 = 4._kind_phys * amr * (juldat - 91._kind_phys) + & / yearlen endif ! For latitude in degrees, decorr_len in km - decorr_len(i) = am1 + am2 * exp( -(latdeg(i) - am3)**2 / & - & am4**2) + decorr_len(i) = am1 + am2 * exp( -(latdeg(i) - am3)**2 + & / am4**2) else decorr_len(i) = decorr_con endif endif enddo + ! For atmospheric data defined from surface to toa; define alpha from surface to toa ! Exponential cloud overlap if (iovrlp == 4) then @@ -3645,12 +3885,12 @@ subroutine get_alpha_exp(nlon, nlay, dzlay, iovrlp, latdeg, & enddo enddo endif - - return - end subroutine get_alpha_exp - + return + end subroutine get_alpha_exp +!----------------------------------- +!! @} ! !........................................! end module module_radiation_clouds ! diff --git a/physics/radiation_surface.f b/physics/radiation_surface.f index a2cbf55ac..f0cbdd18a 100644 --- a/physics/radiation_surface.f +++ b/physics/radiation_surface.f @@ -390,7 +390,7 @@ subroutine setalb & & slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, & & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & & sncovr, snoalb, albPpert ! sfc-perts, mgehne - real (kind=kind_phys), dimension(5), intent(in) :: pertalb ! sfc-perts, mgehne + real (kind=kind_phys), intent(in) :: pertalb ! sfc-perts, mgehne ! --- outputs real (kind=kind_phys), dimension(IMAX,NF_ALBD), intent(out) :: & @@ -628,12 +628,12 @@ subroutine setalb & ! sfc-perts, mgehne *** !> - Call ppebet () to perturb all 4 elements of surface albedo sfcalb(:,1:4). - if (pertalb(1)>0.0) then + if (pertalb>0.0) then do i = 1, imax do kk=1, 4 ! compute beta distribution parameters for all 4 albedos m = sfcalb(i,kk) - s = pertalb(1)*m*(1.-m) + s = pertalb*m*(1.-m) alpha = m*m*(1.-m)/(s*s)-m beta = alpha*(1.-m)/m ! compute beta distribution value corresponding diff --git a/physics/radlw_main.f b/physics/radlw_main.f index 7b029f8b0..f470ad109 100644 --- a/physics/radlw_main.f +++ b/physics/radlw_main.f @@ -6,7 +6,7 @@ !!!!! lw-rrtm3 radiation package description !!!!! !!!!! ============================================================== !!!!! ! ! -! this package includes ncep's modifications of the rrtm-lw radiation ! +! this package includes ncep's modifications of the rrtmg-lw radiation ! ! code from aer inc. ! ! ! ! the lw-rrtm3 package includes these parts: ! @@ -39,7 +39,7 @@ ! inputs: ! ! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! ! clouds,icseed,aerosols,sfemis,sfgtmp, ! -! dzlyr,delpin,de_lgth, ! +! dzlyr,delpin,de_lgth,alpha, ! ! npts, nlay, nlp1, lprnt, ! ! outputs: ! ! hlwc,topflx,sfcflx,cldtau, ! @@ -93,17 +93,38 @@ ! ! !==========================================================================! ! ! -! the original aer's program declarations: ! +! the original aer program declarations: ! ! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! | -! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | -! This software may be used, copied, or redistributed as long as it is | -! not sold and this copyright notice is reproduced on each copy made. | -! This model is provided as is without any express or implied warranties. | -! (http://www.rtweb.aer.com/) | -! | -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! Copyright (c) 2002-2020, Atmospheric & Environmental Research, Inc. (AER) ! +! All rights reserved. ! +! ! +! Redistribution and use in source and binary forms, with or without ! +! modification, are permitted provided that the following conditions are met: ! +! * Redistributions of source code must retain the above copyright ! +! notice, this list of conditions and the following disclaimer. ! +! * Redistributions in binary form must reproduce the above copyright ! +! notice, this list of conditions and the following disclaimer in the ! +! documentation and/or other materials provided with the distribution. ! +! * Neither the name of Atmospheric & Environmental Research, Inc., nor ! +! the names of its contributors may be used to endorse or promote products ! +! derived from this software without specific prior written permission. ! +! ! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ! +! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ! +! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ! +! ARE DISCLAIMED. IN NO EVENT SHALL ATMOSPHERIC & ENVIRONMENTAL RESEARCH, INC.,! +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ! +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ! +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ! +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ! +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF ! +! THE POSSIBILITY OF SUCH DAMAGE. ! +! (http://www.rtweb.aer.com/) ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! ************************************************************************ ! ! ! @@ -136,8 +157,14 @@ ! ************************************************************************ ! ! ! ! references: ! -! (rrtm_lw/rrtmg_lw): ! -! clough, s.A., m.w. shephard, e.j. mlawer, j.s. delamere, ! +! (rrtmg_lw/rrtm_lw): ! +! iacono, m.j., j.s. delamere, e.j. mlawer, m.w. shepard, ! +! s.a. clough, and w.d collins, radiative forcing by long-lived ! +! greenhouse gases: calculations with the aer radiative transfer ! +! models, j, geophys. res., 113, d13103, doi:10.1029/2008jd009944, ! +! 2008. ! +! ! +! clough, s.a., m.w. shephard, e.j. mlawer, j.s. delamere, ! ! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: ! ! atmospheric radiative transfer modeling: a summary of the aer ! ! codes, j. quant. spectrosc. radiat. transfer, 91, 233-244, 2005. ! @@ -234,12 +261,21 @@ ! jun 2018, h-m lin/y-t hou -- added new option of cloud overlap ! ! method 'de-correlation-length' for mcica application ! ! ! +! ************************************************************************ ! +! ! +! additional aer revision history: ! +! jul 2020, m.j. iacono -- added new mcica cloud overlap options ! +! exponential and exponential-random. each method can ! +! use either a constant or a latitude-varying and ! +! day-of-year varying decorrelation length selected ! +! with parameter "idcor". ! +! ! !!!!! ============================================================== !!!!! !!!!! end descriptions !!!!! !!!!! ============================================================== !!!!! !> This module contains the CCPP-compliant NCEP's modifications of the -!! rrtm-lw radiation code from aer inc. +!! rrtmg-lw radiation code from aer inc. module rrtmg_lw ! use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & @@ -360,7 +396,7 @@ end subroutine rrtmg_lw_init !! \brief This module includes NCEP's modifications of the RRTMG-LW radiation !! code from AER. !! -!! The RRTM-LW package includes three files: +!! The RRTMG-LW package includes three files: !! - radlw_param.f, which contains: !! - module_radlw_parameters: band parameters set up !! - radlw_datatb.f, which contains modules: @@ -389,7 +425,7 @@ subroutine rrtmg_lw_run & & gasvmr_ch4, gasvmr_o2, gasvmr_co, gasvmr_cfc11, & & gasvmr_cfc12, gasvmr_cfc22, gasvmr_ccl4, & & icseed,aeraod,aerssa,sfemis,sfgtmp, & - & dzlyr,delpin,de_lgth, & + & dzlyr,delpin,de_lgth,alpha, & & npts, nlay, nlp1, lprnt, cld_cf, lslwr, & & hlwc,topflx,sfcflx,cldtau, & ! --- outputs & HLW0,HLWB,FLXPRF, & ! --- optional @@ -444,6 +480,7 @@ subroutine rrtmg_lw_run & ! dzlyr(npts,nlay) : layer thickness (km) ! ! delpin(npts,nlay): layer pressure thickness (mb) ! ! de_lgth(npts) : cloud decorrelation length (km) ! +! alpha(npts,nlay) : EXP/ER cloud overlap decorrelation parameter ! ! npts : total number of horizontal points ! ! nlay, nlp1 : total number of vertical layers, levels ! ! lprnt : cntl flag for diagnostic print out ! @@ -492,6 +529,8 @@ subroutine rrtmg_lw_run & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud (used for isubclw>0 only) ! ! =3: decorrelation-length overlap (for isubclw>0 only) ! +! =4: exponential cloud overlap (AER) ! +! =5: exponential-random cloud overlap (AER) ! ! ivflip - control flag for vertical index direction ! ! =0: vertical index from toa to surface ! ! =1: vertical index from surface to toa ! @@ -589,6 +628,7 @@ subroutine rrtmg_lw_run & real (kind=kind_phys), dimension(npts), intent(in) :: sfemis, & & sfgtmp, de_lgth + real (kind=kind_phys), dimension(npts,nlay), intent(in) :: alpha real (kind=kind_phys), dimension(npts,nlay,nbands),intent(in):: & & aeraod, aerssa @@ -650,6 +690,7 @@ subroutine rrtmg_lw_run & real (kind=kind_phys) :: tem0, tem1, tem2, pwvcm, summol, stemp, & & delgth + real (kind=kind_phys), dimension(nlay) :: alph integer, dimension(npts) :: ipseed integer, dimension(nlay) :: jp, jt, jt1, indself, indfor, indminor @@ -756,6 +797,7 @@ subroutine rrtmg_lw_run & tavel(k)= tlyr(iplon,k1) tz(k) = tlvl(iplon,k1) dz(k) = dzlyr(iplon,k1) + if (iovrlw == 4 .or. iovrlw == 5) alph(k) = alpha(iplon,k) ! alpha decorrelation !> -# Set absorber amount for h2o, co2, and o3. @@ -868,6 +910,7 @@ subroutine rrtmg_lw_run & tavel(k)= tlyr(iplon,k) tz(k) = tlvl(iplon,k+1) dz(k) = dzlyr(iplon,k) + if (iovrlw == 4 .or. iovrlw == 5) alph(k) = alpha(iplon,k) ! alpha decorrelation ! --- ... set absorber amount !test use @@ -1017,7 +1060,7 @@ subroutine rrtmg_lw_run & call cldprop & ! --- inputs: & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & - & nlay, nlp1, ipseed(iplon), dz, delgth, & + & nlay, nlp1, ipseed(iplon), dz, delgth, alph, & ! --- outputs: & cldfmc, taucld & & ) @@ -1344,7 +1387,7 @@ subroutine rlwinit & ! !===> ... begin here ! - if ( iovrlw<0 .or. iovrlw>3 ) then + if ( iovrlw<0 .or. iovrlw>5 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVRLW=',iovrlw,' in RLWINIT !!' stop @@ -1486,13 +1529,14 @@ end subroutine rlwinit !!\param ipseed permutation seed for generating random numbers (isubclw>0) !!\param dz layer thickness (km) !!\param de_lgth layer cloud decorrelation length (km) +!!\param alpha EXP/ER cloud overlap decorrelation parameter !!\param cldfmc cloud fraction for each sub-column !!\param taucld cloud optical depth for bands (non-mcica) !!\section gen_cldprop cldprop General Algorithm !> @{ subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & nlay, nlp1, ipseed, dz, de_lgth, & + & nlay, nlp1, ipseed, dz, de_lgth, alpha, & & cldfmc, taucld & ! --- outputs & ) @@ -1528,6 +1572,7 @@ subroutine cldprop & ! ! ! dz - real, layer thickness (km) nlay ! ! de_lgth- real, layer cloud decorrelation length (km) 1 ! +! alpha - real, EXP/ER decorrelation parameter nlay ! ! nlay - integer, number of vertical layers 1 ! ! nlp1 - integer, number of vertical levels 1 ! ! ipseed- permutation seed for generating random numbers (isubclw>0) ! @@ -1598,6 +1643,7 @@ subroutine cldprop & real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, dz real (kind=kind_phys), intent(in) :: de_lgth + real (kind=kind_phys), dimension(nlay), intent(in) :: alpha ! --- outputs: real (kind=kind_phys), dimension(ngptlw,nlay),intent(out):: cldfmc @@ -1772,7 +1818,7 @@ subroutine cldprop & call mcica_subcol & ! --- inputs: - & ( cldf, nlay, ipseed, dz, de_lgth, & + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & ! --- output: & lcloudy & & ) @@ -1802,11 +1848,12 @@ end subroutine cldprop !!\param ipseed permute seed for random num generator !!\param dz layer thickness !!\param de_lgth layer cloud decorrelation length (km) +!!\param alpha EXP/ER cloud overlap decorrelation parameter !!\param lcloudy sub-colum cloud profile flag array !!\section mcica_subcol_gen mcica_subcol General Algorithm !! @{ subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, & ! --- inputs + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & ! --- inputs & lcloudy & ! --- outputs & ) @@ -1821,6 +1868,7 @@ subroutine mcica_subcol & ! for lw and sw, use values differ by the number of g-pts. ! ! dz - real, layer thickness (km) nlay ! ! de_lgth - real, layer cloud decorrelation length (km) 1 ! +! alpha - real, EXP/ER decorrelation parameter nlay ! ! ! ! output variables: ! ! lcloudy - logical, sub-colum cloud profile flag array ngptlw*nlay! @@ -1838,6 +1886,7 @@ subroutine mcica_subcol & real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz real (kind=kind_phys), intent(in) :: de_lgth + real (kind=kind_phys), dimension(nlay), intent(in) :: alpha ! --- outputs: logical, dimension(ngptlw,nlay), intent(out) :: lcloudy @@ -1997,6 +2046,58 @@ subroutine mcica_subcol & enddo enddo + case( 4:5 ) ! exponential and exponential-random cloud overlap + +! --- Use previously derived decorrelation parameter, alpha, to specify +! the exponenential transition of cloud correlation in the vertical column. +! +! For exponential cloud overlap, the correlation is applied across layers +! without regard to the configuration of clear and cloudy layers. + +! For exponential-random cloud overlap, a new exponential transition is +! performed within each group of adjacent cloudy layers and blocks of +! cloudy layers with clear layers between them are correlated randomly. +! +! NOTE: The code below is identical for case (4) and (5) because the +! distinction in the vertical correlation between EXP and ER is already +! built into the specification of alpha (in subroutine get_alpha_exp). + +! --- setup 2 sets of random numbers + + call random_number ( rand2d, stat ) + + k1 = 0 + do k = 1, nlay + do n = 1, ngptlw + k1 = k1 + 1 + cdfunc(n,k) = rand2d(k1) + enddo + enddo + + call random_number ( rand2d, stat ) + + k1 = 0 + do k = 1, nlay + do n = 1, ngptlw + k1 = k1 + 1 + cdfun2(n,k) = rand2d(k1) + enddo + enddo + +! --- then working upward from the surface: +! if a random number (from an independent set: cdfun2) is smaller than +! alpha, then use the previous layer's number, otherwise use a new random +! number (keep the originally assigned one in cdfunc for that layer). + + do k = 2, nlay + k1 = k - 1 + do n = 1, ngptlw + if ( cdfun2(n,k) < alpha(k) ) then + cdfunc(n,k) = cdfunc(n,k1) + endif + enddo + enddo + end select !> -# Generate subcolumns for homogeneous clouds. diff --git a/physics/radlw_main.meta b/physics/radlw_main.meta index e91fc10df..8e894a377 100644 --- a/physics/radlw_main.meta +++ b/physics/radlw_main.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmg_lw + type = scheme + dependencies = mersenne_twister.f,physcons.F90,physparam.f,radlw_datatb.f,radlw_param.f + +######################################################################## [ccpp-arg-table] name = rrtmg_lw_run type = scheme @@ -207,6 +213,15 @@ kind = kind_phys intent = in optional = F +[alpha] + standard_name = cloud_overlap_decorrelation_parameter + long_name = cloud overlap decorrelation parameter + units = frac + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = in + optional = F [npts] standard_name = horizontal_loop_extent long_name = horizontal dimension diff --git a/physics/radlw_param.meta b/physics/radlw_param.meta index 61aee1d37..05fe5af57 100644 --- a/physics/radlw_param.meta +++ b/physics/radlw_param.meta @@ -1,13 +1,28 @@ +[ccpp-table-properties] + name = topflw_type + type = ddt + dependencies = + [ccpp-arg-table] name = topflw_type type = ddt ######################################################################## +[ccpp-table-properties] + name = sfcflw_type + type = ddt + dependencies = + [ccpp-arg-table] name = sfcflw_type type = ddt ######################################################################## +[ccpp-table-properties] + name = module_radlw_parameters + type = module + dependencies = + [ccpp-arg-table] name = module_radlw_parameters type = module diff --git a/physics/radsw_main.f b/physics/radsw_main.f index b10541fb7..3b975313b 100644 --- a/physics/radsw_main.f +++ b/physics/radsw_main.f @@ -6,7 +6,7 @@ ! sw-rrtm3 radiation package description !!!!! ! ============================================================== !!!!! ! ! -! this package includes ncep's modifications of the rrtm-sw radiation ! +! this package includes ncep's modifications of the rrtmg-sw radiation ! ! code from aer inc. ! ! ! ! the sw-rrtm3 package includes these parts: ! @@ -38,7 +38,7 @@ ! inputs: ! ! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! ! clouds,icseed,aerosols,sfcalb, ! -! dzlyr,delpin,de_lgth, ! +! dzlyr,delpin,de_lgth,alpha, ! ! cosz,solcon,NDAY,idxday, ! ! npts, nlay, nlp1, lprnt, ! ! outputs: ! @@ -104,17 +104,38 @@ ! ! !==========================================================================! ! ! -! the original program declarations: ! +! the original aer program declarations: ! ! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! ! -! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). ! -! This software may be used, copied, or redistributed as long as it is ! -! not sold and this copyright notice is reproduced on each copy made. ! -! This model is provided as is without any express or implied warranties. ! -! (http://www.rtweb.aer.com/) ! -! ! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! Copyright (c) 2002-2020, Atmospheric & Environmental Research, Inc. (AER) ! +! All rights reserved. ! +! ! +! Redistribution and use in source and binary forms, with or without ! +! modification, are permitted provided that the following conditions are met: ! +! * Redistributions of source code must retain the above copyright ! +! notice, this list of conditions and the following disclaimer. ! +! * Redistributions in binary form must reproduce the above copyright ! +! notice, this list of conditions and the following disclaimer in the ! +! documentation and/or other materials provided with the distribution. ! +! * Neither the name of Atmospheric & Environmental Research, Inc., nor ! +! the names of its contributors may be used to endorse or promote products ! +! derived from this software without specific prior written permission. ! +! ! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ! +! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ! +! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ! +! ARE DISCLAIMED. IN NO EVENT SHALL ATMOSPHERIC & ENVIRONMENTAL RESEARCH, INC.,! +! BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ! +! CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ! +! SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ! +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ! +! CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ! +! ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF ! +! THE POSSIBILITY OF SUCH DAMAGE. ! +! (http://www.rtweb.aer.com/) ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! ! ************************************************************************ ! ! ! @@ -144,7 +165,13 @@ ! ************************************************************************ ! ! ! ! references: ! -! (rrtm_sw/rrtmg_sw): ! +! (rrtmg_sw/rrtm_sw): ! +! iacono, m.j., j.s. delamere, e.j. mlawer, m.w. shepard, ! +! s.a. clough, and w.d collins, radiative forcing by long-lived ! +! greenhouse gases: calculations with the aer radiative transfer ! +! models, j, geophys. res., 113, d13103, doi:10.1029/2008jd009944, ! +! 2008. ! +! ! ! clough, s.a., m.w. shephard, e.j. mlawer, j.s. delamere, ! ! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: ! ! atmospheric radiative transfer modeling: a summary of the aer ! @@ -189,7 +216,7 @@ ! ! ! ncep modifications history log: ! ! ! -! sep 2003, yu-tai hou -- received aer's rrtm-sw gcm version ! +! sep 2003, yu-tai hou -- received aer's rrtmg-sw gcm version! ! code (v224) ! ! nov 2003, yu-tai hou -- corrected errors in direct/diffuse ! ! surface alabedo components. ! @@ -260,12 +287,21 @@ ! scheme. (used if iswcliq=2); added new option of ! ! cloud overlap method 'de-correlation-length'. ! ! ! +! ************************************************************************ ! +! ! +! additional aer revision history: ! +! jul 2020, m.j. iacono -- added new mcica cloud overlap options ! +! exponential and exponential-random. each method can ! +! use either a constant or a latitude-varying and ! +! day-of-year varying decorrelation length selected ! +! with parameter "idcor". ! +! ! !!!!! ============================================================== !!!!! !!!!! end descriptions !!!!! !!!!! ============================================================== !!!!! -!> This module contains the CCPP-compliant NCEP's modifications of the rrtm-sw radiation -!! code from aer inc. +!> This module contains the CCPP-compliant NCEP's modifications of the +!! rrtmg-sw radiation code from aer inc. module rrtmg_sw ! use physparam, only : iswrate, iswrgas, iswcliq, iswcice, & @@ -422,7 +458,7 @@ end subroutine rrtmg_sw_init !! | 29 | 820-2600 |H2O |CO2 |CO2 |H2O | !!\tableofcontents !! -!! The RRTM-SW package includes three files: +!! The RRTMG-SW package includes three files: !! - radsw_param.f, which contains: !! - module_radsw_parameters: specifies major parameters of the spectral !! bands and defines the construct structures of derived-type variables @@ -467,7 +503,7 @@ subroutine rrtmg_sw_run & & icseed, aeraod, aerssa, aerasy, & & sfcalb_nir_dir, sfcalb_nir_dif, & & sfcalb_uvis_dir, sfcalb_uvis_dif, & - & dzlyr,delpin,de_lgth, & + & dzlyr,delpin,de_lgth,alpha, & & cosz,solcon,NDAY,idxday, & & npts, nlay, nlp1, lprnt, & & cld_cf, lsswr, & @@ -528,6 +564,7 @@ subroutine rrtmg_sw_run & ! dzlyr(npts,nlay) : layer thickness in km ! ! delpin(npts,nlay): layer pressure thickness (mb) ! ! de_lgth(npts) : clouds decorrelation length (km) ! +! alpha(npts,nlay) : EXP/ER cloud overlap decorrelation parameter ! ! cosz (npts) : cosine of solar zenith angle ! ! solcon : solar constant (w/m**2) ! ! NDAY : num of daytime points ! @@ -595,6 +632,8 @@ subroutine rrtmg_sw_run & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud ! ! =3: decorrelation-length overlap clouds ! +! =4: exponential cloud overlap (AER) ! +! =5: exponential-random cloud overlap (AER) ! ! ivflip - control flg for direction of vertical index ! ! =0: index from toa to surface ! ! =1: index from surface to toa ! @@ -691,6 +730,7 @@ subroutine rrtmg_sw_run & real (kind=kind_phys), intent(in) :: cosz(npts), solcon, & & de_lgth(npts) + real (kind=kind_phys), dimension(npts,nlay), intent(in) :: alpha ! --- outputs: real (kind=kind_phys), dimension(npts,nlay), intent(inout) :: hswc @@ -740,6 +780,7 @@ subroutine rrtmg_sw_run & real (kind=kind_phys) :: cosz1, sntz1, tem0, tem1, tem2, s0fac, & & ssolar, zcf0, zcf1, ftoau0, ftoauc, ftoadc, & & fsfcu0, fsfcuc, fsfcd0, fsfcdc, suvbfc, suvbf0, delgth + real (kind=kind_phys), dimension(nlay) :: alph ! --- column amount of absorbing gases: ! (:,m) m = 1-h2o, 2-co2, 3-o3, 4-n2o, 5-ch4, 6-o2, 7-co @@ -869,6 +910,8 @@ subroutine rrtmg_sw_run & tavel(k) = tlyr(j1,kk) delp (k) = delpin(j1,kk) dz (k) = dzlyr (j1,kk) + if (iovrsw == 4 .or. iovrsw == 5) alph(k) = alpha(j1,k) ! alpha decorrelation + !> -# Set absorber and gas column amount, convert from volume mixing !! ratio to molec/cm2 based on coldry (scaled to 1.0e-20) !! - colamt(nlay,maxgas):column amounts of absorbing gases 1 to @@ -958,6 +1001,7 @@ subroutine rrtmg_sw_run & tavel(k) = tlyr(j1,k) delp (k) = delpin(j1,k) dz (k) = dzlyr (j1,k) + if (iovrsw == 4 .or. iovrsw == 5) alph(k) = alpha(j1,k) ! alpha decorrelation ! --- ... set absorber amount !test use @@ -1080,7 +1124,7 @@ subroutine rrtmg_sw_run & call cldprop & ! --- inputs: & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & - & zcf1, nlay, ipseed(j1), dz, delgth, & + & zcf1, nlay, ipseed(j1), dz, delgth, alph, & ! --- outputs: & taucw, ssacw, asycw, cldfrc, cldfmc & & ) @@ -1409,7 +1453,7 @@ subroutine rswinit & ! !===> ... begin here ! - if ( iovrsw<0 .or. iovrsw>3 ) then + if ( iovrsw<0 .or. iovrsw>5 ) then print *,' *** Error in specification of cloud overlap flag', & & ' IOVRSW=',iovrsw,' in RSWINIT !!' stop @@ -1530,6 +1574,7 @@ end subroutine rswinit !! (isubcsw>0) !!\param dz layer thickness (km) !!\param delgth layer cloud decorrelation length (km) +!!\param alpha EXP/ER cloud overlap decorrelation parameter !!\param taucw cloud optical depth, w/o delta scaled !!\param ssacw weighted cloud single scattering albedo !! (ssa = ssacw / taucw) @@ -1542,7 +1587,7 @@ end subroutine rswinit !----------------------------------- subroutine cldprop & & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs - & cf1, nlay, ipseed, dz, delgth, & + & cf1, nlay, ipseed, dz, delgth, alpha, & & taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output & ) @@ -1581,6 +1626,7 @@ subroutine cldprop & ! ipseed- permutation seed for generating random numbers (isubcsw>0) ! ! dz - real, layer thickness (km) nlay ! ! delgth- real, layer cloud decorrelation length (km) 1 ! +! alpha - real, EXP/ER decorrelation parameter nlay ! ! ! ! outputs: ! ! taucw - real, cloud optical depth, w/o delta scaled nlay*nbdsw ! @@ -1633,6 +1679,7 @@ subroutine cldprop & real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, cfrac, dz + real (kind=kind_phys), dimension(nlay), intent(in) :: alpha ! --- outputs: real (kind=kind_phys), dimension(nlay,ngptsw), intent(out) :: & @@ -1885,7 +1932,7 @@ subroutine cldprop & call mcica_subcol & ! --- inputs: - & ( cldf, nlay, ipseed, dz, delgth, & + & ( cldf, nlay, ipseed, dz, delgth, alpha, & ! --- outputs: & lcloudy & & ) @@ -1920,12 +1967,13 @@ end subroutine cldprop !!\param ipseed permute seed for random num generator !!\param dz layer thickness (km) !!\param de_lgth layer cloud decorrelation length (km) +!!\param alpha EXP/ER cloud overlap decorrelation parameter !!\param lcloudy sub-colum cloud profile flag array !!\section mcica_sw_gen mcica_subcol General Algorithm !> @{ ! ---------------------------------- subroutine mcica_subcol & - & ( cldf, nlay, ipseed, dz, de_lgth, & ! --- inputs + & ( cldf, nlay, ipseed, dz, de_lgth, alpha, & ! --- inputs & lcloudy & ! --- outputs & ) @@ -1940,6 +1988,7 @@ subroutine mcica_subcol & ! for lw and sw, use values differ by the number of g-pts. ! ! dz - real, layer thickness (km) nlay ! ! de_lgth-real, layer cloud decorrelation length (km) 1 ! +! alpha - real, EXP/ER decorrelation parameter nlay ! ! ! ! output variables: ! ! lcloudy - logical, sub-colum cloud profile flag array nlay*ngptsw! @@ -1950,6 +1999,8 @@ subroutine mcica_subcol & ! =1: maximum/random overlapping clouds ! ! =2: maximum overlap cloud ! ! =3: cloud decorrelation-length overlap method ! +! =4: exponential cloud overlap method (AER) ! +! =5: exponential-random cloud overlap method (AER) ! ! ! ! ===================== end of definitions ==================== ! @@ -1960,6 +2011,7 @@ subroutine mcica_subcol & real (kind=kind_phys), dimension(nlay), intent(in) :: cldf, dz real (kind=kind_phys), intent(in) :: de_lgth + real (kind=kind_phys), dimension(nlay), intent(in) :: alpha ! --- outputs: logical, dimension(nlay,ngptsw), intent(out):: lcloudy @@ -2115,6 +2167,58 @@ subroutine mcica_subcol & enddo enddo + case( 4:5 ) ! exponential and exponential-random cloud overlap + +! --- Use previously derived decorrelation parameter, alpha, to specify +! the exponenential transition of cloud correlation in the vertical column. +! +! For exponential cloud overlap, the correlation is applied across layers +! without regard to the configuration of clear and cloudy layers. + +! For exponential-random cloud overlap, a new exponential transition is +! performed within each group of adjacent cloudy layers and blocks of +! cloudy layers with clear layers between them are correlated randomly. +! +! NOTE: The code below is identical for case (4) and (5) because the +! distinction in the vertical correlation between EXP and ER is already +! built into the specification of alpha (in subroutine get_alpha_exp). + +! --- setup 2 sets of random numbers + + call random_number ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptsw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(k,n) = rand2d(k1) + enddo + enddo + + call random_number ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptsw + do k = 1, nlay + k1 = k1 + 1 + cdfun2(k,n) = rand2d(k1) + enddo + enddo + +! --- then working upward from the surface: +! if a random number (from an independent set: cdfun2) is smaller than +! alpha, then use the previous layer's number, otherwise use a new random +! number (keep the originally assigned one in cdfunc for that layer). + + do n = 1, ngptsw + do k = 2, nlay + k1 = k - 1 + if ( cdfun2(k,n) < alpha(k) ) then + cdfunc(k,n) = cdfunc(k1,n) + endif + enddo + enddo + end select !> -# Generate subcolumns for homogeneous clouds. diff --git a/physics/radsw_main.meta b/physics/radsw_main.meta index c8074cf47..a294b9d3c 100644 --- a/physics/radsw_main.meta +++ b/physics/radsw_main.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmg_sw + type = scheme + dependencies = mersenne_twister.f,physcons.F90,physparam.f,radsw_datatb.f,radsw_param.f + +######################################################################## [ccpp-arg-table] name = rrtmg_sw_run type = scheme @@ -234,6 +240,15 @@ kind = kind_phys intent = in optional = F +[alpha] + standard_name = cloud_overlap_decorrelation_parameter + long_name = cloud overlap decorrelation parameter + units = frac + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys + intent = in + optional = F [cosz] standard_name = cosine_of_zenith_angle long_name = cosine of the solar zenit angle diff --git a/physics/radsw_param.meta b/physics/radsw_param.meta index e0eb5ece8..7f7da3bdd 100644 --- a/physics/radsw_param.meta +++ b/physics/radsw_param.meta @@ -1,18 +1,38 @@ +[ccpp-table-properties] + name = topfsw_type + type = ddt + dependencies = + [ccpp-arg-table] name = topfsw_type type = ddt ######################################################################## +[ccpp-table-properties] + name = sfcfsw_type + type = ddt + dependencies = + [ccpp-arg-table] name = sfcfsw_type type = ddt ######################################################################## +[ccpp-table-properties] + name = cmpfsw_type + type = ddt + dependencies = + [ccpp-arg-table] name = cmpfsw_type type = ddt ######################################################################## +[ccpp-table-properties] + name = module_radsw_parameters + type = module + dependencies = + [ccpp-arg-table] name = module_radsw_parameters type = module diff --git a/physics/rascnv.F90 b/physics/rascnv.F90 index cc6838b2c..1c311e4cf 100644 --- a/physics/rascnv.F90 +++ b/physics/rascnv.F90 @@ -10,37 +10,38 @@ module rascnv private logical :: is_initialized = .False. ! + integer, parameter :: kp = kind_phys integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s integer, parameter :: idnmax=999 - real (kind=kind_phys), parameter :: delt_c=1800.0/3600.0 & + real (kind=kind_phys), parameter :: delt_c=1800.0_kp/3600.0_kp & ! Adjustment time scales in hrs for deep and shallow clouds ! &, adjts_d=3.0, adjts_s=0.5 ! &, adjts_d=2.5, adjts_s=0.5 - &, adjts_d=2.0, adjts_s=0.5 + &, adjts_d=2.0_kp, adjts_s=0.5_kp ! logical, parameter :: fix_ncld_hr=.true. ! - real (kind=kind_phys), parameter :: ZERO=0.0, HALF=0.5 & - &, pt25=0.25 & - &, ONE=1.0, TWO=2.0, FOUR=4.& - &, twoo3=two/3.0 & - &, FOUR_P2=4.E2, ONE_M10=1.E-10 & - &, ONE_M6=1.E-6, ONE_M5=1.E-5 & - &, ONE_M2=1.E-2, ONE_M1=1.E-1 & - &, oneolog10=one/log(10.0) & - &, facmb = 0.01 & ! conversion factor from Pa to hPa (or mb) - &, cmb2pa = 100.0 ! Conversion from hPa to Pa -! - real(kind=kind_phys), parameter :: frac=0.5, crtmsf=0.0 & - &, rhfacs=0.70, rhfacl=0.70 & - &, face=5.0, delx=10000.0 & - &, ddfac=face*delx*0.001 & - &, max_neg_bouy=0.15 & -! &, max_neg_bouy=pt25 & - &, testmb=0.1, testmbi=one/testmb & - &, dpd=0.5, rknob=1.0, eknob=1.0 + real (kind=kind_phys), parameter :: ZERO=0.0_kp, HALF=0.5_kp & + &, pt25=0.25_kp, ONE=1.0_kp & + &, TWO=2.0_kp, FOUR=4.0_kp & + &, twoo3=two/3.0_kp & + &, FOUR_P2=4.0e2_kp, ONE_M10=1.0e-10_kp& + &, ONE_M6=1.0e-6_kp, ONE_M5=1.0e-5_kp & + &, ONE_M2=1.0e-2_kp, ONE_M1=1.0e-1_kp & + &, oneolog10=one/log(10.0_kp) & + &, facmb = 0.01_kp & ! conversion factor from Pa to hPa (or mb) + &, cmb2pa = 100.0_kp ! Conversion from hPa to Pa +! + real(kind=kind_phys), parameter :: frac=0.5_kp, crtmsf=0.0_kp & + &, rhfacs=0.75_kp, rhfacl=0.75_kp & + &, face=5.0_kp, delx=10000.0_kp& + &, ddfac=face*delx*0.001_kp & + &, max_neg_bouy=0.15_kp & +! &, max_neg_bouy=pt25_kp & + &, testmb=0.1_kp, testmbi=one/testmb & + &, dpd=0.5_kp, rknob=1.0_kp, eknob=1.0_kp !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! logical, parameter :: do_aw=.true., cumfrc=.true. & @@ -52,17 +53,17 @@ module rascnv ! &, advcld=.true., advups=.false.,advtvd=.false. - real(kind=kind_phys), parameter :: TF=233.16, TCR=273.16 & - &, TCRF=1.0/(TCR-TF), TCL=2.0 + real(kind=kind_phys), parameter :: TF=233.16_kp, TCR=273.16_kp & + &, TCRF=one/(TCR-TF), TCL=2.0_kp ! ! For pressure gradient force in momentum mixing -! real (kind=kind_phys), parameter :: pgftop=0.80, pgfbot=0.30 & +! real (kind=kind_phys), parameter :: pgftop=0.80, pgfbot=0.30 & ! No pressure gradient force in momentum mixing - real (kind=kind_phys), parameter :: pgftop=0.0, pgfbot=0.0 & -! real (kind=kind_phys), parameter :: pgftop=0.55, pgfbot=0.55 & - &, pgfgrad=(pgfbot-pgftop)*0.001 & - &, cfmax=0.1 + real (kind=kind_phys), parameter :: pgftop=0.0_kp, pgfbot=0.0_kp & +! real (kind=kind_phys), parameter :: pgftop=0.55, pgfbot=0.55 & + &, pgfgrad=(pgfbot-pgftop)*0.001_kp& + &, cfmax=0.1_kp ! ! For Tilting Angle Specification ! @@ -120,7 +121,7 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! - real(kind=kind_phys), parameter :: actp=1.7, facm=1.00 + real(kind=kind_phys), parameter :: actp=1.7_kp, facm=1.00_kp ! real(kind=kind_phys) PH(15), A(15) ! @@ -167,7 +168,7 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & ! ! VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 ! - AFC = -(1.01097E-4*DT)*(3600./DT)**0.57777778 + AFC = -(1.01097e-4_kp*DT)*(3600.0_kp/DT)**0.57777778_kp ! grav = con_g ; cp = con_cp ; alhl = con_hvap alhf = con_hfus ; rgas = con_rd @@ -179,15 +180,15 @@ subroutine rascnv_init(me, dt, con_g, con_cp, con_rd, & pi = four*atan(one) ; PIINV = one/PI ONEBG = ONE / GRAV ; GRAVCON = cmb2pa * ONEBG onebcp = one / cp ; GRAVFAC = GRAV / CMB2PA - rkap = rgas * onebcp ; deg2rad = pi/180.d0 + rkap = rgas * onebcp ; deg2rad = pi/180.0_kp ELOCP = ALHL * onebcp ; ELFOCP = (ALHL+ALHF) * onebcp oneoalhl = one/alhl ; CMPOR = CMB2PA / RGAS - picon = half*pi*onebg ; zfac = 0.28888889E-4 * ONEBG + picon = half*pi*onebg ; zfac = 0.28888889e-4_kp * ONEBG testmboalhl = testmb/alhl ! - rvi = one/rv ; facw=CVAP-CLIQ - faci = CVAP-CSOL ; hsub=alhl+alhf - tmix = TTP-20.0 ; DEN=one/(TTP-TMIX) + rvi = one/rv ; facw=CVAP-CLIQ + faci = CVAP-CSOL ; hsub=alhl+alhf + tmix = TTP-20.0_kp ; DEN=one/(TTP-TMIX) ! if (me == 0) write(0,*) ' NO DOWNDRAFT FOR CLOUD TYPES' & @@ -364,7 +365,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & integer, dimension(100) :: ic - real(kind=kind_phys), parameter :: clwmin=1.0e-10 + real(kind=kind_phys), parameter :: clwmin=1.0e-10_kp ! real(kind=kind_phys), allocatable :: ALFINT(:,:), uvi(:,:) & &, trcfac(:,:), rcu(:,:) @@ -391,8 +392,8 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & fscav_(i) = fscav(i) enddo endif - trcmin = -99999.0 - if (ntk-2 > 0) trcmin(ntk-2) = 1.0d-4 + trcmin = -99999.0_kp + if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4_kp !> - Initialize CCPP error handling variables @@ -486,23 +487,23 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & if (flipv) ll = kp1 -l ! Input variables are bottom to top! SGC = prsl(ipt,ll) * tem sgcs(l,ipt) = sgc - IF (SGC <= 0.050) KRMIN = L -! IF (SGC <= 0.700) KRMAX = L -! IF (SGC <= 0.800) KRMAX = L - IF (SGC <= 0.760) KRMAX = L -! IF (SGC <= 0.930) KFMAX = L - IF (SGC <= 0.970) KFMAX = L ! Commented on 20060202 -! IF (SGC <= 0.700) kblmx = L ! Commented on 20101015 - IF (SGC <= 0.600) kblmx = L ! -! IF (SGC <= 0.650) kblmx = L ! Commented on 20060202 - IF (SGC <= 0.980) kblmn = L ! + IF (SGC <= 0.050_kp) KRMIN = L +! IF (SGC <= 0.700_kp) KRMAX = L +! IF (SGC <= 0.800_kp) KRMAX = L + IF (SGC <= 0.760_kp) KRMAX = L +! IF (SGC <= 0.930_kp) KFMAX = L + IF (SGC <= 0.970_kp) KFMAX = L ! Commented on 20060202 +! IF (SGC <= 0.700_kp) kblmx = L ! Commented on 20101015 + IF (SGC <= 0.600_kp) kblmx = L ! +! IF (SGC <= 0.650_kp) kblmx = L ! Commented on 20060202 + IF (SGC <= 0.980_kp) kblmn = L ! ENDDO krmin = max(krmin,2) ! if (fix_ncld_hr) then !!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 - NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1800) + 0.10001 + NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1800) + 0.10001_kp ! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.10001 ! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/900) + 0.50001 ! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/600) + 0.50001 @@ -512,7 +513,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & facdt = delt_c / dt else NCRND = min(nrcmax, (KRMAX-KRMIN+1)) - facdt = one / 3600.0 + facdt = one / 3600.0_kp endif NCRND = min(nrcm,max(NCRND, 1)) ! @@ -536,7 +537,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & IF (NCRND > 0) THEN DO I=1,NCRND II = mod(i-1,nrcm) + 1 - IRND = (RANNUM(ipt,II)-0.0005)*(KCR-KRMIN+1) + IRND = (RANNUM(ipt,II)-0.0005_kp)*(KCR-KRMIN+1) IC(KFX+I) = IRND + KRMIN ENDDO ENDIF @@ -581,7 +582,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & if (ntr > 0) then ! tracers such as O3, dust etc do n=1,ntr uvi(l,n) = ccin(ipt,ll,n+2) - if (abs(uvi(l,n)) < 1.0e-20) uvi(l,n) = zero + if (abs(uvi(l,n)) < 1.0e-20_kp) uvi(l,n) = zero enddo endif enddo @@ -592,7 +593,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & phi_h(LL) = phii(ipt,L) enddo ! - if (ccin(ipt,1,2) <= -999.0) then ! input ice/water are together + if (ccin(ipt,1,2) <= -998.0_kp) then ! input ice/water are together do l=1,k ll = kp1 -l tem = ccin(ipt,ll,1) & @@ -630,7 +631,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & if (ntr > 0) then ! tracers such as O3, dust etc do n=1,ntr uvi(l,n) = ccin(ipt,l,n+2) - if (abs(uvi(l,n)) < 1.0e-20) uvi(l,n) = zero + if (abs(uvi(l,n)) < 1.0e-20_kp) uvi(l,n) = zero enddo endif enddo @@ -640,7 +641,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & phi_h(L) = phii(ipt,L) ENDDO ! - if (ccin(ipt,1,2) <= -999.0) then ! input ice/water are together + if (ccin(ipt,1,2) <= -998.0_kp) then ! input ice/water are together do l=1,k tem = ccin(ipt,l,1) & & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) @@ -687,7 +688,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvd=',dtvd(:,1) - if (abs(dtvd(2,1)) > 1.0e-10) then + if (abs(dtvd(2,1)) > 1.0e-10_kp) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) alfint(l,1) = one - half*(tem1 + tem2)/(one + tem2) ! for h @@ -701,7 +702,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvd2=',dtvd(:,2) - if (abs(dtvd(2,2)) > 1.0e-10) then + if (abs(dtvd(2,2)) > 1.0e-10_kp) then tem1 = dtvd(1,2) / dtvd(2,2) tem2 = abs(tem1) alfint(l,2) = one - half*(tem1 + tem2)/(one + tem2) ! for q @@ -712,7 +713,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvd3=',dtvd(:,3) - if (abs(dtvd(2,3)) > 1.0e-10) then + if (abs(dtvd(2,3)) > 1.0e-10_kp) then tem1 = dtvd(1,3) / dtvd(2,3) tem2 = abs(tem1) alfint(l,3) = one - half*(tem1 + tem2)/(one + tem2) ! for ql @@ -723,7 +724,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvd4=',dtvd(:,4) - if (abs(dtvd(2,4)) > 1.0e-10) then + if (abs(dtvd(2,4)) > 1.0e-10_kp) then tem1 = dtvd(1,4) / dtvd(2,4) tem2 = abs(tem1) alfint(l,4) = one - half*(tem1 + tem2)/(one + tem2) ! for qi @@ -740,7 +741,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! write(0,*)' l=',l,' dtvdn=',dtvd(:,1),' n=',n,' l=',l - if (abs(dtvd(2,1)) > 1.0e-10) then + if (abs(dtvd(2,1)) > 1.0e-10_kp) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) alfint(l,n+4) = one - half*(tem1 + tem2)/(one + tem2) ! for tracers @@ -849,7 +850,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & FLXD(L) = zero enddo ! - TLA = -10.0 + TLA = -10.0_kp ! qiid = qii(ib) ! cloud top level ice before convection qlid = qli(ib) ! cloud top level water before convection @@ -905,7 +906,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) ! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt CNV_DQLDT(ipt,ib) = CNV_DQLDT(ipt,ib) + flx(ib)* & - & max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt + & max(zero,(QLI(ib)+QII(ib)-qiid-qlid))/dt ! & max(0.,(QLI(ib)+QII(ib)))/dt/3. if(flx(ib)<0) write(*,*)"AAA666", flx(ib),QLI(ib),QII(ib) & & ,ipt,ib @@ -929,7 +930,7 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! ENDDO ! End of the NC loop! ! - RAINC(ipt) = rain * 0.001 ! Output rain is in meters + RAINC(ipt) = rain * 0.001_kp ! Output rain is in meters ktop(ipt) = kp1 kbot(ipt) = 0 @@ -943,9 +944,9 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & ! clw(i) = max(clw(i), zero) ! cli(i) = max(cli(i), zero) - if (sgcs(l,ipt) < 0.93 .and. abs(tcu(l)) > one_m10) then -! if (sgcs(l,ipt) < 0.90 .and. tcu(l) .ne. 0.0) then -! if (sgcs(l,ipt) < 0.85 .and. tcu(l) .ne. 0.0) then + if (sgcs(l,ipt) < 0.93_kp .and. abs(tcu(l)) > one_m10) then +! if (sgcs(l,ipt) < 0.90_kp .and. tcu(l) .ne. zero) then +! if (sgcs(l,ipt) < 0.85_kp .and. tcu(l) .ne. zero) then kcnv(ipt) = 1 endif ! New test for convective clouds ! added in 08/21/96 @@ -971,18 +972,18 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & QLCN(ipt,ll) = max(qli(l)-ccin(ipt,ll,2), zero) QICN(ipt,ll) = max(qii(l)-ccin(ipt,ll,1), zero) CNV_FICE(ipt,ll) = QICN(ipt,ll) & - & / max(1.e-10,QLCN(ipt,ll)+QICN(ipt,ll)) + & / max(1.0e-10_kp,QLCN(ipt,ll)+QICN(ipt,ll)) else QLCN(ipt,ll) = qli(l) QICN(ipt,ll) = qii(l) - CNV_FICE(ipt,ll) = qii(l)/max(1.e-10,qii(l)+qli(l)) + CNV_FICE(ipt,ll) = qii(l)/max(1.0e-10_kp,qii(l)+qli(l)) endif - cf_upi(ipt,ll) = max(zero,min(0.02*log(one+ & - & 500*ud_mf(ipt,ll)/dt), cfmax)) + cf_upi(ipt,ll) = max(zero,min(0.02_kp*log(one+ & + & 500.0_kp*ud_mf(ipt,ll)/dt), cfmax)) ! & 500*ud_mf(ipt,ll)/dt), 0.60)) CLCN(ipt,ll) = cf_upi(ipt,ll) !downdraft is below updraft w_upi(ipt,ll) = ud_mf(ipt,ll)*toi(l)*rgas / & - & (dt*max(cf_upi(ipt,ll),1.e-12)*prsl(ipt,ll)) + & (dt*max(cf_upi(ipt,ll),1.0e-12_kp)*prsl(ipt,ll)) endif if (ntr > 0) then @@ -1022,21 +1023,21 @@ subroutine rascnv_run(IM, k, ntr, dt, dtf & QLCN(ipt,l) = max(qli(l)-ccin(ipt,l,2), zero) QICN(ipt,l) = max(qii(l)-ccin(ipt,l,1), zero) CNV_FICE(ipt,l) = QICN(ipt,l) & - & / max(1.e-10,QLCN(ipt,l)+QICN(ipt,l)) + & / max(1.0e-10_kp,QLCN(ipt,l)+QICN(ipt,l)) else QLCN(ipt,l) = qli(l) QICN(ipt,l) = qii(l) - CNV_FICE(ipt,l) = qii(l)/max(1.e-10,qii(l)+qli(l)) + CNV_FICE(ipt,l) = qii(l)/max(1.0e-10_kp,qii(l)+qli(l)) endif !! CNV_PRC3(ipt,l) = PCU(l)/dt ! CNV_PRC3(ipt,l) = zero ! if(PCU(l) < zero) write(*,*)"AAA777",PCU(l),ipt,l - cf_upi(ipt,l) = max(zero,min(0.02*log(one+ & - & 500*ud_mf(ipt,l)/dt), cfmax)) + cf_upi(ipt,l) = max(zero,min(0.02_kp*log(one+ & + & 500.0_kp*ud_mf(ipt,l)/dt), cfmax)) ! & 500*ud_mf(ipt,l)/dt), 0.60)) CLCN(ipt,l) = cf_upi(ipt,l) !downdraft is below updraft w_upi(ipt,l) = ud_mf(ipt,l)*toi(l)*rgas / & - & (dt*max(cf_upi(ipt,l),1.e-12)*prsl(ipt,l)) + & (dt*max(cf_upi(ipt,l),1.0e-12_kp)*prsl(ipt,l)) endif if (ntr > 0) then @@ -1139,33 +1140,33 @@ SUBROUTINE CLOUD( & ! IMPLICIT NONE ! - real (kind=kind_phys), parameter :: RHMAX=1.0 & ! MAX RELATIVE HUMIDITY - &, QUAD_LAM=1.0 & ! MASK FOR QUADRATIC LAMBDA - &, RHRAM=0.05 & ! PBL RELATIVE HUMIDITY RAMP -! &, RHRAM=0.15 !& ! PBL RELATIVE HUMIDITY RAMP - &, HCRITD=4000.0 & ! Critical Moist Static Energy for Deep clouds - &, HCRITS=2000.0 & ! Critical Moist Static Energy for Shallow clouds - &, pcrit_lcl=250.0 & ! Critical pressure difference between boundary layer top - ! layer top and lifting condensation level (hPa) -! &, hpert_fac=1.01 !& ! Perturbation on hbl when ctei=.true. -! &, hpert_fac=1.005 !& ! Perturbation on hbl when ctei=.true. - &, qudfac=quad_lam*half & - &, shalfac=3.0 & -! &, qudfac=quad_lam*pt25, shalfac=3.0 !& ! Yogesh's - &, c0ifac=0.07 & ! following Han et al, 2016 MWR - &, dpnegcr = 150.0 -! &, dpnegcr = 100.0 -! &, dpnegcr = 200.0 -! - real(kind=kind_phys), parameter :: ERRMIN=0.0001 & - &, ERRMI2=0.1*ERRMIN & -! &, rainmin=1.0e-9 !& - &, rainmin=1.0e-8 & - &, oneopt9=1.0/0.09 & - &, oneopt4=1.0/0.04 - real(kind=kind_phys), parameter :: almax=1.0e-2 & - &, almin1=0.0, almin2=0.0 - real(kind=kind_phys), parameter :: bldmax = 300.0, bldmin=25.0 + real (kind=kind_phys), parameter :: RHMAX=1.0_kp & ! MAX RELATIVE HUMIDITY + &, QUAD_LAM=1.0_kp & ! MASK FOR QUADRATIC LAMBDA + &, RHRAM=0.05_kp & ! PBL RELATIVE HUMIDITY RAMP +! &, RHRAM=0.15_kp !& ! PBL RELATIVE HUMIDITY RAMP + &, HCRITD=4000.0_kp & ! Critical Moist Static Energy for Deep clouds + &, HCRITS=2000.0_kp & ! Critical Moist Static Energy for Shallow clouds + &, pcrit_lcl=250.0_kp & ! Critical pressure difference between boundary layer top + ! layer top and lifting condensation level (hPa) +! &, hpert_fac=1.01_kp !& ! Perturbation on hbl when ctei=.true. +! &, hpert_fac=1.005_kp !& ! Perturbation on hbl when ctei=.true. + &, qudfac=quad_lam*half & + &, shalfac=3.0_kp & +! &, qudfac=quad_lam*pt25, shalfac=3.0_kp !& ! Yogesh's + &, c0ifac=0.07_kp & ! following Han et al, 2016 MWR + &, dpnegcr = 150.0_kp +! &, dpnegcr = 100.0_kp +! &, dpnegcr = 200.0_kp +! + real(kind=kind_phys), parameter :: ERRMIN=0.0001_kp & + &, ERRMI2=0.1_kp*ERRMIN & +! &, rainmin=1.0e-9_kp !& + &, rainmin=1.0e-8_kp & + &, oneopt9=one/0.09_kp & + &, oneopt4=one/0.04_kp + real(kind=kind_phys), parameter :: almax=1.0e-2_kp & + &, almin1=0.0_kp, almin2=0.0_kp + real(kind=kind_phys), parameter :: bldmax=300.0_kp, bldmin=25.0_kp ! ! INPUT ARGUMENTS @@ -1264,18 +1265,18 @@ SUBROUTINE CLOUD( & PRL(KP1) = PRS(KP1) ! DO L=KD,K - RNN(L) = zero - ZET(L) = zero - XI(L) = zero -! - TOL(L) = TOI(L) - QOL(L) = QOI(L) - PRL(L) = PRS(L) - CLL(L) = QLI(L) - CIL(L) = QII(L) - BUY(L) = zero - - wvl(l) = zero + RNN(L) = zero + ZET(L) = zero + XI(L) = zero +! + TOL(L) = TOI(L) + QOL(L) = QOI(L) + PRL(L) = PRS(L) + CLL(L) = QLI(L) + CIL(L) = QII(L) + BUY(L) = zero + + wvl(l) = zero ENDDO wvl(kp1) = zero ! @@ -1370,8 +1371,14 @@ SUBROUTINE CLOUD( & ! To determine KBL internally -- If KBL is defined externally ! the following two loop should be skipped ! - hcrit = hcritd - if (sgcs(kd) > 0.65) hcrit = hcrits + if (sgcs(kd) < 0.5_kp) then + hcrit = hcritd + elseif (sgcs(kd) > 0.65_kp) then + hcrit = hcrits + else + hcrit = (hcrits*(sgcs(kd)-0.5_kp) + hcritd*(0.65_kp-sgcs(kd)))& + & * (one/0.15_kp) + endif IF (CALKBL) THEN KTEM = MAX(KD+1, KBLMX) hmin = hol(k) @@ -1454,7 +1461,7 @@ SUBROUTINE CLOUD( & ii = max(kbl,kd1) kbl = max(klcl,kd1) - tem = min(50.0,max(10.0,(prl(kmaxp1)-prl(kd))*0.10)) + tem = min(50.0_kp,max(10.0_kp,(prl(kmaxp1)-prl(kd))*0.10_kp)) if (prl(kmaxp1) - prl(ii) > tem .and. ii > kbl) kbl = ii @@ -1514,7 +1521,7 @@ SUBROUTINE CLOUD( & ! shal_fac = one ! if (prl(kbl)-prl(kd) < 300.0 .and. kmax == k) shal_fac = shalfac - if (prl(kbl)-prl(kd) < 350.0 .and. kmax == k) shal_fac = shalfac + if (prl(kbl)-prl(kd) < 350.0_kp .and. kmax == k) shal_fac = shalfac DO L=Kmax,KD,-1 IF (L >= KBL) THEN ETA(L) = (PRL(Kmaxp1)-PRL(L)) * PRISM @@ -1576,7 +1583,7 @@ SUBROUTINE CLOUD( & endif enddo ! - if (lcon == kd .or. kbl <= kd .or. prl(kbl)-prsm(lcon) > 150.0) & + if (lcon == kd .or. kbl <= kd .or. prl(kbl)-prsm(lcon) > 150.0_kp) & & return ! TX1 = RHFACS - QBL / TX1 ! Average RH @@ -1586,9 +1593,9 @@ SUBROUTINE CLOUD( & IF (.NOT. cnvflg) RETURN ! - RHC = MAX(ZERO, MIN(ONE, EXP(-20.0*TX1) )) + RHC = MAX(ZERO, MIN(ONE, EXP(-20.0_kp*TX1) )) ! - wcbase = 0.1 + wcbase = 0.1_kp if (ntrc > 0) then DO N=1,NTRC RBL(N) = ROI(Kmax,N) * ETA(Kmax) @@ -1601,9 +1608,9 @@ SUBROUTINE CLOUD( & ! ! if (ntk > 0 .and. do_aw) then if (ntk > 0) then - if (rbl(ntk) > 0.0) then - wcbase = min(2.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) -! wcbase = min(1.0, max(wcbase, sqrt(twoo3*rbl(ntk)))) + if (rbl(ntk) > zero) then + wcbase = min(two, max(wcbase, sqrt(twoo3*rbl(ntk)))) +! wcbase = min(one, max(wcbase, sqrt(twoo3*rbl(ntk)))) endif endif @@ -1664,7 +1671,7 @@ SUBROUTINE CLOUD( & QLL(KD ) = ALHF * GAF(KD) * QIL(KD) + ONE ! st1 = qil(kd) - st2 = c0i * st1 * exp(c0ifac*min(tol(kd)-t0c,0.0)) + st2 = c0i * st1 * exp(c0ifac*min(tol(kd)-t0c,zero)) tem = c0 * (one-st1) tem2 = st2*qi0 + tem*qw0 ! @@ -1686,7 +1693,7 @@ SUBROUTINE CLOUD( & AKC(L) = one / AKT(L) ! st1 = half * (qil(l)+qil(lp1)) - st2 = c0i * st1 * exp(c0ifac*min(tol(lp1)-t0c,0.0)) + st2 = c0i * st1 * exp(c0ifac*min(tol(lp1)-t0c,zero)) tem = c0 * (one-st1) tem2 = st2*qi0 + tem*qw0 ! @@ -1745,13 +1752,13 @@ SUBROUTINE CLOUD( & HSU = HSU - ALM * TX3 ! CLP = ZERO - ALM = -100.0 + ALM = -100.0_kp HOS = HOL(KD) QOS = QOL(KD) QIS = CIL(KD) QLS = CLL(KD) - cnvflg = HBL > HSU .and. abs(tx1) > 1.0e-4 + cnvflg = HBL > HSU .and. abs(tx1) > 1.0e-4_kp !*********************************************************************** @@ -1768,7 +1775,7 @@ SUBROUTINE CLOUD( & if (tx2 == zero) then alm = - st2 / tx1 - if (alm > almax) alm = -100.0 + if (alm > almax) alm = -100.0_kp else x00 = tx2 + tx2 epp = tx1 * tx1 - (x00+x00)*st2 @@ -1777,8 +1784,8 @@ SUBROUTINE CLOUD( & tem = sqrt(epp) tem1 = (-tx1-tem)*x00 tem2 = (-tx1+tem)*x00 - if (tem1 > almax) tem1 = -100.0 - if (tem2 > almax) tem2 = -100.0 + if (tem1 > almax) tem1 = -100.0_kp + if (tem2 > almax) tem2 = -100.0_kp alm = max(tem1,tem2) endif @@ -1849,12 +1856,12 @@ SUBROUTINE CLOUD( & ACR = zero TEM = PRL(KD1) - (PRL(KD1)-PRL(KD)) * CLP * HALF tx1 = PRL(KBL) - TEM - tx2 = min(900.0, max(tx1,100.0)) - tem1 = log(tx2*0.01) * oneolog10 + tx2 = min(900.0_kp, max(tx1,100.0_kp)) + tem1 = log(tx2*0.01_kp) * oneolog10 tem2 = one - tem1 if ( kdt == 1 ) then -! rel_fac = (dt * facdt) / (tem1*12.0 + tem2*3.0) - rel_fac = (dt * facdt) / (tem1*6.0 + tem2*adjts_s) +! rel_fac = (dt * facdt) / (tem1*12.0_kp + tem2*3.0) + rel_fac = (dt * facdt) / (tem1*6.0_kp + tem2*adjts_s) else rel_fac = (dt * facdt) / (tem1*adjts_d + tem2*adjts_s) endif @@ -1863,7 +1870,7 @@ SUBROUTINE CLOUD( & rel_fac = max(zero, min(half,rel_fac)) IF (CRTFUN) THEN - iwk = tem*0.02-0.999999999 + iwk = tem*0.02_kp - 0.999999999_kp iwk = MAX(1, MIN(iwk, 16)) ACR = tx1 * (AC(iwk) + tem * AD(iwk)) * CCWF ENDIF @@ -2036,7 +2043,7 @@ SUBROUTINE CLOUD( & ! CALCUP = .FALSE. - TEM = max(0.05, MIN(CD*200.0, MAX_NEG_BOUY)) + TEM = max(0.05_kp, MIN(CD*200.0_kp, MAX_NEG_BOUY)) IF (.not. cnvflg .and. WFN > ACR .and. & & dpneg < dpnegcr .and. AKM <= TEM) CALCUP = .TRUE. @@ -2079,7 +2086,7 @@ SUBROUTINE CLOUD( & ENDIF PL = (PRL(KD1) + PRL(KD))*HALF - IF (TRAIN > 1.0E-4 .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. + IF (TRAIN > 1.0e-4_kp .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. ENDIF ! IF (DDFT) THEN ! Downdraft scheme based on (Cheng and Arakawa, 1997) @@ -2394,7 +2401,7 @@ SUBROUTINE CLOUD( & ! sigf(kd) = max(zero, min(one, tx1 * tx1)) ! endif if (do_aw) then - tx1 = (0.2 / max(alm, 1.0e-5)) + tx1 = (0.2_kp / max(alm, 1.0e-5_kp)) tx2 = one - min(one, pi * tx1 * tx1 / area) tx2 = tx2 * tx2 @@ -2518,10 +2525,11 @@ SUBROUTINE CLOUD( & endif enddo tem = tem + amb * dof * sigf(kbl) - tem = tem * (3600.0/dt) - tem1 = sqrt(max(one, min(100.0,(6.25E10/max(area,one))))) ! 20110530 + tem = tem * (3600.0_kp/dt) + tem1 = sqrt(max(one, min(100.0_kp,(6.25e10_kp/max(area,one))))) ! 20110530 clfrac = max(ZERO, min(half, rknob*clf(tem)*tem1)) + cldfrd = clfrac DO L=KD,KBL ! Testing on 20070926 ! for L=KD,K @@ -2565,7 +2573,7 @@ SUBROUTINE CLOUD( & tem4 = zero if (tx1 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778 ) ) + & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778_kp )) ACTEVAP = MIN(TX1, TEM4*CLFRAC) @@ -2573,7 +2581,7 @@ SUBROUTINE CLOUD( & ! tem4 = zero if (tx2 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778 ) ) + & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778_kp )) TEM4 = min(MIN(TX2, TEM4*CLDFRD), potevap-actevap) if (tx2 < rainmin*dt) tem4 = min(tx2, potevap-actevap) ! @@ -2642,7 +2650,7 @@ SUBROUTINE CLOUD( & ! following Liu et al. [JGR,2001] Eq 1 if (FSCAV_(N) > zero) then - DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001) + DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001_kp) FNOSCAV = exp(- FSCAV_(N) * DELZKM) else FNOSCAV = one @@ -2652,7 +2660,7 @@ SUBROUTINE CLOUD( & & * FNOSCAV DO L=KD1,K if (FSCAV_(N) > zero) then - DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001) + DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001_kp) FNOSCAV = exp(- FSCAV_(N) * DELZKM) endif lm1 = l - 1 @@ -2771,7 +2779,7 @@ SUBROUTINE DDRFT( & &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1 & &, IDW, IDH, IDN(K), idnm, itr ! - parameter (ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) + parameter (ERRMIN=0.0001_kp, ERRMI2=0.1_kp*ERRMIN) ! parameter (ERRMIN=0.00001, ERRMI2=0.1*ERRMIN) ! ! real (kind=kind_phys), parameter :: PIINV=one/PI, pio2=half*pi @@ -2781,8 +2789,9 @@ SUBROUTINE DDRFT( & ! parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=0.5) ! PARAMETER (AA1=1.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) ! PARAMETER (AA1=2.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) - PARAMETER (AA1=1.0, BB1=1.0, CC1=1.0, DD1=1.0, F3=CC1, F5=1.0) - parameter (QRMIN=1.0E-6, WC2MIN=0.01, GMF1=GMF/AA1, GMF5=GMF/F5) + PARAMETER (AA1=1.0_kp, BB1=1.0_kp, CC1=1.0_kp, DD1=1.0_kp, & + & F3=CC1, F5=1.0_kp) + parameter (QRMIN=1.0e-6_kp, WC2MIN=0.01_kp, GMF1=GMF/AA1, GMF5=GMF/F5) ! parameter (QRMIN=1.0E-6, WC2MIN=1.00, GMF1=GMF/AA1, GMF5=GMF/F5) parameter (WCMIN=sqrt(wc2min)) ! parameter (sialf=0.5) @@ -2791,11 +2800,12 @@ SUBROUTINE DDRFT( & &, itrmin=15, itrmnd=12, numtla=2 ! uncentering for vvel in dd - real(kind=kind_phys), parameter :: ddunc1=0.25, ddunc2=one-ddunc1 & + real(kind=kind_phys), parameter :: ddunc1=0.25_kp & + &, ddunc2=one-ddunc1 & ! &, ddunc1=0.4, ddunc2=one-ddunc1 & ! &, ddunc1=0.3, ddunc2=one-ddunc1 & - &, VTPEXP=-0.3636 & - &, VTP=36.34*SQRT(1.2)*(0.001)**0.1364 + &, VTPEXP=-0.3636_kp & + &, VTP=36.34_kp*SQRT(1.2_kp)*(0.001_kp)**0.1364_kp ! ! real(kind=kind_phys) EM(K*K), ELM(K) real(kind=kind_phys) ELM(K), AA(KD:K,KD:KP1), QW(KD:K,KD:K) & @@ -2820,7 +2830,7 @@ SUBROUTINE DDRFT( & CLDFRD = zero RNTP = zero DOF = zero - ERRQ = 10.0 + ERRQ = 10.0_kp RNB = zero RNT = zero TX2 = PRL(KBL) @@ -2851,7 +2861,7 @@ SUBROUTINE DDRFT( & ENDDO if (kk /= kbl) then do l=kk,kbl - buy(l) = 0.9 * buy(l-1) + buy(l) = 0.9_kp * buy(l-1) enddo endif ! @@ -2859,24 +2869,24 @@ SUBROUTINE DDRFT( & qrpi(l) = buy(l) enddo do l=kd1,kb1 - buy(l) = 0.25 * (qrpi(l-1)+qrpi(l)+qrpi(l)+qrpi(l+1)) + buy(l) = 0.25_kp * (qrpi(l-1)+qrpi(l)+qrpi(l)+qrpi(l+1)) enddo ! ! CALL ANGRAD(TX1, ALM, STLA, CTL2, AL2, PI, TLA, TX2, WFN, TX3) - tx1 = 1000.0 + tx1 - prl(kp1) + tx1 = 1000.0_kp + tx1 - prl(kp1) ! CALL ANGRAD(TX1, ALM, AL2, TLA, TX2, WFN, TX3) CALL ANGRAD(TX1, ALM, AL2, TLA) ! ! Following Ucla approach for rain profile ! - F2 = (BB1+BB1)*ONEBG/(PI*0.2) + F2 = (BB1+BB1)*ONEBG/(PI*0.2_kp) ! WCMIN = SQRT(WC2MIN) ! WCBASE = WCMIN ! ! del_tla = TLA * 0.2 ! del_tla = TLA * 0.25 - del_tla = TLA * 0.3 + del_tla = TLA * 0.3_kp TLA = TLA - DEL_TLA ! DO L=KD,K @@ -2937,15 +2947,15 @@ SUBROUTINE DDRFT( & do ntla=1,numtla ! numtla is the the maximimu number of tilting angle tries ! ------ ! if (errq < 1.0 .or. tla > 45.0) cycle - if (errq < 0.1 .or. tla > 45.0) cycle + if (errq < 0.1_kp .or. tla > 45.0_kp) cycle ! tla = tla + del_tla STLA = SIN(TLA*deg2rad) ! sine of tilting angle CTL2 = one - STLA * STLA ! cosine square of tilting angle ! - STLA = F2 * STLA * AL2 - CTL2 = DD1 * CTL2 - CTL3 = 0.1364 * CTL2 + STLA = F2 * STLA * AL2 + CTL2 = DD1 * CTL2 + CTL3 = 0.1364_kp * CTL2 ! DO L=KD,K RNF(L) = zero @@ -3008,8 +3018,8 @@ SUBROUTINE DDRFT( & VRW(1) = F3*WVL(KD) - CTL2*VT(1) BUD(KD) = STLA * TX6 * QRB(KD) * half RNF(KD) = BUD(KD) - DOF = 1.1364 * BUD(KD) * QRPI(KD) - DOFW = -BUD(KD) * STLT(KD) + DOF = 1.1364_kp * BUD(KD) * QRPI(KD) + DOFW = -BUD(KD) * STLT(KD) ! RNT = TRW(1) * VRW(1) TX2 = zero @@ -3042,8 +3052,8 @@ SUBROUTINE DDRFT( & ! QA(2) = DOF WA(2) = DOFW - DOF = 1.1364 * BUD(L) * QRPI(L) - DOFW = -BUD(L) * STLT(L) + DOF = 1.1364_kp * BUD(L) * QRPI(L) + DOFW = -BUD(L) * STLT(L) ! RNF(LL) = RNF(LL) + QQQ * ST1 RNF(L) = QQQ * QRT(L) @@ -3113,8 +3123,8 @@ SUBROUTINE DDRFT( & QA(2) = DOF WA(2) = DOFW - DOF = 1.1364 * BUD(L) * QRPI(L) - DOFW = -BUD(L) * STLT(L) + DOF = 1.1364_kp * BUD(L) * QRPI(L) + DOFW = -BUD(L) * STLT(L) ! RNF(LL) = RNF(LL) + ST1 ! @@ -3248,7 +3258,7 @@ SUBROUTINE DDRFT( & ENDDO ! ! tem = 0.5 - if (tx2 > one .and. abs(errq-tx2) > 0.1) then + if (tx2 > one .and. abs(errq-tx2) > 0.1_kp) then tem = half !! elseif (tx2 < 0.1) then !! tem = 1.2 @@ -3271,17 +3281,17 @@ SUBROUTINE DDRFT( & ENDIF ELSE TEM = ERRQ - TX2 -! IF (TEM < ZERO .AND. ERRQ > 0.1) THEN - IF (TEM < ZERO .AND. ERRQ > 0.5) THEN +! IF (TEM < ZERO .AND. ERRQ > 0.1_kp) THEN + IF (TEM < ZERO .AND. ERRQ > 0.5_kp) THEN ! IF (TEM < ZERO .and. & -! & (ntla < numtla .or. ERRQ > 0.5)) THEN +! & (ntla < numtla .or. ERRQ > 0.5_kp)) THEN SKPUP = .TRUE. ! No convergence ! - ERRQ = 10.0 ! No rain profile! + ERRQ = 10.0_kp ! No rain profile! !!!! ELSEIF (ABS(TEM) < ERRMI2 .OR. TX2 < ERRMIN) THEN ELSEIF (TX2 < ERRMIN) THEN SKPUP = .TRUE. ! Converges ! ERRQ = zero ! Rain profile exists! - elseif (tem < zero .and. errq < 0.1) then + elseif (tem < zero .and. errq < 0.1_kp) then skpup = .true. ! if (ntla == numtla .or. tem > -0.003) then errq = zero @@ -3299,7 +3309,7 @@ SUBROUTINE DDRFT( & ! ENDDO ! End of the ITR Loop!! ! - IF (ERRQ < 0.1) THEN + IF (ERRQ < 0.1_kp) THEN DDFT = .TRUE. RNB = - RNB ! do l=kd1,kb1-1 @@ -3320,7 +3330,7 @@ SUBROUTINE DDRFT( & TX1 = TX1 + RNF(L) ENDDO TX1 = TRAIN / (TX1+RNT+RNB) - IF (ABS(TX1-one) < 0.2) THEN + IF (ABS(TX1-one) < 0.2_kp) THEN RNT = MAX(RNT*TX1,ZERO) RNB = RNB * TX1 DO L=KD,KB1 @@ -3330,7 +3340,7 @@ SUBROUTINE DDRFT( & ELSE DDFT = .FALSE. - ERRQ = 10.0 + ERRQ = 10.0_kp ENDIF ENDIF ! @@ -3354,7 +3364,7 @@ SUBROUTINE DDRFT( & WCB(L) = zero ENDDO ! - ERRQ = 10.0 + ERRQ = 10.0_kp ! At this point stlt contains inverse of updraft vertical velocity 1/Wu. KK = MAX(KB1,KD1) @@ -3400,9 +3410,9 @@ SUBROUTINE DDRFT( & IF (RNT > zero) THEN if (TX1 > zero) THEN QRP(KD) = (RPART*RNT / (ROR(KD)*TX1*GMS(KD))) & - & ** (one/1.1364) + & ** (one/1.1364_kp) else - tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364) + tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364_kp) endif RNTP = (one - RPART) * RNT BUY(KD) = - ROR(KD) * TX1 * QRP(KD) @@ -3463,7 +3473,7 @@ SUBROUTINE DDRFT( & VRW(1) = half * (GAM(L-1) + GAM(L)) VRW(2) = one / (VRW(1) + VRW(1)) ! - TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.00*EKNOB) + TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.0_kp*EKNOB) ! DOFW = one / (WA(3) * (one + NU*WA(2))) ! 1.0 / TVbar! ! @@ -3471,7 +3481,7 @@ SUBROUTINE DDRFT( & HOD(L) = HOD(L-1) QOD(L) = QOD(L-1) ! - ERRQ = 10.0 + ERRQ = 10.0_kp ! IF (L <= KBL) THEN @@ -3496,7 +3506,7 @@ SUBROUTINE DDRFT( & IF (L == KD1) THEN IF (RNT > zero) THEN TEM = MAX(QRP(L-1),QRP(L)) - WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0) + WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0_kp) ENDIF WVL(L) = MAX(ONE_M2, WVL(L)) TRW(1) = TRW(1) * half @@ -3624,9 +3634,9 @@ SUBROUTINE DDRFT( & ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) TEM2 = ROR(L) * QRP(L) CALL QRABF(TEM2,QRAF,QRBF) - TEM6 = TX5 * (1.6 + 124.9 * QRAF) * QRBF * TX4 + TEM6 = TX5 * (1.6_kp + 124.9_kp * QRAF) * QRBF * TX4 ! - CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6 * ST2 / ((5.4e5_kp*ST2 + 2.55e6_kp)*(ETD(L)+DDZ)) ! TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) TEM3 = (one + TEM1) * QHS * (QOD(L)+CE) @@ -3637,7 +3647,7 @@ SUBROUTINE DDRFT( & ! second iteration ! ! ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6 * ST2 / ((5.4e5_kp*ST2 + 2.55e6_kp)*(ETD(L)+DDZ)) ! CEE = CE * (ETD(L)+DDZ) ! @@ -3658,7 +3668,7 @@ SUBROUTINE DDRFT( & QRP(L) = MAX(TEM,ZERO) ELSEIF (TX5 > zero) THEN QRP(L) = (MAX(ZERO,QA(1)/(ROR(L)*TX5*GMS(L)))) & - & ** (one/1.1364) + & ** (one/1.1364_kp) ELSE QRP(L) = zero ENDIF @@ -3685,7 +3695,7 @@ SUBROUTINE DDRFT( & ! WVL(L) = 0.5*tem1 ! WVL(L) = 0.1*tem1 ! WVL(L) = 0.0 - WVL(L) = 1.0e-10 + WVL(L) = 1.0e-10_kp else WVL(L) = half*(WVL(L)+TEM1) endif @@ -3699,7 +3709,7 @@ SUBROUTINE DDRFT( & ! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN - IF (ETD(L-1) == zero .AND. ERRQ > 0.2) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.2_kp) THEN ROR(L) = BUD(KD) ETD(L) = zero WVL(L) = zero @@ -3711,7 +3721,7 @@ SUBROUTINE DDRFT( & TX5 = TX9 else TX5 = (STLT(KB1) * QRT(KB1) & - & + STLT(KBL) * QRB(KB1)) * (0.5*FAC) + & + STLT(KBL) * QRB(KB1)) * (0.5_kp*FAC) endif EVP(L-1) = zero @@ -3720,14 +3730,14 @@ SUBROUTINE DDRFT( & ! IF (QA(1) > 0.0) THEN QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (one/1.1364) + & ** (one/1.1364_kp) ! endif BUY(L) = - ROR(L) * TX5 * QRP(L) WCB(L-1) = zero ENDIF ! DEL_ETA = ETD(L) - ETD(L-1) - IF(DEL_ETA < zero .AND. ERRQ > 0.1) THEN + IF(DEL_ETA < zero .AND. ERRQ > 0.1_kp) THEN ROR(L) = BUD(KD) ETD(L) = zero WVL(L) = zero @@ -3754,9 +3764,9 @@ SUBROUTINE DDRFT( & ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) TEM2 = ROR(L) * QRP(L-1) CALL QRABF(TEM2,QRAF,QRBF) - TEM6 = TX5 * (1.6 + 124.9 * QRAF) * QRBF * TX4 + TEM6 = TX5 * (1.6_kp + 124.9_kp * QRAF) * QRBF * TX4 ! - CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6*ST2/((5.4e5_kp*ST2 + 2.55e6_kp)*(ETD(L)+DDZ)) ! TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) @@ -3767,7 +3777,7 @@ SUBROUTINE DDRFT( & ! second iteration ! ! ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) - CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6*ST2/((5.4e5_kp*ST2 + 2.55e6_kp)*(ETD(L)+DDZ)) ! CEE = CE * (ETD(L)+DDZ) ! @@ -3820,7 +3830,7 @@ SUBROUTINE DDRFT( & ! ENDDO ! End of the iteration loop for a given L! IF (L <= K) THEN - IF (ETD(L-1) == zero .AND. ERRQ > 0.1 .and. l <= kbl) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.1_kp .and. l <= kbl) THEN !!! & .AND. ERRQ > ERRMIN*10.0 .and. l <= kbl) THEN ! & .AND. ERRQ > ERRMIN*10.0) THEN ROR(L) = BUD(KD) @@ -3843,7 +3853,7 @@ SUBROUTINE DDRFT( & ! IF (QA(1) > 0.0) THEN QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (one/1.1364) + & ** (one/1.1364_kp) ! ENDIF ETD(L) = zero WVL(L) = zero @@ -3874,7 +3884,7 @@ SUBROUTINE DDRFT( & ! not converge) , no downdraft is assumed ! ! IF (ERRQ > ERRMIN*100.0 .AND. IDN(idnm) == 99) & - IF (ERRQ > 0.1 .AND. IDN(idnm) == idnmax) DDFT = .FALSE. + IF (ERRQ > 0.1_kp .AND. IDN(idnm) == idnmax) DDFT = .FALSE. ! DOF = zero IF (.NOT. DDFT) RETURN @@ -3978,7 +3988,7 @@ SUBROUTINE QSATCN(TT,P,Q,DQDT) real(kind=kind_phys) es, d, hlorv, W ! ! es = 10.0 * fpvs(tt) ! fpvs is in centibars! - es = min(p, 0.01 * fpvs(tt)) ! fpvs is in Pascals! + es = min(p, 0.01_kp * fpvs(tt)) ! fpvs is in Pascals! ! D = one / max(p+epsm1*es,ONE_M10) D = one / (p+epsm1*es) ! @@ -3999,7 +4009,7 @@ SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) ! integer i ! - IF (TLA < 0.0) THEN + IF (TLA < 0.0_kp) THEN IF (PRES <= PLAC(1)) THEN TLA = TLAC(1) ELSEIF (PRES <= PLAC(2)) THEN @@ -4036,8 +4046,8 @@ SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) TEM = REFR(6) ENDIF ! - tem = 2.0E-4 / tem - al2 = min(4.0*tem, max(alm, tem)) + tem = 2.0e-4_kp / tem + al2 = min(4.0_kp*tem, max(alm, tem)) ! RETURN end subroutine angrad @@ -4049,18 +4059,18 @@ SUBROUTINE SETQRP integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! XMIN = 1.0E-6 - XMIN = 0.0 - XMAX = 5.0 + XMIN = 0.0_kp + XMAX = 5.0_kp XINC = (XMAX-XMIN)/(NQRP-1) C2XQRP = one / XINC C1XQRP = one - XMIN*C2XQRP - TEM1 = 0.001 ** 0.2046 - TEM2 = 0.001 ** 0.525 + TEM1 = 0.001_kp ** 0.2046_kp + TEM2 = 0.001_kp ** 0.525_kp DO JX=1,NQRP X = XMIN + (JX-1)*XINC - TBQRP(JX) = X ** 0.1364 - TBQRA(JX) = TEM1 * X ** 0.2046 - TBQRB(JX) = TEM2 * X ** 0.525 + TBQRP(JX) = X ** 0.1364_kp + TBQRA(JX) = TEM1 * X ** 0.2046_kp + TBQRB(JX) = TEM2 * X ** 0.525_kp ENDDO ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN @@ -4085,12 +4095,12 @@ end subroutine qrabf SUBROUTINE SETVTP implicit none - real(kind=kind_phys), parameter :: vtpexp=-0.3636, one=1.0 + real(kind=kind_phys), parameter :: vtpexp=-0.3636_kp, one=1.0_kp real(kind=kind_phys) xinc,x,xmax,xmin integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN = 0.05 - XMAX = 1.5 + XMIN = 0.05_kp + XMAX = 1.5_kp XINC = (XMAX-XMIN)/(NVTP-1) C2XVTP = one / XINC C1XVTP = one - XMIN*C2XVTP @@ -4137,10 +4147,10 @@ real(kind=kind_phys) FUNCTION CLF(PRATE) implicit none real(kind=kind_phys) PRATE ! - real (kind=kind_phys), parameter :: ccf1=0.30, ccf2=0.09 & - &, ccf3=0.04, ccf4=0.01 & - &, pr1=1.0, pr2=5.0 & - &, pr3=20.0 + real (kind=kind_phys), parameter :: ccf1=0.30_kp, ccf2=0.09_kp & + &, ccf3=0.04_kp, ccf4=0.01_kp & + &, pr1=1.0_kp, pr2=5.0_kp & + &, pr3=20.0_kp ! if (prate < pr1) then clf = ccf1 diff --git a/physics/rascnv.meta b/physics/rascnv.meta index f83699347..8a8cc0153 100644 --- a/physics/rascnv.meta +++ b/physics/rascnv.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rascnv + type = scheme + dependencies = + +######################################################################## [ccpp-arg-table] name = rascnv_init type = scheme diff --git a/physics/rayleigh_damp.meta b/physics/rayleigh_damp.meta index 554ac4139..9a40ceff1 100644 --- a/physics/rayleigh_damp.meta +++ b/physics/rayleigh_damp.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = rayleigh_damp_init +[ccpp-table-properties] + name = rayleigh_damp type = scheme + dependencies = ######################################################################## [ccpp-arg-table] @@ -190,7 +191,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = rayleigh_damp_finalize - type = scheme diff --git a/physics/rrtmg_lw_post.F90 b/physics/rrtmg_lw_post.F90 index 971b278dd..af83c5cc7 100644 --- a/physics/rrtmg_lw_post.F90 +++ b/physics/rrtmg_lw_post.F90 @@ -30,9 +30,8 @@ subroutine rrtmg_lw_post_run (Model, Grid, Radtend, Coupling, & type(GFS_grid_type), intent(in) :: Grid type(GFS_radtend_type), intent(inout) :: Radtend integer, intent(in) :: im, ltp, LM, kd - real(kind=kind_phys), dimension(size(Grid%xlon,1), Model%levr+LTP), intent(in) :: htlwc - real(kind=kind_phys), dimension(size(Grid%xlon,1), Model%levr+LTP), intent(in) :: htlw0 - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa + real(kind=kind_phys), dimension(size(Grid%xlon,1), lm+LTP), intent(in) :: htlwc, htlw0 + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg ! local variables @@ -54,7 +53,7 @@ subroutine rrtmg_lw_post_run (Model, Grid, Radtend, Coupling, & enddo ! --- repopulate the points above levr if (lm < Model%levs) then - do k = lm,Model%levs + do k = lm+1,Model%levs Radtend%htrlw (1:im,k) = Radtend%htrlw (1:im,LM) enddo endif @@ -66,7 +65,7 @@ subroutine rrtmg_lw_post_run (Model, Grid, Radtend, Coupling, & enddo ! --- repopulate the points above levr if (lm < Model%levs) then - do k = lm,Model%levs + do k = lm+1,Model%levs Radtend%lwhc(1:im,k) = Radtend%lwhc(1:im,LM) enddo endif diff --git a/physics/rrtmg_lw_post.meta b/physics/rrtmg_lw_post.meta index 8bca0597e..4886e600c 100644 --- a/physics/rrtmg_lw_post.meta +++ b/physics/rrtmg_lw_post.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = rrtmg_lw_post_init +[ccpp-table-properties] + name = rrtmg_lw_post type = scheme + dependencies = machine.F ######################################################################## [ccpp-arg-table] @@ -115,7 +116,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = rrtmg_lw_post_finalize - type = scheme diff --git a/physics/rrtmg_lw_pre.F90 b/physics/rrtmg_lw_pre.F90 index 5f128a79a..7de02eed1 100644 --- a/physics/rrtmg_lw_pre.F90 +++ b/physics/rrtmg_lw_pre.F90 @@ -30,7 +30,7 @@ subroutine rrtmg_lw_pre_run (Model, Grid, Sfcprop, Radtend, im, tsfg, tsfa, errm type(GFS_sfcprop_type), intent(in) :: Sfcprop type(GFS_grid_type), intent(in) :: Grid integer, intent(in) :: im - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -44,7 +44,7 @@ subroutine rrtmg_lw_pre_run (Model, Grid, Sfcprop, Radtend, im, tsfg, tsfa, errm call setemis (Grid%xlon, Grid%xlat, Sfcprop%slmsk, & ! --- inputs Sfcprop%snowd, Sfcprop%sncovr, Sfcprop%zorl, & tsfg, tsfa, Sfcprop%hprime(:,1), IM, & - Radtend%semis) ! --- outputs + Radtend%semis) ! --- outputs endif end subroutine rrtmg_lw_pre_run diff --git a/physics/rrtmg_lw_pre.meta b/physics/rrtmg_lw_pre.meta index 6b4488b26..fb7b9d3b0 100644 --- a/physics/rrtmg_lw_pre.meta +++ b/physics/rrtmg_lw_pre.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = rrtmg_lw_pre_init +[ccpp-table-properties] + name = rrtmg_lw_pre type = scheme + dependencies = iounitdef.f,machine.F,radiation_surface.f ######################################################################## [ccpp-arg-table] @@ -82,7 +83,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = rrtmg_lw_pre_finalize - type = scheme diff --git a/physics/rrtmg_sw_post.F90 b/physics/rrtmg_sw_post.F90 index e11491d48..b0ab31129 100644 --- a/physics/rrtmg_sw_post.F90 +++ b/physics/rrtmg_sw_post.F90 @@ -34,9 +34,9 @@ subroutine rrtmg_sw_post_run (Model, Grid, Diag, Radtend, Coupling, & type(GFS_radtend_type), intent(inout) :: Radtend type(GFS_grid_type), intent(in) :: Grid type(GFS_diag_type), intent(inout) :: Diag - integer, intent(in) :: im, lm, kd, nday, ltp - type(cmpfsw_type), dimension(size(Grid%xlon,1)), intent(inout) :: scmpsw - real(kind=kind_phys), dimension(Size(Grid%xlon,1), Model%levr+LTP), intent(in) :: htswc, htsw0 + integer, intent(in) :: im, lm, kd, nday, ltp + type(cmpfsw_type), dimension(size(Grid%xlon,1)), intent(inout) :: scmpsw + real(kind=kind_phys), dimension(Size(Grid%xlon,1), lm+LTP), intent(in) :: htswc, htsw0 real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: sfcalb1, sfcalb2, sfcalb3, sfcalb4 character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -56,7 +56,7 @@ subroutine rrtmg_sw_post_run (Model, Grid, Diag, Radtend, Coupling, & ! We are assuming that radiative tendencies are from bottom to top ! --- repopulate the points above levr i.e. LM if (lm < Model%levs) then - do k = lm,Model%levs + do k = lm+1,Model%levs Radtend%htrsw (1:im,k) = Radtend%htrsw (1:im,LM) enddo endif @@ -68,7 +68,7 @@ subroutine rrtmg_sw_post_run (Model, Grid, Diag, Radtend, Coupling, & enddo ! --- repopulate the points above levr i.e. LM if (lm < Model%levs) then - do k = lm,Model%levs + do k = lm+1,Model%levs Radtend%swhc(1:im,k) = Radtend%swhc(1:im,LM) enddo endif diff --git a/physics/rrtmg_sw_post.meta b/physics/rrtmg_sw_post.meta index 6ed13e830..da2272a54 100644 --- a/physics/rrtmg_sw_post.meta +++ b/physics/rrtmg_sw_post.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = rrtmg_sw_post_init +[ccpp-table-properties] + name = rrtmg_sw_post type = scheme + dependencies = machine.F,radsw_param.f ######################################################################## [ccpp-arg-table] @@ -166,7 +167,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = rrtmg_sw_post_finalize - type = scheme diff --git a/physics/rrtmg_sw_pre.F90 b/physics/rrtmg_sw_pre.F90 index 8eeb16430..5bdaab56b 100644 --- a/physics/rrtmg_sw_pre.F90 +++ b/physics/rrtmg_sw_pre.F90 @@ -35,7 +35,7 @@ subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & integer, intent(in) :: im integer, intent(out) :: nday integer, dimension(size(Grid%xlon,1)), intent(out) :: idxday - real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg + real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: tsfa, tsfg real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(out) :: sfcalb1, sfcalb2, sfcalb3, sfcalb4 real(kind=kind_phys), dimension(size(Grid%xlon,1)), intent(in) :: alb1d character(len=*), intent(out) :: errmsg @@ -44,6 +44,8 @@ subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & integer :: i real(kind=kind_phys), dimension(size(Grid%xlon,1),NF_ALBD) :: sfcalb + real(kind=kind_phys) :: lndp_alb + ! Initialize CCPP error handling variables errmsg = '' errflg = 0 @@ -63,6 +65,16 @@ subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & endif enddo +! set albedo pert, if requested. + lndp_alb = -999. + if (Model%lndp_type==1) then + do i =1,Model%n_var_lndp + if (Model%lndp_var_list(i) == 'alb') then + lndp_alb = Model%lndp_prt_list(i) + endif + enddo + endif + !> - Call module_radiation_surface::setalb() to setup surface albedo. !! for SW radiation. @@ -72,13 +84,13 @@ subroutine rrtmg_sw_pre_run (Model, Grid, Sfcprop, Radtend, im, & Sfcprop%alnsf, Sfcprop%alvwf, Sfcprop%alnwf, & Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, & Sfcprop%tisfc, IM, & - alb1d, Model%pertalb, & ! mg, sfc-perts + alb1d, lndp_alb, & ! mg, sfc-perts sfcalb) ! --- outputs !> -# Approximate mean surface albedo from vis- and nir- diffuse values. Radtend%sfalb(:) = max(0.01, 0.5 * (sfcalb(:,2) + sfcalb(:,4))) else - nday = 0 + nday = 0 idxday = 0 sfcalb = 0.0 endif diff --git a/physics/rrtmg_sw_pre.meta b/physics/rrtmg_sw_pre.meta index 6a68a8cd6..9088284bb 100644 --- a/physics/rrtmg_sw_pre.meta +++ b/physics/rrtmg_sw_pre.meta @@ -1,6 +1,7 @@ -[ccpp-arg-table] - name = rrtmg_sw_pre_init +[ccpp-table-properties] + name = rrtmg_sw_pre type = scheme + dependencies = iounitdef.f,machine.F,radiation_surface.f ######################################################################## [ccpp-arg-table] @@ -143,7 +144,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = rrtmg_sw_pre_finalize - type = scheme diff --git a/physics/rrtmgp_lw_aerosol_optics.meta b/physics/rrtmgp_lw_aerosol_optics.meta index c71a2a97e..8df363cb6 100644 --- a/physics/rrtmgp_lw_aerosol_optics.meta +++ b/physics/rrtmgp_lw_aerosol_optics.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmgp_lw_aerosol_optics + type = scheme + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_lw_aerosol_optics_run type = scheme diff --git a/physics/rrtmgp_lw_cloud_optics.meta b/physics/rrtmgp_lw_cloud_optics.meta index 41afb6c72..34ce77ad3 100644 --- a/physics/rrtmgp_lw_cloud_optics.meta +++ b/physics/rrtmgp_lw_cloud_optics.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmgp_lw_cloud_optics + type = scheme + dependencies = machine.F,rrtmg_lw_cloud_optics.F90,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_lw_cloud_optics_init type = scheme @@ -328,7 +334,3 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = rrtmgp_lw_cloud_optics_finalize - type = scheme diff --git a/physics/rrtmgp_lw_cloud_sampling.F90 b/physics/rrtmgp_lw_cloud_sampling.F90 index 1d6cc06a1..35ae3c4a8 100644 --- a/physics/rrtmgp_lw_cloud_sampling.F90 +++ b/physics/rrtmgp_lw_cloud_sampling.F90 @@ -3,7 +3,7 @@ module rrtmgp_lw_cloud_sampling use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use physparam, only: isubclw, iovrlw use mo_optical_props, only: ty_optical_props_1scl - use mo_cloud_sampling, only: sampled_mask_max_ran, sampled_mask_exp_dcorr, sampled_mask_exp_ran, draw_samples + use rrtmgp_sampling, only: sampled_mask, draw_samples use mersenne_twister, only: random_setseed, random_number, random_stat use rrtmgp_aux, only: check_error_msg use netcdf @@ -133,41 +133,30 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, enddo ! Cloud-overlap. - select case ( iovrlw ) - case(1) ! Maximum-random overlap - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - sampled_mask_max_ran(rng3D, & - cld_frac, & - cldfracMCICA)) - case(3) ! Exponential decorrelation length overlap + ! Maximum-random + if (iovrlw == 1) then + call sampled_mask(rng3D, cld_frac, cldfracMCICA) + endif + ! Exponential decorrelation length overlap + if (iovrlw == 3) then ! Generate second RNG do iCol=1,ncol call random_setseed(ipseed_lw(icol),rng_stat) call random_number(rng1D,rng_stat) rng3D2(:,:,iCol) = reshape(source = rng1D,shape=[lw_gas_props%get_ngpt(),nLev]) enddo - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - sampled_mask_exp_dcorr(rng3D, & - rng3D2, & - cld_frac, & - cloud_overlap_param(:,1:nLev-1), & - cldfracMCICA)) - case(4) ! Exponential overlap - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - sampled_mask_exp_ran(rng3D, & - cld_frac, & - cloud_overlap_param(:,1:nLev-1), & - cldfracMCICA)) - case(5) ! Exponential-random overlap - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - sampled_mask_exp_ran(rng3D, & - cld_frac, & - cloud_overlap_param(:,1:nLev-1), & - cldfracMCICA)) - end select - + call sampled_mask(rng3D, cld_frac, cldfracMCICA, & + overlap_param = cloud_overlap_param(:,1:nLev-1), & + randoms2 = rng3D2) + endif + ! Exponential or Exponential-random + if (iovrlw == 4 .or. iovrlw == 5) then + call sampled_mask(rng3D, cld_frac, cldfracMCICA, & + overlap_param = cloud_overlap_param(:,1:nLev-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & + call check_error_msg('rrtmgp_lw_cloud_sampling_run_draw_samples',& draw_samples(cldfracMCICA, & lw_optical_props_cloudsByBand, & lw_optical_props_clouds)) @@ -201,13 +190,12 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, !enddo ! Precipitation overlap. - select case ( iovrlw ) - case(1) ! Maximum-random overlap - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - sampled_mask_max_ran(rng3D, & - precip_frac, & - precipfracSAMP)) - case(3) ! Exponential decorrelation length overlap + ! Maximum-random + if (iovrlw == 1) then + call sampled_mask(rng3D, precip_frac, precipfracSAMP) + endif + ! Exponential decorrelation length overlap + if (iovrlw == 3) then ! No need to call RNG second time for now, just use the same seeds for precip as clouds. !! Generate second RNG !do iCol=1,ncol @@ -215,30 +203,21 @@ subroutine rrtmgp_lw_cloud_sampling_run(doLWrad, nCol, nLev, ipsdlw0, icseed_lw, ! call random_number(rng1D,rng_stat) ! rng3D2(:,:,iCol) = reshape(source = rng1D,shape=[lw_gas_props%get_ngpt(),nLev]) !enddo - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - sampled_mask_exp_dcorr(rng3D, & - rng3D2, & - precip_frac, & - precip_overlap_param(:,1:nLev-1), & - precipfracSAMP)) - case(4) ! Exponential overlap - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - sampled_mask_exp_ran(rng3D, & - precip_frac, & - precip_overlap_param(:,1:nLev-1), & - precipfracSAMP)) - case(5) ! Exponential-random overlap - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - sampled_mask_exp_ran(rng3D, & - precip_frac, & - precip_overlap_param(:,1:nLev-1), & - precipfracSAMP)) - end select + call sampled_mask(rng3D, precip_frac, precipfracSAMP, & + overlap_param = precip_overlap_param(:,1:nLev-1), & + randoms2 = rng3D2) + endif + ! Exponential or Exponential-random + if (iovrlw == 4 .or. iovrlw == 5) then + call sampled_mask(rng3D, precip_frac, precipfracSAMP, & + overlap_param = precip_overlap_param(:,1:nLev-1)) + endif + ! Sampling. Map band optical depth to each g-point using McICA - call check_error_msg('rrtmgp_lw_cloud_sampling_run', & - draw_samples(precipfracSAMP, & - lw_optical_props_precipByBand, & + call check_error_msg('rrtmgp_lw_precip_sampling_run_draw_samples',& + draw_samples(precipfracSAMP, & + lw_optical_props_precipByBand, & lw_optical_props_precip)) ! #################################################################################### diff --git a/physics/rrtmgp_lw_cloud_sampling.meta b/physics/rrtmgp_lw_cloud_sampling.meta index 251e1e880..ff161d902 100644 --- a/physics/rrtmgp_lw_cloud_sampling.meta +++ b/physics/rrtmgp_lw_cloud_sampling.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmgp_lw_cloud_sampling + type = scheme + dependencies = machine.F,mersenne_twister.f,physparam.f,rrtmgp_sampling.F90,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_lw_cloud_sampling_init type = scheme diff --git a/physics/rrtmgp_lw_gas_optics.meta b/physics/rrtmgp_lw_gas_optics.meta index 36b8067dd..56cc7cefa 100644 --- a/physics/rrtmgp_lw_gas_optics.meta +++ b/physics/rrtmgp_lw_gas_optics.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = rrtmgp_lw_gas_optics + type = scheme + dependencies = machine.F,rte-rrtmgp/extensions/mo_compute_bc.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90 + dependencies = rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_lw_gas_optics_init type = scheme diff --git a/physics/rrtmgp_lw_pre.meta b/physics/rrtmgp_lw_pre.meta index f49563a49..4dfc48203 100644 --- a/physics/rrtmgp_lw_pre.meta +++ b/physics/rrtmgp_lw_pre.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmgp_lw_pre + type = scheme + dependencies = iounitdef.f,machine.F,physparam.f,radiation_surface.f + +######################################################################## [ccpp-arg-table] name = rrtmgp_lw_pre_run type = scheme diff --git a/physics/rrtmgp_lw_rte.meta b/physics/rrtmgp_lw_rte.meta index f8cdfe891..cf11fcc64 100644 --- a/physics/rrtmgp_lw_rte.meta +++ b/physics/rrtmgp_lw_rte.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = rrtmgp_lw_rte + type = scheme + dependencies = machine.F,rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rrtmgp_aux.F90 + dependencies = rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90,rte-rrtmgp/extensions/mo_fluxes_byband_kernels.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_lw_rte_run type = scheme diff --git a/physics/rrtmgp_sampling.F90 b/physics/rrtmgp_sampling.F90 new file mode 100644 index 000000000..29a9064a2 --- /dev/null +++ b/physics/rrtmgp_sampling.F90 @@ -0,0 +1,204 @@ +! This code is part of RRTM for GCM Applications - Parallel (RRTMGP) +! +! Contacts: Robert Pincus and Eli Mlawer +! email: rrtmgp@aer.com +! +! Copyright 2015-2019, Atmospheric and Environmental Research and +! Regents of the University of Colorado. All right reserved. +! +! Use and duplication is permitted under the terms of the +! BSD 3-clause license, see http://opensource.org/licenses/BSD-3-Clause +! ------------------------------------------------------------------------------------------------- +! +! This module provides a simple implementation of sampling for the +! Monte Carlo Independent Pixel Approximation (McICA, doi:10.1029/2002jd003322) +! Cloud optical properties, defined by band and assumed homogenous within each cell (column/layer), +! are randomly sampled to preserve the mean cloud fraction and one of several possible overlap assumptions +! Users supply random numbers with order ngpt,nlay,ncol +! These are only accessed if cloud_fraction(icol,ilay) > 0 so many values don't need to be filled in +! +! Adapted by Dustin Swales on 8/11/2020 for use in UFS (NOAA-PSL/CU-CIRES) +! +! ------------------------------------------------------------------------------------------------- +module rrtmgp_sampling + use mo_rte_kind, only: wp, wl + use mo_optical_props, only: ty_optical_props_arry, & + ty_optical_props_1scl, & + ty_optical_props_2str, & + ty_optical_props_nstr + implicit none + private + public :: draw_samples, sampled_mask +contains + ! ------------------------------------------------------------------------------------------------- + ! + ! Apply a T/F sampled cloud mask to cloud optical properties defined by band to produce + ! McICA-sampled cloud optical properties + ! + ! ------------------------------------------------------------------------------------------------- + function draw_samples(cloud_mask,clouds,clouds_sampled) result(error_msg) + ! Inputs + logical, dimension(:,:,:), intent(in ) :: cloud_mask ! Dimensions ncol,nlay,ngpt + class(ty_optical_props_arry), intent(in ) :: clouds ! Defined by band + + ! Outputs + class(ty_optical_props_arry), intent(inout) :: clouds_sampled ! Defined by g-point + character(len=128) :: error_msg + + ! Local variables + integer :: ncol,nlay,nbnd,ngpt + integer :: imom + + error_msg = "" + + ! Array extents + ncol = clouds%get_ncol() + nlay = clouds%get_nlay() + nbnd = clouds%get_nband() + ngpt = clouds_sampled%get_ngpt() + + ! Optical depth assignment works for 1scl, 2str (also nstr) + call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%tau,clouds_sampled%tau) + ! + ! For 2-stream + ! + select type(clouds) + type is (ty_optical_props_2str) + select type(clouds_sampled) + type is (ty_optical_props_2str) + call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%ssa,clouds_sampled%ssa) + call apply_cloud_mask(ncol,nlay,nbnd,ngpt,clouds_sampled%get_band_lims_gpoint(),cloud_mask,clouds%g, clouds_sampled%g ) + class default + error_msg = "draw_samples: by-band and sampled cloud properties need to be the same variable type" + end select + end select + end function draw_samples + ! ------------------------------------------------------------------------------------------------- + ! + ! Generate a McICA-sampled cloud mask + ! + ! ------------------------------------------------------------------------------------------------- + subroutine sampled_mask(randoms, cloud_frac, cloud_mask, overlap_param, randoms2) + ! Inputs + real(wp), dimension(:,:,:), intent(in ) :: randoms ! ngpt,nlay,ncol + real(wp), dimension(:,:), intent(in ) :: cloud_frac ! ncol,nlay + + ! Outputs + logical, dimension(:,:,:), intent(out) :: cloud_mask ! ncol,nlay,ngpt + + ! Inputs (optional) + real(wp), dimension(:,:), intent(in ), optional :: overlap_param ! ncol,nlay-1 + real(wp), dimension(:,:,:), intent(in ), optional :: randoms2 ! ngpt,nlay,ncol + + ! Local variables + integer :: ncol, nlay, ngpt, icol, ilay, igpt + integer :: cloud_lay_fst, cloud_lay_lst + real(wp) :: rho + real(wp), dimension(size(randoms,1)) :: local_rands + logical, dimension(size(randoms,2)) :: cloud_mask_layer + logical :: l_use_overlap_param = .false. + logical :: l_use_second_rng = .false. + character(len=128) :: error_msg + + ! Array dimensions + ncol = size(randoms, 3) + nlay = size(randoms, 2) + ngpt = size(randoms, 1) + + ! Using cloud-overlap parameter (alpha)? + if (present(overlap_param)) l_use_overlap_param = .true. + + ! Using a second RNG? + if (present(randoms2)) l_use_second_rng = .true. + + ! Construct the cloud mask for each column + do icol = 1, ncol + cloud_mask_layer(1:nlay) = cloud_frac(icol,1:nlay) > 0._wp + if(.not. any(cloud_mask_layer)) then + cloud_mask(icol,1:nlay,1:ngpt) = .false. + cycle + end if + cloud_lay_fst = findloc(cloud_mask_layer, .true., dim=1) + cloud_lay_lst = findloc(cloud_mask_layer, .true., dim=1, back = .true.) + cloud_mask(icol,1:cloud_lay_fst,1:ngpt) = .false. + + ilay = cloud_lay_fst + local_rands(1:ngpt) = randoms(1:ngpt,cloud_lay_fst,icol) + cloud_mask(icol,ilay,1:ngpt) = local_rands(1:ngpt) > (1._wp - cloud_frac(icol,ilay)) + do ilay = cloud_lay_fst+1, cloud_lay_lst + ! ################################################################################ + ! Max-random overlap + ! new random deviates if the adjacent layer isn't cloudy + ! same random deviates if the adjacent layer is cloudy + ! ################################################################################ + if (.not. l_use_overlap_param) then + if(cloud_mask_layer(ilay)) then + if(.not. cloud_mask_layer(ilay-1)) local_rands(1:ngpt) = randoms(1:ngpt,ilay,icol) + cloud_mask(icol,ilay,1:ngpt) = local_rands(1:ngpt) > (1._wp - cloud_frac(icol,ilay)) + else + cloud_mask(icol,ilay,1:ngpt) = .false. + end if + end if ! END COND: Maximum-random overlap + ! ################################################################################ + ! Exponential-random overlap + ! new random deviates if the adjacent layer isn't cloudy + ! correlated deviates if the adjacent layer is cloudy + ! ################################################################################ + if (l_use_overlap_param) then + if(cloud_mask_layer(ilay)) then + if(cloud_mask_layer(ilay-1)) then + ! Create random deviates correlated between this layer and the previous layer + ! (have to remove mean value before enforcing correlation). + rho = overlap_param(icol,ilay-1) + local_rands(1:ngpt) = rho*(local_rands(1:ngpt) -0.5_wp) + & + sqrt(1._wp-rho*rho)*(randoms(1:ngpt,ilay,icol)-0.5_wp) + 0.5_wp + else + local_rands(1:ngpt) = randoms(1:ngpt,ilay,icol) + end if + cloud_mask(icol,ilay,1:ngpt) = local_rands(1:ngpt) > (1._wp - cloud_frac(icol,ilay)) + endif + endif ! END COND: Exponential/Exponential-random overlap + ! ################################################################################ + ! Exponential-decorrelation overlap + ! new random deviates if the adjacent layer isn't cloudy + ! correlated deviates if the adjacent layer is cloudy and decorrelation-length + ! ################################################################################ + if (l_use_overlap_param .and. l_use_second_rng) then + where(randoms2(1:nGpt,iLay,iCol) .le. overlap_param(iCol,iLay)) + cloud_mask(iCol,iLay,1:nGpt) = randoms(1:ngpt,iLay-1,iCol) > (1._wp - cloud_frac(iCol,iLay)) + elsewhere + cloud_mask(iCol,iLay,1:nGpt) = randoms(1:ngpt,iLay,iCol) > (1._wp - cloud_frac(iCol,iLay)) + end where + endif ! END COND: Exponential decorrelation-length + end do ! END LOOP: Layers + + ! Set cloud-mask in layer below clouds to false + cloud_mask(icol,cloud_lay_lst+1:nlay, 1:ngpt) = .false. + end do ! END LOOP: Columns + + end subroutine sampled_mask + ! ------------------------------------------------------------------------------------------------- + ! + ! Apply a true/false cloud mask to a homogeneous field + ! This could be a kernel + ! + ! ------------------------------------------------------------------------------------------------- + subroutine apply_cloud_mask(ncol,nlay,nbnd,ngpt,band_lims_gpt,cloud_mask,input_field,sampled_field) + integer, intent(in ) :: ncol,nlay,nbnd,ngpt + integer, dimension(2,nbnd), intent(in ) :: band_lims_gpt + logical, dimension(ncol,nlay,ngpt), intent(in ) :: cloud_mask + real(wp), dimension(ncol,nlay,nbnd), intent(in ) :: input_field + real(wp), dimension(ncol,nlay,ngpt), intent(out) :: sampled_field + + integer :: icol,ilay,ibnd,igpt + + do ibnd = 1, nbnd + do igpt = band_lims_gpt(1,ibnd), band_lims_gpt(2,ibnd) + do ilay = 1, nlay + sampled_field(1:ncol,ilay,igpt) = merge(input_field(1:ncol,ilay,ibnd), 0._wp, cloud_mask(1:ncol,ilay,igpt)) + end do + end do + end do + end subroutine apply_cloud_mask + +end module rrtmgp_sampling diff --git a/physics/rrtmgp_sw_aerosol_optics.meta b/physics/rrtmgp_sw_aerosol_optics.meta index bd02434b6..68979ae5b 100644 --- a/physics/rrtmgp_sw_aerosol_optics.meta +++ b/physics/rrtmgp_sw_aerosol_optics.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmgp_sw_aerosol_optics + type = scheme + dependencies = iounitdef.f,machine.F,radiation_aerosols.f,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_sw_aerosol_optics_run type = scheme diff --git a/physics/rrtmgp_sw_cloud_optics.meta b/physics/rrtmgp_sw_cloud_optics.meta index 9edb4130a..08fd7f3fd 100644 --- a/physics/rrtmgp_sw_cloud_optics.meta +++ b/physics/rrtmgp_sw_cloud_optics.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmgp_sw_cloud_optics + type = scheme + dependencies = machine.F,physparam.f,rrtmg_sw_cloud_optics.F90,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_sw_cloud_optics_init type = scheme diff --git a/physics/rrtmgp_sw_cloud_sampling.F90 b/physics/rrtmgp_sw_cloud_sampling.F90 index 0a0511bc2..802cad840 100644 --- a/physics/rrtmgp_sw_cloud_sampling.F90 +++ b/physics/rrtmgp_sw_cloud_sampling.F90 @@ -3,8 +3,7 @@ module rrtmgp_sw_cloud_sampling use mo_gas_optics_rrtmgp, only: ty_gas_optics_rrtmgp use physparam, only: isubcsw, iovrsw use mo_optical_props, only: ty_optical_props_2str - use mo_cloud_sampling, only: sampled_mask_max_ran, sampled_mask_exp_dcorr, & - sampled_mask_exp_ran, draw_samples + use rrtmgp_sampling, only: sampled_mask, draw_samples use mersenne_twister, only: random_setseed, random_number, random_stat use rrtmgp_aux, only: check_error_msg use netcdf @@ -137,40 +136,29 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, ipsdsw0, idxd enddo ! Cloud overlap. - select case ( iovrsw ) - case(1) ! Maximum-random overlap - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sampled_mask_max_ran(rng3D, & - cld_frac(idxday(1:nDay),:), & - cldfracMCICA)) - case(3) ! Decorrelation-length overlap + ! Maximum-random overlap + if (iovrsw == 1) then + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA) + endif + ! Decorrelation-length overlap + if (iovrsw == 3) then do iday=1,nday call random_setseed(ipseed_sw(iday),rng_stat) call random_number(rng1D,rng_stat) rng3D2(:,:,iday) = reshape(source = rng1D,shape=[sw_gas_props%get_ngpt(),nLev]) enddo - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sampled_mask_exp_dcorr(rng3D, & - rng3D2, & - cld_frac(idxday(1:nDay),:), & - cloud_overlap_param(idxday(1:nDay),1:nLev-1), & - cldfracMCICA)) - case(4) ! Exponential overlap - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sampled_mask_exp_ran(rng3D, & - cld_frac(idxday(1:nDay),:), & - cloud_overlap_param(idxday(1:nDay),1:nLev-1), & - cldfracMCICA)) - case(5) ! Exponential-random overlap - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sampled_mask_exp_ran(rng3D, & - cld_frac(idxday(1:nDay),:), & - cloud_overlap_param(idxday(1:nDay),1:nLev-1), & - cldfracMCICA)) - end select + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA, & + overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1),& + randoms2 = rng3D2) + endif + ! Exponential overlap + if (iovrsw == 4 .or. iovrsw == 5) then + call sampled_mask(rng3D, cld_frac(idxday(1:nDay),:), cldfracMCICA, & + overlap_param = cloud_overlap_param(idxday(1:nDay),1:nLev-1)) + endif ! Sampling. Map band optical depth to each g-point using McICA - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & + call check_error_msg('rrtmgp_sw_cloud_sampling_run_draw_samples', & draw_samples(cldfracMCICA, & sw_optical_props_cloudsByBand, & sw_optical_props_clouds)) @@ -204,41 +192,29 @@ subroutine rrtmgp_sw_cloud_sampling_run(doSWrad, nCol, nDay, nLev, ipsdsw0, idxd !enddo ! Precipitation overlap - select case ( iovrsw ) - case(1) ! Maximum-random - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sampled_mask_max_ran(rng3D, & - precip_frac(idxday(1:nDay),:), & - precipfracSAMP)) - case(3) ! Exponential-random + ! Maximum-random + if (iovrsw == 1) then + call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), precipfracSAMP) + endif + ! Exponential decorrelation length overlap + if (iovrsw == 3) then !! Generate second RNG !do iday=1,nday ! call random_setseed(ipseed_sw(iday),rng_stat) ! call random_number(rng1D,rng_stat) ! rng3D2(:,:,iday) = reshape(source = rng1D,shape=[sw_gas_props%get_ngpt(),nLev]) !enddo - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sampled_mask_exp_dcorr(rng3D, & - rng3D2, & - precip_frac(idxday(1:nDay),:), & - precip_overlap_param(idxday(1:nDay),1:nLev-1), & - precipfracSAMP)) - case(4) ! Exponential overlap - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sampled_mask_exp_ran(rng3D, & - precip_frac(idxday(1:nDay),:), & - precip_overlap_param(idxday(1:nDay),1:nLev-1), & - precipfracSAMP)) - case(5) ! Exponential-random overlap - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & - sampled_mask_exp_ran(rng3D, & - precip_frac(idxday(1:nDay),:), & - precip_overlap_param(idxday(1:nDay),1:nLev-1), & - precipfracSAMP)) - end select - + call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:), precipfracSAMP, & + overlap_param = precip_overlap_param(idxday(1:nDay),1:nLev-1),& + randoms2 = rng3D2) + endif + if (iovrsw == 4 .or. iovrsw == 5) then + call sampled_mask(rng3D, precip_frac(idxday(1:nDay),:),precipfracSAMP, & + overlap_param = precip_overlap_param(idxday(1:nDay),1:nLev-1)) + endif + ! Map band optical depth to each g-point using McICA - call check_error_msg('rrtmgp_sw_cloud_sampling_run', & + call check_error_msg('rrtmgp_sw_precip_sampling_run_draw_samples', & draw_samples(precipfracSAMP, & sw_optical_props_precipByBand, & sw_optical_props_precip)) diff --git a/physics/rrtmgp_sw_cloud_sampling.meta b/physics/rrtmgp_sw_cloud_sampling.meta index 7ce6a708d..7890d750e 100644 --- a/physics/rrtmgp_sw_cloud_sampling.meta +++ b/physics/rrtmgp_sw_cloud_sampling.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = rrtmgp_sw_cloud_sampling + type = scheme + dependencies = machine.F,mersenne_twister.f,physparam.f,rrtmgp_sampling.F90,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_sw_cloud_sampling_init type = scheme diff --git a/physics/rrtmgp_sw_gas_optics.meta b/physics/rrtmgp_sw_gas_optics.meta index fc8e72a9a..1d0c96547 100644 --- a/physics/rrtmgp_sw_gas_optics.meta +++ b/physics/rrtmgp_sw_gas_optics.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = rrtmgp_sw_gas_optics + type = scheme + dependencies = iounitdef.f,machine.F,radiation_gases.f,rrtmgp_aux.F90,rte-rrtmgp/extensions/mo_compute_bc.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90 + dependencies = rte-rrtmgp/rte/mo_rte_lw.F90,rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rrtmgp_aux.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_sw_gas_optics_init type = scheme diff --git a/physics/rrtmgp_sw_rte.meta b/physics/rrtmgp_sw_rte.meta index 6f0be98c5..302221ce3 100644 --- a/physics/rrtmgp_sw_rte.meta +++ b/physics/rrtmgp_sw_rte.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = rrtmgp_sw_rte + type = scheme + dependencies = machine.F,radsw_param.f,rte-rrtmgp/rte/mo_rte_sw.F90,rte-rrtmgp/rte/mo_fluxes.F90,rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90,rrtmgp_aux.F90 + dependencies = rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90,rte-rrtmgp/extensions/mo_fluxes_byband.F90,rte-rrtmgp/extensions/mo_fluxes_byband_kernels.F90 + +######################################################################## [ccpp-arg-table] name = rrtmgp_sw_rte_run type = scheme diff --git a/physics/rte-rrtmgp b/physics/rte-rrtmgp index 6ee0b62c1..566bee9cd 160000 --- a/physics/rte-rrtmgp +++ b/physics/rte-rrtmgp @@ -1 +1 @@ -Subproject commit 6ee0b62c1ac6204a89a4e922382b611c16dd5fa7 +Subproject commit 566bee9cd6f9977e82d75d9b4964b20b1ff6163d diff --git a/physics/samfdeepcnv.meta b/physics/samfdeepcnv.meta index 9de8036d9..7085e6577 100644 --- a/physics/samfdeepcnv.meta +++ b/physics/samfdeepcnv.meta @@ -1,11 +1,7 @@ -[ccpp-arg-table] - name = samfdeepcnv_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = samfdeepcnv_finalize +[ccpp-table-properties] + name = samfdeepcnv type = scheme + dependencies = funcphys.f90,machine.F,samfaerosols.F ######################################################################## [ccpp-arg-table] diff --git a/physics/samfshalcnv.meta b/physics/samfshalcnv.meta index 09150adb4..6c7eedb82 100644 --- a/physics/samfshalcnv.meta +++ b/physics/samfshalcnv.meta @@ -1,11 +1,7 @@ -[ccpp-arg-table] - name = samfshalcnv_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = samfshalcnv_finalize +[ccpp-table-properties] + name = samfshalcnv type = scheme + dependencies = funcphys.f90,machine.F,samfaerosols.F ######################################################################## [ccpp-arg-table] diff --git a/physics/sascnvn.meta b/physics/sascnvn.meta index 2e386bc43..3031e8fd7 100644 --- a/physics/sascnvn.meta +++ b/physics/sascnvn.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sascnvn + type = scheme + dependencies = funcphys.f90,machine.F + +######################################################################## [ccpp-arg-table] name = sascnvn_init type = scheme @@ -35,11 +41,6 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = sascnvn_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = sascnvn_run diff --git a/physics/satmedmfvdif.F b/physics/satmedmfvdif.F index f00fb3776..ec6add8a5 100644 --- a/physics/satmedmfvdif.F +++ b/physics/satmedmfvdif.F @@ -62,7 +62,7 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl, & & kinver,xkzm_m,xkzm_h,xkzm_s, & & dt3dt_PBL,du3dt_PBL,dv3dt_PBL,dq3dt_PBL,do3dt_PBL, & - & ldiag3d,qdiag3d,errmsg,errflg) + & gen_tend,ldiag3d,qdiag3d,errmsg,errflg) ! use machine , only : kind_phys use funcphys , only : fpvs @@ -74,7 +74,7 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & integer, intent(in) :: kinver(im) integer, intent(out) :: kpbl(im) ! - logical, intent(in) :: ldiag3d, qdiag3d + logical, intent(in) :: gen_tend, ldiag3d, qdiag3d real(kind=kind_phys), intent(inout), dimension(:,:) :: & & dt3dt_PBL,du3dt_PBL,dv3dt_PBL,dq3dt_PBL,do3dt_PBL ! @@ -1397,14 +1397,24 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & rtg(i,k,1) = rtg(i,k,1)+qtend dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend - if(ldiag3d) then - dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + ttend*delt - if(qdiag3d) then - dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + qtend*delt - endif - endif enddo enddo + if (ldiag3d .and. .not. gen_tend) then + do k = 1,km + do i = 1,im + ttend = (f1(i,k)-t1(i,k))*rdt + dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + ttend*delt + enddo + enddo + if (qdiag3d) then + do k = 1,km + do i = 1,im + qtend = (f2(i,k)-q1(i,k,1))*rdt + dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + qtend*delt + enddo + enddo + endif + endif ! if(ntrac1 >= 2) then do kk = 2, ntrac1 @@ -1503,12 +1513,18 @@ subroutine satmedmfvdif_run(im,km,ntrac,ntcw,ntiw,ntke, & dv(i,k) = dv(i,k)+vtend dusfc(i) = dusfc(i)+conw*del(i,k)*utend dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend - if(ldiag3d) then - du3dt_PBL(i,k) = du3dt_PBL(i,k) + utend*delt - dv3dt_PBL(i,k) = dv3dt_PBL(i,k) + vtend*delt - endif enddo enddo + if (ldiag3d .and. .not. gen_tend) then + do k = 1,km + do i = 1,im + utend = (f1(i,k)-u1(i,k))*rdt + vtend = (f2(i,k)-v1(i,k))*rdt + du3dt_PBL(i,k) = du3dt_PBL(i,k) + utend*delt + dv3dt_PBL(i,k) = dv3dt_PBL(i,k) + vtend*delt + enddo + enddo + endif ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !> -# Save PBL height for diagnostic purpose diff --git a/physics/satmedmfvdif.meta b/physics/satmedmfvdif.meta index c4230b950..2365c1a52 100644 --- a/physics/satmedmfvdif.meta +++ b/physics/satmedmfvdif.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = satmedmfvdif + type = scheme + dependencies = funcphys.f90,machine.F,mfpblt.f,mfscu.f,tridi.f + +######################################################################## [ccpp-arg-table] name = satmedmfvdif_init type = scheme @@ -547,7 +553,7 @@ standard_name = cumulative_change_in_temperature_due_to_PBL long_name = cumulative change in temperature due to PBL units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -556,7 +562,7 @@ standard_name = cumulative_change_in_x_wind_due_to_PBL long_name = cumulative change in x wind due to PBL units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -565,7 +571,7 @@ standard_name = cumulative_change_in_y_wind_due_to_PBL long_name = cumulative change in y wind due to PBL units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -574,7 +580,7 @@ standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL long_name = cumulative change in water vapor specific humidity due to PBL units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -583,11 +589,19 @@ standard_name = cumulative_change_in_ozone_mixing_ratio_due_to_PBL long_name = cumulative change in ozone mixing ratio due to PBL units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout optional = F +[gen_tend] + standard_name = flag_for_generic_planetary_boundary_layer_tendency + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in + optional = F [ldiag3d] standard_name = flag_diagnostics_3D long_name = flag for 3d diagnostic fields diff --git a/physics/satmedmfvdifq.F b/physics/satmedmfvdifq.F index f192788fe..63a67c810 100644 --- a/physics/satmedmfvdifq.F +++ b/physics/satmedmfvdifq.F @@ -65,7 +65,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & & prsi,del,prsl,prslk,phii,phil,delt, & & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl, & & kinver,xkzm_m,xkzm_h,xkzm_s,dspfac,bl_upfr,bl_dnfr, & - & ntoz,du3dt,dv3dt,dt3dt,dq3dt,do3dt,ldiag3d,qdiag3d, & + & ntoz,du3dt,dv3dt,dt3dt,dq3dt,do3dt,gen_tend,ldiag3d,qdiag3d, & & errmsg,errflg) ! use machine , only : kind_phys @@ -78,7 +78,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & integer, intent(in) :: kinver(im) integer, intent(in) :: islimsk(im) integer, intent(out) :: kpbl(im) - logical, intent(in) :: ldiag3d,qdiag3d + logical, intent(in) :: gen_tend,ldiag3d,qdiag3d ! real(kind=kind_phys), intent(in) :: grav,rd,cp,rv,hvap,hfus,fv, & & eps,epsm1 @@ -1421,18 +1421,18 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend enddo enddo - if(ldiag3d) then + if(ldiag3d .and. .not. gen_tend) then do k = 1,km do i = 1,im ttend = (f1(i,k)-t1(i,k))*rdt - dt3dt(i,k) = dt3dt(i,k)+dspfac*ttend*delt + dt3dt(i,k) = dt3dt(i,k)+ttend*delt enddo enddo if(qdiag3d) then do k = 1,km do i = 1,im qtend = (f2(i,k)-q1(i,k,1))*rdt - dq3dt(i,k) = dq3dt(i,k)+dspfac*qtend*delt + dq3dt(i,k) = dq3dt(i,k)+qtend*delt enddo enddo endif @@ -1448,7 +1448,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & enddo enddo enddo - if(ldiag3d .and. qdiag3d .and. ntoz>0) then + if(ldiag3d .and. .not. gen_tend .and. qdiag3d .and. ntoz>0) then kk=ntoz is = (kk-1) * km do k = 1, km @@ -1471,7 +1471,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & tdt(i,k) = tdt(i,k) + dspfac * ttend enddo enddo - if(ldiag3d) then + if(ldiag3d .and. .not. gen_tend) then do k = 1,km1 do i = 1,im ttend = diss(i,k) / cp @@ -1555,7 +1555,7 @@ subroutine satmedmfvdifq_run(im,km,ntrac,ntcw,ntiw,ntke, & dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend enddo enddo - if(ldiag3d) then + if(ldiag3d .and. .not. gen_tend) then do k = 1,km do i = 1,im utend = (f1(i,k)-u1(i,k))*rdt diff --git a/physics/satmedmfvdifq.meta b/physics/satmedmfvdifq.meta index 397d71537..fb83fdffe 100644 --- a/physics/satmedmfvdifq.meta +++ b/physics/satmedmfvdifq.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = satmedmfvdifq + type = scheme + dependencies = funcphys.f90,machine.F,mfpbltq.f,mfscuq.f,tridi.f + +######################################################################## [ccpp-arg-table] name = satmedmfvdifq_init type = scheme @@ -599,7 +605,7 @@ standard_name = cumulative_change_in_x_wind_due_to_PBL long_name = cumulative change in x wind due to PBL units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -608,7 +614,7 @@ standard_name = cumulative_change_in_y_wind_due_to_PBL long_name = cumulative change in y wind due to PBL units = m s-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -617,7 +623,7 @@ standard_name = cumulative_change_in_temperature_due_to_PBL long_name = cumulative change in temperature due to PBL units = K - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -626,7 +632,7 @@ standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL long_name = cumulative change in water vapor specific humidity due to PBL units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout @@ -635,11 +641,19 @@ standard_name = cumulative_change_in_ozone_mixing_ratio_due_to_PBL long_name = cumulative change in ozone mixing ratio due to PBL units = kg kg-1 - dimensions = (horizontal_dimension,vertical_dimension) + dimensions = (horizontal_loop_extent,vertical_dimension) type = real kind = kind_phys intent = inout optional = F +[gen_tend] + standard_name = flag_for_generic_planetary_boundary_layer_tendency + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in + optional = F [ldiag3d] standard_name = flag_diagnostics_3D long_name = flag for 3d diagnostic fields diff --git a/physics/sfc_cice.f b/physics/sfc_cice.f index d0aaee476..f845f6091 100644 --- a/physics/sfc_cice.f +++ b/physics/sfc_cice.f @@ -44,9 +44,9 @@ subroutine sfc_cice_run & & ( im, cplflx, hvap, cp, rvrdm1, rd, & & t1, q1, cm, ch, prsl1, & & wind, flag_cice, flag_iter, dqsfc, dtsfc, & - & dusfc, dvsfc, & + & dusfc, dvsfc, snowd, & ! --- outputs: - & qsurf, cmm, chh, evap, hflx, stress, & + & qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep, & & errmsg, errflg & ) @@ -61,9 +61,9 @@ subroutine sfc_cice_run & ! ( im, cplflx, hvap, cp, rvrdm1, rd, ! ! t1, q1, cm, ch, prsl1, ! ! wind, flag_cice, flag_iter, dqsfc, dtsfc, ! -! dusfc, dvsfc, ! +! dusfc, dvsfc, snowd, ! ! outputs: ! -! qsurf, cmm, chh, evap, hflx, stress) ! +! qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep) ! ! ! ! ==================== defination of variables ==================== ! ! ! @@ -81,6 +81,7 @@ subroutine sfc_cice_run & ! dtsfc - real, sensible heat flux ! dusfc - real, zonal momentum stress ! dvsfc - real, meridional momentum stress +! snowd - real, snow depth from cice ! outputs: ! qsurf - real, specific humidity at sfc ! cmm - real, ? @@ -88,12 +89,17 @@ subroutine sfc_cice_run & ! evap - real, evaperation from latent heat ! hflx - real, sensible heat ! stress - real, surface stress +! weasd - real, water equivalent accumulated snow depth (mm) +! snwdph - real, water equivalent snow depth (mm) +! ep - real, potential evaporation ! ==================== end of description ===================== ! ! ! use machine , only : kind_phys implicit none + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys real (kind=kind_phys), intent(in) :: hvap, cp, rvrdm1, rd ! --- inputs: @@ -103,12 +109,14 @@ subroutine sfc_cice_run & ! real (kind=kind_phys), dimension(im), intent(in) :: u1, v1, & real (kind=kind_phys), dimension(im), intent(in) :: & & t1, q1, cm, ch, prsl1, wind, dqsfc, dtsfc, dusfc, dvsfc + &, snowd logical, intent(in) :: flag_cice(im), flag_iter(im) ! --- outputs: - real (kind=kind_phys), dimension(im), intent(out) :: qsurf, & + real (kind=kind_phys), dimension(im), intent(inout) :: qsurf, & & cmm, chh, evap, hflx, stress + &, weasd, snwdph, ep ! character(len=*), intent(out) :: errmsg integer, intent(out) :: errflg @@ -127,24 +135,32 @@ subroutine sfc_cice_run & ! if (.not. cplflx) return ! - cpinv = 1.0/cp - hvapi = 1.0/hvap + cpinv = one / cp + hvapi = one / hvap elocp = hvap/cp ! do i = 1, im if (flag_cice(i) .and. flag_iter(i)) then rho = prsl1(i) & - & / (rd * t1(i) * (1.0 + rvrdm1*max(q1(i), 1.0e-8))) + & / (rd * t1(i) * (one + rvrdm1*max(q1(i), 1.0e-8_kind_phys))) cmm(i) = wind(i) * cm(i) chh(i) = wind(i) * ch(i) * rho qsurf(i) = q1(i) + dqsfc(i) / (hvap*chh(i)) - tem = 1.0 / rho + tem = one / rho hflx(i) = dtsfc(i) * tem * cpinv evap(i) = dqsfc(i) * tem * hvapi stress(i) = sqrt(dusfc(i)*dusfc(i) + dvsfc(i)*dvsfc(i)) * tem + + snwdph(i) = snowd(i) * 1000.0_kind_phys + weasd(i) = snwdph(i) * 0.33_kind_phys + +! weasd(i) = snowd(i) * 1000.0_kind_phys +! snwdph(i) = weasd(i) * dsi ! snow depth in mm + + ep(i) = evap(i) endif enddo diff --git a/physics/sfc_cice.meta b/physics/sfc_cice.meta index a1c57d4d9..ffb49b530 100644 --- a/physics/sfc_cice.meta +++ b/physics/sfc_cice.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sfc_cice + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = sfc_cice_run type = scheme @@ -159,6 +165,15 @@ kind = kind_phys intent = in optional = F +[snowd] + standard_name = surface_snow_thickness_for_coupling + long_name = sfc snow depth in meters over sea ice for coupling + units = m + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [qsurf] standard_name = surface_specific_humidity_over_ice long_name = surface air saturation specific humidity over ice @@ -213,6 +228,33 @@ kind = kind_phys intent = inout optional = F +[weasd] + standard_name = water_equivalent_accumulated_snow_depth_over_ice + long_name = water equiv of acc snow depth over ice + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[snwdph] + standard_name = surface_snow_thickness_water_equivalent_over_ice + long_name = water equivalent snow depth over ice + units = mm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F +[ep] + standard_name = surface_upward_potential_latent_heat_flux_over_ice + long_name = surface upward potential latent heat flux over ice + units = W m-2 + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = inout + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfc_diag.meta b/physics/sfc_diag.meta index 0e9699faf..6ede745b8 100644 --- a/physics/sfc_diag.meta +++ b/physics/sfc_diag.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sfc_diag + type = scheme + dependencies = funcphys.f90,machine.F + +######################################################################## [ccpp-arg-table] name = sfc_diag_run type = scheme diff --git a/physics/sfc_diag_post.meta b/physics/sfc_diag_post.meta index 6c863a6af..492a97a0f 100644 --- a/physics/sfc_diag_post.meta +++ b/physics/sfc_diag_post.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sfc_diag_post + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = sfc_diag_post_run type = scheme diff --git a/physics/sfc_diff.f b/physics/sfc_diff.f index fd35d5964..b7ef1ea68 100644 --- a/physics/sfc_diff.f +++ b/physics/sfc_diff.f @@ -14,7 +14,7 @@ module sfc_diff private - real (kind=kind_phys), parameter :: ca=.4 ! ca - von karman constant + real (kind=kind_phys), parameter :: ca=0.4_kind_phys ! ca - von karman constant contains @@ -72,6 +72,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & !intent(in) & snwdph_wat,snwdph_lnd,snwdph_ice, & !intent(in) & z0rl_wat, z0rl_lnd, z0rl_ice, & !intent(inout) + & z0rl_wav, & !intent(inout) & ustar_wat, ustar_lnd, ustar_ice, & !intent(inout) & cm_wat, cm_lnd, cm_ice, & !intent(inout) & ch_wat, ch_lnd, ch_ice, & !intent(inout) @@ -85,6 +86,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! implicit none ! + integer, parameter :: kp = kind_phys integer, intent(in) :: im, ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean @@ -104,6 +106,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) & tsurf_wat, tsurf_lnd, tsurf_ice, & & snwdph_wat,snwdph_lnd,snwdph_ice + real(kind=kind_phys), dimension(im), intent(in) :: z0rl_wav real(kind=kind_phys), dimension(im), intent(inout) :: & & z0rl_wat, z0rl_lnd, z0rl_ice, & & ustar_wat, ustar_lnd, ustar_ice, & @@ -128,9 +131,11 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) real(kind=kind_phys) :: tvs, z0, z0max, ztmax ! real(kind=kind_phys), parameter :: - & charnock=.014, z0s_max=.317e-2 &! a limiting value at high winds over sea - &, vis=1.4e-5, rnu=1.51e-5, visi=1.0/vis & - &, log01=log(0.01), log05=log(0.05), log07=log(0.07) + & one=1.0_kp, zero=0.0_kp, half=0.5_kp, qmin=1.0e-8_kp + &, charnock=.014_kp, z0s_max=.317e-2_kp &! a limiting value at high winds over sea + &, zmin=1.0e-6_kp & + &, vis=1.4e-5_kp, rnu=1.51e-5_kp, visi=one/vis & + &, log01=log(0.01_kp), log05=log(0.05_kp), log07=log(0.07_kp) ! parameter (charnock=.014,ca=.4)!c ca is the von karman constant ! parameter (alpha=5.,a0=-3.975,a1=12.32,b1=-7.755,b2=6.041) @@ -161,7 +166,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) do i=1,im if(flag_iter(i)) then - virtfac = 1.0 + rvrdm1 * max(q1(i),1.e-8) + virtfac = one + rvrdm1 * max(q1(i),qmin) thv1 = t1(i) * prslki(i) * virtfac ! compute stability dependent exchange coefficients @@ -169,15 +174,16 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! if (dry(i)) then ! Some land #ifdef GSD_SURFACE_FLUXES_BUGFIX - tvs = 0.5 * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) * virtfac + tvs = half * (tsurf_lnd(i)+tskin_lnd(i))/prsik1(i) + & * virtfac #else - tvs = 0.5 * (tsurf_lnd(i)+tskin_lnd(i)) * virtfac + tvs = half * (tsurf_lnd(i)+tskin_lnd(i)) * virtfac #endif - z0max = max(1.0e-6, min(0.01 * z0rl_lnd(i), z1(i))) + z0max = max(zmin, min(0.01_kp * z0rl_lnd(i), z1(i))) !** xubin's new z0 over land - tem1 = 1.0 - shdmax(i) + tem1 = one - shdmax(i) tem2 = tem1 * tem1 - tem1 = 1.0 - tem2 + tem1 = one - tem2 if( ivegsrc == 1 ) then @@ -187,10 +193,10 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = exp( tem2*log01 + tem1*log05 ) elseif (vegtype(i) == 7) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01_kp elseif (vegtype(i) == 16) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01_kp else z0max = exp( tem2*log01 + tem1*log(z0max) ) endif @@ -203,35 +209,35 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = exp( tem2*log01 + tem1*log05 ) elseif (vegtype(i) == 9) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01_kp elseif (vegtype(i) == 11) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01_kp else z0max = exp( tem2*log01 + tem1*log(z0max) ) endif endif ! mg, sfc-perts: add surface perturbations to z0max over land - if (z0pert(i) /= 0.0 ) then - z0max = z0max * (10.**z0pert(i)) + if (z0pert(i) /= zero ) then + z0max = z0max * (10.0_kp**z0pert(i)) endif - z0max = max(z0max, 1.0e-6) + z0max = max(z0max, zmin) ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil - czilc = 0.8 + czilc = 0.8_kp - tem1 = 1.0 - sigmaf(i) + tem1 = 1.0_kp - sigmaf(i) ztmax = z0max*exp( - tem1*tem1 & * czilc*ca*sqrt(ustar_lnd(i)*(0.01/1.5e-05))) ! mg, sfc-perts: add surface perturbations to ztmax/z0max ratio over land - if (ztpert(i) /= 0.0) then - ztmax = ztmax * (10.**ztpert(i)) + if (ztpert(i) /= zero) then + ztmax = ztmax * (10.0_kp**ztpert(i)) endif - ztmax = max(ztmax, 1.0e-6) + ztmax = max(ztmax, zmin) ! call stability ! --- inputs: @@ -243,12 +249,12 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) endif ! Dry points if (icy(i)) then ! Some ice - tvs = 0.5 * (tsurf_ice(i)+tskin_ice(i)) * virtfac - z0max = max(1.0e-6, min(0.01 * z0rl_ice(i), z1(i))) + tvs = half * (tsurf_ice(i)+tskin_ice(i)) * virtfac + z0max = max(zmin, min(0.01_kp * z0rl_ice(i), z1(i))) !** xubin's new z0 over land and sea ice - tem1 = 1.0 - shdmax(i) + tem1 = one - shdmax(i) tem2 = tem1 * tem1 - tem1 = 1.0 - tem2 + tem1 = one - tem2 if( ivegsrc == 1 ) then @@ -257,13 +263,13 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) z0max = exp( tem2*log01 + tem1*log(z0max) ) endif - z0max = max(z0max, 1.0e-6) + z0max = max(z0max, zmin) ! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height ! dependance of czil - czilc = 0.8 + czilc = 0.8_kp - tem1 = 1.0 - sigmaf(i) + tem1 = 1.0_kp - sigmaf(i) ztmax = z0max*exp( - tem1*tem1 & * czilc*ca*sqrt(ustar_ice(i)*(0.01/1.5e-05))) ztmax = max(ztmax, 1.0e-6) @@ -281,9 +287,9 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! the stuff now put into "stability" if (wet(i)) then ! Some open ocean - tvs = 0.5 * (tsurf_wat(i)+tskin_wat(i)) * virtfac - z0 = 0.01 * z0rl_wat(i) - z0max = max(1.0e-6, min(z0,z1(i))) + tvs = half * (tsurf_wat(i)+tskin_wat(i)) * virtfac + z0 = 0.01_kp * z0rl_wat(i) + z0max = max(zmin, min(z0,z1(i))) ustar_wat(i) = sqrt(grav * z0 / charnock) wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) @@ -291,7 +297,7 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! ztmax = z0max - restar = max(ustar_wat(i)*z0max*visi, 0.000001) + restar = max(ustar_wat(i)*z0max*visi, 0.000001_kp) ! restar = log(restar) ! restar = min(restar,5.) @@ -300,8 +306,8 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! rat = rat / (1. + (bb2 + cc2*restar) * restar)) ! rat taken from zeng, zhao and dickinson 1997 - rat = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57) - ztmax = max(z0max * exp(-rat), 1.0e-6) + rat = min(7.0_kp, 2.67_kp * sqrt(sqrt(restar)) - 2.57_kp) + ztmax = max(z0max * exp(-rat), zmin) ! if (sfc_z0_type == 6) then call znot_t_v6(wind10m, ztmax) ! 10-m wind,m/s, ztmax(m) @@ -335,21 +341,32 @@ subroutine sfc_diff_run (im,rvrdm1,eps,epsm1,grav, & !intent(in) ! z0 = arnu / (ustar(i) * ff ** pp) if (redrag) then - z0rl_wat(i) = 100.0 * max(min(z0, z0s_max), 1.e-7) + z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max), & + & 1.0e-7_kp) else - z0rl_wat(i) = 100.0 * max(min(z0,.1), 1.e-7) + z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.e-7_kp) endif elseif (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m - z0rl_wat(i) = 100.0 * z0 ! cm + call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m + z0rl_wat(i) = 100.0_kp * z0 ! cm elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m - z0rl_wat(i) = 100.0 * z0 ! cm + call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m + z0rl_wat(i) = 100.0_kp * z0 ! cm + else + z0rl_wat(i) = 1.0e-4_kp + endif + + elseif (z0rl_wav(i) <= 1.0e-7_kp) then + z0 = (charnock / grav) * ustar_wat(i) * ustar_wat(i) + + if (redrag) then + z0rl_wat(i) = 100.0_kp * max(min(z0, z0s_max),1.0e-7_kp) else - z0rl_wat(i) = 1.0e-4 + z0rl_wat(i) = 100.0_kp * max(min(z0,0.1_kp), 1.0e-7_kp) endif endif + endif ! end of if(open ocean) ! endif ! end of if(flagiter) loop @@ -368,6 +385,7 @@ subroutine stability & & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) !----- + integer, parameter :: kp = kind_phys ! --- inputs: real(kind=kind_phys), intent(in) :: & & z1, snwdph, thv1, wind, z0max, ztmax, tvs, grav @@ -377,11 +395,12 @@ subroutine stability & & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar ! --- locals: - real(kind=kind_phys), parameter :: alpha=5., a0=-3.975 & - &, a1=12.32, alpha4=4.0*alpha - &, b1=-7.755, b2=6.041, alpha2=alpha+alpha, beta=1.0 - &, a0p=-7.941, a1p=24.75, b1p=-8.705, b2p=7.899 - &, ztmin1=-999.0 + real(kind=kind_phys), parameter :: alpha=5.0_kp, a0=-3.975_kp & + &, a1=12.32_kp, alpha4=4.0_kp*alpha & + &, b1=-7.755_kp, b2=6.041_kp, alpha2=alpha+alpha & + &, beta=1.0_kp & + &, a0p=-7.941_kp, a1p=24.75_kp, b1p=-8.705_kp, b2p=7.899_kp& + &, ztmin1=-999.0_kp, zero=0.0_kp, one=1.0_kp real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, & hl1, hl12, pm, ph, pm10, ph2, @@ -390,51 +409,51 @@ subroutine stability & & hl110, hlt, hltinf, olinf, & tem1, tem2, ztmax1 - z1i = 1.0 / z1 + z1i = one / z1 tem1 = z0max/z1 - if (abs(1.0-tem1) > 1.0e-6) then - ztmax1 = - beta*log(tem1)/(alpha2*(1.-tem1)) + if (abs(one-tem1) > 1.0e-6_kp) then + ztmax1 = - beta*log(tem1)/(alpha2*(one-tem1)) else - ztmax1 = 99.0 + ztmax1 = 99.0_kp endif - if( z0max < 0.05 .and. snwdph < 10.0 ) ztmax1 = 99.0 + if( z0max < 0.05_kp .and. snwdph < 10.0_kp ) ztmax1 = 99.0_kp ! compute stability indices (rb and hlinf) dtv = thv1 - tvs - adtv = max(abs(dtv),0.001) + adtv = max(abs(dtv),0.001_kp) dtv = sign(1.,dtv) * adtv #ifdef GSD_SURFACE_FLUXES_BUGFIX - rb = max(-5000.0, grav * dtv * z1 + rb = max(-5000.0_kp, grav * dtv * z1 & / (thv1 * wind * wind)) #else - rb = max(-5000.0, (grav+grav) * dtv * z1 + rb = max(-5000.0_kp, (grav+grav) * dtv * z1 & / ((thv1 + tvs) * wind * wind)) #endif - tem1 = 1.0 / z0max - tem2 = 1.0 / ztmax + tem1 = one / z0max + tem2 = one / ztmax fm = log((z0max+z1) * tem1) fh = log((ztmax+z1) * tem2) - fm10 = log((z0max+10.) * tem1) - fh2 = log((ztmax+2.) * tem2) + fm10 = log((z0max+10.0_kp) * tem1) + fh2 = log((ztmax+2.0_kp) * tem2) hlinf = rb * fm * fm / fh hlinf = min(max(hlinf,ztmin1),ztmax1) ! ! stable case ! - if (dtv >= 0.0) then + if (dtv >= zero) then hl1 = hlinf - if(hlinf > .25) then + if(hlinf > 0.25_kp) then tem1 = hlinf * z1i hl0inf = z0max * tem1 hltinf = ztmax * tem1 - aa = sqrt(1. + alpha4 * hlinf) - aa0 = sqrt(1. + alpha4 * hl0inf) + aa = sqrt(one + alpha4 * hlinf) + aa0 = sqrt(one + alpha4 * hl0inf) bb = aa - bb0 = sqrt(1. + alpha4 * hltinf) - pm = aa0 - aa + log( (aa + 1.)/(aa0 + 1.) ) - ph = bb0 - bb + log( (bb + 1.)/(bb0 + 1.) ) + bb0 = sqrt(one + alpha4 * hltinf) + pm = aa0 - aa + log( (aa + one)/(aa0 + one) ) + ph = bb0 - bb + log( (bb + one)/(bb0 + one) ) fms = fm - pm fhs = fh - ph hl1 = fms * fms * rb / fhs @@ -446,27 +465,27 @@ subroutine stability & tem1 = hl1 * z1i hl0 = z0max * tem1 hlt = ztmax * tem1 - aa = sqrt(1. + alpha4 * hl1) - aa0 = sqrt(1. + alpha4 * hl0) + aa = sqrt(one + alpha4 * hl1) + aa0 = sqrt(one + alpha4 * hl0) bb = aa - bb0 = sqrt(1. + alpha4 * hlt) - pm = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) - ph = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) - hl110 = hl1 * 10. * z1i + bb0 = sqrt(one + alpha4 * hlt) + pm = aa0 - aa + log( (one+aa)/(one+aa0) ) + ph = bb0 - bb + log( (one+bb)/(one+bb0) ) + hl110 = hl1 * 10.0_kp * z1i hl110 = min(max(hl110, ztmin1), ztmax1) - aa = sqrt(1. + alpha4 * hl110) - pm10 = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) + aa = sqrt(one + alpha4 * hl110) + pm10 = aa0 - aa + log( (one+aa)/(one+aa0) ) hl12 = (hl1+hl1) * z1i hl12 = min(max(hl12,ztmin1),ztmax1) -! aa = sqrt(1. + alpha4 * hl12) - bb = sqrt(1. + alpha4 * hl12) - ph2 = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) +! aa = sqrt(one + alpha4 * hl12) + bb = sqrt(one + alpha4 * hl12) + ph2 = bb0 - bb + log( (one+bb)/(one+bb0) ) ! ! unstable case - check for unphysical obukhov length ! else ! dtv < 0 case olinf = z1 / hlinf - tem1 = 50.0 * z0max + tem1 = 50.0_kp * z0max if(abs(olinf) <= tem1) then hlinf = -z1 / tem1 hlinf = min(max(hlinf,ztmin1),ztmax1) @@ -474,30 +493,30 @@ subroutine stability & ! ! get pm and ph ! - if (hlinf >= -0.5) then + if (hlinf >= -0.5_kp) then hl1 = hlinf - pm = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) - ph = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) - hl110 = hl1 * 10. * z1i + pm = (a0 + a1*hl1) * hl1 / (one+ (b1+b2*hl1) *hl1) + ph = (a0p + a1p*hl1) * hl1 / (one+ (b1p+b2p*hl1)*hl1) + hl110 = hl1 * 10.0_kp * z1i hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = (a0 + a1*hl110) * hl110 / (1.+(b1+b2*hl110)*hl110) + pm10 = (a0 + a1*hl110) * hl110/(one+(b1+b2*hl110)*hl110) hl12 = (hl1+hl1) * z1i hl12 = min(max(hl12, ztmin1), ztmax1) - ph2 = (a0p + a1p*hl12) * hl12 / (1.+(b1p+b2p*hl12)*hl12) + ph2 = (a0p + a1p*hl12) * hl12/(one+(b1p+b2p*hl12)*hl12) else ! hlinf < 0.05 hl1 = -hlinf - tem1 = 1.0 / sqrt(hl1) - pm = log(hl1) + 2. * sqrt(tem1) - .8776 - ph = log(hl1) + .5 * tem1 + 1.386 + tem1 = one / sqrt(hl1) + pm = log(hl1) + 2.0_kp * sqrt(tem1) - .8776_kp + ph = log(hl1) + 0.5_kp * tem1 + 1.386_kp ! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 ! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 - hl110 = hl1 * 10. * z1i + hl110 = hl1 * 10.0_kp * z1i hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = log(hl110) + 2.0 / sqrt(sqrt(hl110)) - .8776 + pm10 = log(hl110) + 2.0_kp/sqrt(sqrt(hl110)) - 0.8776_kp ! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 hl12 = (hl1+hl1) * z1i hl12 = min(max(hl12, ztmin1), ztmax1) - ph2 = log(hl12) + 0.5 / sqrt(hl12) + 1.386 + ph2 = log(hl12) + 0.5_kp / sqrt(hl12) + 1.386_kp ! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 endif @@ -511,7 +530,7 @@ subroutine stability & fh2 = fh2 - ph2 cm = ca * ca / (fm * fm) ch = ca * ca / (fm * fh) - tem1 = 0.00001/z1 + tem1 = 0.00001_kp/z1 cm = max(cm, tem1) ch = max(ch, tem1) stress = cm * wind * wind diff --git a/physics/sfc_diff.meta b/physics/sfc_diff.meta index ab99dcb06..8db932a68 100644 --- a/physics/sfc_diff.meta +++ b/physics/sfc_diff.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sfc_diff + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = sfc_diff_run type = scheme @@ -352,6 +358,15 @@ kind = kind_phys intent = inout optional = F +[z0rl_wav] + standard_name = surface_roughness_length_from_wave_model + long_name = surface roughness length from wave model + units = cm + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [ustar_wat] standard_name = surface_friction_velocity_over_ocean long_name = surface friction velocity over ocean diff --git a/physics/sfc_drv.f b/physics/sfc_drv.f index 75afaa6ff..54e596db6 100644 --- a/physics/sfc_drv.f +++ b/physics/sfc_drv.f @@ -194,20 +194,24 @@ subroutine lsm_noah_run & implicit none ! --- constant parameters: - real(kind=kind_phys), parameter :: rhoh2o = 1000.0 - real(kind=kind_phys), parameter :: a2 = 17.2693882 - real(kind=kind_phys), parameter :: a3 = 273.16 - real(kind=kind_phys), parameter :: a4 = 35.86 + 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 :: rhoh2o = 1000.0_kind_phys + real(kind=kind_phys), parameter :: a2 = 17.2693882_kind_phys + real(kind=kind_phys), parameter :: a3 = 273.16_kind_phys + real(kind=kind_phys), parameter :: a4 = 35.86_kind_phys real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) + real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys real(kind=kind_phys), save :: zsoil_noah(4) - data zsoil_noah / -0.1, -0.4, -1.0, -2.0 / + data zsoil_noah / -0.1_kind_phys, -0.4_kind_phys, & + & -1.0_kind_phys, -2.0_kind_phys / ! --- input: integer, intent(in) :: im, km, isot, ivegsrc real (kind=kind_phys), intent(in) :: grav, cp, hvap, rd, eps, & & epsm1, rvrdm1 - real (kind=kind_phys), dimension(5), intent(in) :: pertvegf + real (kind=kind_phys), intent(in) :: pertvegf integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp @@ -266,9 +270,9 @@ subroutine lsm_noah_run & ! !===> ... begin here ! - cpinv = 1.0/cp - hvapi = 1.0/hvap - elocp = hvap/cp + cpinv = one/cp + hvapi = one/hvap + elocp = hvap/cp !> - Initialize CCPP error handling variables @@ -298,46 +302,33 @@ subroutine lsm_noah_run & do i = 1, im if (flag_iter(i) .and. land(i)) then - ep(i) = 0.0 - evap (i) = 0.0 - hflx (i) = 0.0 - gflux(i) = 0.0 - drain(i) = 0.0 - canopy(i) = max(canopy(i), 0.0) - - evbs (i) = 0.0 - evcw (i) = 0.0 - trans(i) = 0.0 - sbsno(i) = 0.0 - snowc(i) = 0.0 - snohf(i) = 0.0 - endif ! flag_iter & land - enddo + ep(i) = zero + evap (i) = zero + hflx (i) = zero + gflux(i) = zero + drain(i) = zero + canopy(i) = max(canopy(i), zero) + + evbs (i) = zero + evcw (i) = zero + trans(i) = zero + sbsno(i) = zero + snowc(i) = zero + snohf(i) = zero !> - initialize variables wind, q, and rh at level 1. - do i = 1, im - if (flag_iter(i) .and. land(i)) then - q0(i) = max(q1(i), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) + q0(i) = max(q1(i), qmin) !* q1=specific humidity at level 1 (kg/kg) theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) - rho(i) = prsl1(i) / (rd*t1(i)*(1.0+rvrdm1*q0(i))) + rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0(i))) qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) - qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), 1.e-8) + qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), qmin) q0 (i) = min(qs1(i), q0(i)) - endif ! flag_iter & land - enddo - do i = 1, im - if (flag_iter(i) .and. land(i)) then do k = 1, km zsoil(i,k) = zsoil_noah(k) enddo - endif ! flag_iter & land - enddo - - do i = 1, im - if (flag_iter(i) .and. land(i)) then !> - Prepare variables to run Noah LSM: !! - 1. configuration information (c): @@ -422,12 +413,12 @@ subroutine lsm_noah_run & !! 0.5 and the perturbations go to zero as vegetation fraction approaches its upper !! or lower bound. vegfp = vegfpert(i) ! sfc-perts, mgehne - if (pertvegf(1)>0.0) then + if (pertvegf>zero) then ! compute beta distribution parameters for vegetation fraction mv = shdfac - sv = pertvegf(1)*mv*(1.-mv) - alphav = mv*mv*(1.0-mv)/(sv*sv)-mv - betav = alphav*(1.0-mv)/mv + sv = pertvegf*mv*(one-mv) + alphav = mv*mv*(one-mv)/(sv*sv)-mv + betav = alphav*(one-mv)/mv ! compute beta distribution value corresponding ! to the given percentile albPpert to use as new albedo call ppfbet(vegfp,alphav,betav,iflag,vegftmp) @@ -439,7 +430,7 @@ subroutine lsm_noah_run & shdmax1d = shdmax(i) snoalb1d = snoalb(i) - ptu = 0.0 + ptu = zero alb = sfalb(i) tbot = tg3(i) @@ -456,8 +447,8 @@ subroutine lsm_noah_run & ! cm - surface exchange coefficient for momentum (\f$m s^{-1}\f$) -> cmx ! z0 - surface roughness (\f$m\f$) -> zorl(\f$cm\f$) - cmc = canopy(i) * 0.001 ! convert from mm to m - tsea = tsurf(i) ! clu_q2m_iter + cmc = canopy(i) * 0.001_kind_phys ! convert from mm to m + tsea = tsurf(i) ! clu_q2m_iter do k = 1, km stsoil(k) = stc(i,k) @@ -465,10 +456,10 @@ subroutine lsm_noah_run & slsoil(k) = slc(i,k) enddo - snowh = snwdph(i) * 0.001 ! convert from mm to m - sneqv = weasd(i) * 0.001 ! convert from mm to m - if (sneqv /= 0.0 .and. snowh == 0.0) then - snowh = 10.0 * sneqv + snowh = snwdph(i) * 0.001_kind_phys ! convert from mm to m + sneqv = weasd(i) * 0.001_kind_phys ! convert from mm to m + if (sneqv /= zero .and. snowh == zero) then + snowh = 10.0_kind_phys * sneqv endif chx = ch(i) * wind(i) ! compute conductance @@ -477,7 +468,7 @@ subroutine lsm_noah_run & cmm(i) = cmx ! ---- ... outside sflx, roughness uses cm as unit - z0 = zorl(i)/100. + z0 = zorl(i) * 0.01_kind_phys ! ---- mgehne, sfc-perts ! - Apply perturbation of soil type b parameter and leave area index. bexpp = bexppert(i) ! sfc perts, mgehne @@ -522,7 +513,7 @@ subroutine lsm_noah_run & trans(i) = ett sbsno(i) = esnow snowc(i) = sncovr - stm(i) = soilm * 1000.0 ! unit conversion (from m to kg m-2) + stm(i) = soilm * 1000.0_kind_phys ! unit conversion (from m to kg m-2) snohf(i) = flx1 + flx2 + flx3 smcwlt2(i) = smcwlt @@ -539,17 +530,17 @@ subroutine lsm_noah_run & wet1(i) = smsoil(1) / smcmax !Sarah Lu added 09/09/2010 (for GOCART) ! --- ... unit conversion (from m s-1 to mm s-1 and kg m-2 s-1) - runoff(i) = runoff1 * 1000.0 - drain (i) = runoff2 * 1000.0 + runoff(i) = runoff1 * 1000.0_kind_phys + drain (i) = runoff2 * 1000.0_kind_phys ! --- ... unit conversion (from m to mm) - canopy(i) = cmc * 1000.0 - snwdph(i) = snowh * 1000.0 - weasd(i) = sneqv * 1000.0 + canopy(i) = cmc * 1000.0_kind_phys + snwdph(i) = snowh * 1000.0_kind_phys + weasd(i) = sneqv * 1000.0_kind_phys sncovr1(i) = sncovr ! ---- ... outside sflx, roughness uses cm as unit (update after snow's ! effect) - zorl(i) = z0*100. + zorl(i) = z0*100.0_kind_phys !> - Do not return the following output fields to parent model: !!\n ec - canopy water evaporation (m s-1) @@ -590,25 +581,20 @@ subroutine lsm_noah_run & !!\n nroot - number of root layers, a function of veg type, determined !! in subroutine redprm. - endif ! end if flag_iter and flag - enddo ! end do_i_loop +! endif ! end if flag_iter and flag +! enddo ! end do_i_loop !> - Compute specific humidity at surface (\a qsurf). - do i = 1, im - if (flag_iter(i) .and. land(i)) then rch(i) = rho(i) * cp * ch(i) * wind(i) qsurf(i) = q1(i) + evap(i) / (elocp * rch(i)) - endif ! flag_iter & land - enddo !> - Compute surface upward sensible heat flux (\a hflx) and evaporation !! flux (\a evap). - do i = 1, im - if (flag_iter(i) .and. land(i)) then - tem = 1.0 / rho(i) + tem = one / rho(i) hflx(i) = hflx(i) * tem * cpinv evap(i) = evap(i) * tem * hvapi + endif ! flag_iter & land enddo diff --git a/physics/sfc_drv.meta b/physics/sfc_drv.meta index 7728ee375..b397e0f4c 100644 --- a/physics/sfc_drv.meta +++ b/physics/sfc_drv.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = lsm_noah + type = scheme + dependencies = funcphys.f90,machine.F,set_soilveg.f,sflx.f,surface_perturbation.F90 + +######################################################################## [ccpp-arg-table] name = lsm_noah_init type = scheme @@ -439,7 +445,7 @@ standard_name = magnitude_of_perturbation_of_vegetation_fraction long_name = magnitude of perturbation of vegetation fraction units = frac - dimensions = (5) + dimensions = () type = real kind = kind_phys intent = in diff --git a/physics/sfc_drv_ruc.meta b/physics/sfc_drv_ruc.meta index 4721418d3..2c91a3d59 100644 --- a/physics/sfc_drv_ruc.meta +++ b/physics/sfc_drv_ruc.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = lsm_ruc + type = scheme + dependencies = machine.F,module_sf_ruclsm.F90,module_soil_pre.F90,namelist_soilveg_ruc.F90,set_soilveg_ruc.F90 + +######################################################################## [ccpp-arg-table] name = lsm_ruc_init type = scheme diff --git a/physics/sfc_noahmp_drv.meta b/physics/sfc_noahmp_drv.meta index 4e1c5b334..73382d008 100644 --- a/physics/sfc_noahmp_drv.meta +++ b/physics/sfc_noahmp_drv.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = noahmpdrv + type = scheme + dependencies = funcphys.f90,machine.F,module_sf_noahmp_glacier.f90,module_sf_noahmplsm.f90,noahmp_tables.f90,set_soilveg.f + +######################################################################## [ccpp-arg-table] name = noahmpdrv_init type = scheme diff --git a/physics/sfc_nst.f b/physics/sfc_nst.f index 05b4f817a..5920f375c 100644 --- a/physics/sfc_nst.f +++ b/physics/sfc_nst.f @@ -161,7 +161,7 @@ subroutine sfc_nst_run & ! ===================================================================== ! use machine , only : kind_phys use funcphys, only : fpvs - use date_def, only: idate + use date_def, only : idate use module_nst_water_prop, only: get_dtzm_point use module_nst_parameters, only : t0k,cp_w,omg_m,omg_sh, & & sigma_r,solar_time_6am,ri_c,z_w_max,delz,wd_max, & @@ -175,11 +175,14 @@ subroutine sfc_nst_run & & dtl_reset ! implicit none + + integer, parameter :: kp = kind_phys ! ! --- constant parameters: - real (kind=kind_phys), parameter :: f24 = 24.0 ! hours/day - real (kind=kind_phys), parameter :: f1440 = 1440.0 ! minutes/day - real (kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) + real (kind=kind_phys), parameter :: f24 = 24.0_kp ! hours/day + real (kind=kind_phys), parameter :: f1440 = 1440.0_kp ! minutes/day + real (kind=kind_phys), parameter :: czmin = 0.0001_kp ! cos(89.994) + real (kind=kind_phys), parameter :: zero = 0.0_kp, one = 1.0_kp ! --- inputs: @@ -249,11 +252,11 @@ subroutine sfc_nst_run & errmsg = '' errflg = 0 - cpinv = 1.0/cp - hvapi = 1.0/hvap + cpinv = one/cp + hvapi = one/hvap elocp = hvap/cp - sss = 34.0 ! temporarily, when sea surface salinity data is not ready + sss = 34.0_kp ! temporarily, when sea surface salinity data is not ready ! ! flag for open water and where the iteration is on ! @@ -294,21 +297,21 @@ subroutine sfc_nst_run & nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) - q0(i) = max(q1(i), 1.0e-8) + q0(i) = max(q1(i), 1.0e-8_kp) #ifdef GSD_SURFACE_FLUXES_BUGFIX theta1(i) = t1(i) / prslk1(i) ! potential temperature at the middle of lowest model layer #else theta1(i) = t1(i) * prslki(i) #endif - tv1(i) = t1(i) * (1.0 + rvrdm1*q0(i)) + tv1(i) = t1(i) * (one + rvrdm1*q0(i)) rho_a(i) = prsl1(i) / (rd*tv1(i)) qss(i) = fpvs(tsurf(i)) ! pa qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa ! - evap(i) = 0.0 - hflx(i) = 0.0 - gflux(i) = 0.0 - ep(i) = 0.0 + evap(i) = zero + hflx(i) = zero + gflux(i) = zero + ep(i) = zero ! --- ... rcp = rho cp ch v @@ -334,8 +337,8 @@ subroutine sfc_nst_run & ! run nst model: dtm + slm ! - zsea1 = 0.001*real(nstf_name4) - zsea2 = 0.001*real(nstf_name5) + zsea1 = 0.001_kp*real(nstf_name4) + zsea2 = 0.001_kp*real(nstf_name5) !> - Call module_nst_water_prop::density() to compute sea water density. !> - Call module_nst_water_prop::rhocoef() to compute thermal expansion @@ -347,20 +350,20 @@ subroutine sfc_nst_run & ulwflx(i) = sfcemis(i) * sbc * t12 * t12 alon = xlon(i)*rad2deg grav = grv(sinlat(i)) - soltim = mod(alon/15.0 + solhr, 24.0)*3600.0 + soltim = mod(alon/15.0_kp + solhr, 24.0_kp)*3600.0_kp call density(tsea,sss,rho_w) ! sea water density call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta ! !> - Calculate sensible heat flux (\a qrain) due to rainfall. ! - le = (2.501-.00237*tsea)*1e6 - dwat = 2.11e-5*(t1(i)/t0k)**1.94 ! water vapor diffusivity - dtmp = (1.+3.309e-3*(t1(i)-t0k)-1.44e-6*(t1(i)-t0k)* - & (t1(i)-t0k))*0.02411/(rho_a(i)*cp) ! heat diffusivity - wetc = 622.0*le*qss(i)/(rd*t1(i)*t1(i)) - alfac = 1/(1+(wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor - qrain(i) = (1000.*rain(i)/rho_w)*alfac*cp_w* - & (tsea-t1(i)+(1000.*qss(i)-1000.*q0(i))*le/cp) + le = (2.501_kp-0.00237_kp*tsea)*1e6_kp + dwat = 2.11e-5_kp*(t1(i)/t0k)**1.94_kp ! water vapor diffusivity + dtmp = (one+3.309e-3_kp*(t1(i)-t0k)-1.44e-6_kp*(t1(i)-t0k) + & * (t1(i)-t0k))*0.02411_kp/(rho_a(i)*cp) ! heat diffusivity + wetc = 622.0_kp*le*qss(i)/(rd*t1(i)*t1(i)) + alfac = one / (one + (wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor + tem = (1.0e3_kp * rain(i) / rho_w) * alfac * cp_w + qrain(i) = tem * (tsea-t1(i)+1.0e3_kp*(qss(i)-q0(i))*le/cp) !> - Calculate input non solar heat flux as upward = positive to models here @@ -376,10 +379,10 @@ subroutine sfc_nst_run & ! ! sensitivities of heat flux components to ts ! - rnl_ts = 4.0*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) + rnl_ts = 4.0_kp*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) hs_ts = rch(i) hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12) - rf_ts = (1000.*rain(i)/rho_w)*alfac*cp_w*(1.0+rch(i)*hl_ts) + rf_ts = tem * (one+rch(i)*hl_ts) q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts ! !> - Call cool_skin(), which is the sub-layer cooling parameterization @@ -390,7 +393,7 @@ subroutine sfc_nst_run & &, rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le &, dt_cool(i),z_c(i),c_0(i),c_d(i)) - tem = 1.0 / wndmag(i) + tem = one / wndmag(i) cosa = u1(i)*tem sina = v1(i)*tem taux = max(stress(i),tau_min)*cosa @@ -399,20 +402,20 @@ subroutine sfc_nst_run & ! ! Run DTM-1p system. ! - if ( (soltim > solar_time_6am .and. ifd(i) == 0.0) ) then + if ( (soltim > solar_time_6am .and. ifd(i) == zero) ) then else - ifd(i) = 1.0 + ifd(i) = one ! ! calculate fcl thickness with current forcing and previous time's profile ! ! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i) !> - Call convdepth() to calculate depth for convective adjustments. - if ( f_nsol > 0.0 .and. xt(i) > 0.0 ) then + if ( f_nsol > zero .and. xt(i) > zero ) then call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w &, alpha,beta,xt(i),xs(i),xz(i),d_conv(i)) else - d_conv(i) = 0.0 + d_conv(i) = zero endif ! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i) @@ -440,7 +443,7 @@ subroutine sfc_nst_run & ! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i) ! apply mda - if ( xt(i) > 0.0 ) then + if ( xt(i) > zero ) then !> - If \a dtl heat content \a xt > 0.0, call dtm_1p_mda() to apply !! minimum depth adjustment (mda). call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i)) @@ -455,7 +458,7 @@ subroutine sfc_nst_run & endif ! apply fca - if ( d_conv(i) > 0.0 ) then + if ( d_conv(i) > zero ) then !> - If thickness of free convection layer > 0.0, call dtm_1p_fca() !! to apply free convection adjustment. !> - If \a dtl thickness >= module_nst_parameters::z_w_max(), call dtl_reset() @@ -480,7 +483,7 @@ subroutine sfc_nst_run & !> - Call cal_ttop() to calculate the diurnal warming amount at the top layer with !! thickness of \a dz. - if ( q_warm > 0.0 ) then + if ( q_warm > zero ) then call cal_ttop(kdt,timestep,q_warm,rho_w,dz, & xt(i),xz(i),ttop0) @@ -489,7 +492,7 @@ subroutine sfc_nst_run & ! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i), ! &' xz=',xz(i),' qrain=',qrain(i) - ttop = ((xt(i)+xt(i))/xz(i))*(1.0-dz/((xz(i)+xz(i)))) + ttop = ((xt(i)+xt(i))/xz(i))*(one-dz/((xz(i)+xz(i)))) ! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i) ! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz @@ -540,7 +543,7 @@ subroutine sfc_nst_run & ! endif ! if ( xt(i) > 0.0 ) then ! reset dtl at midnight and when solar zenith angle > 89.994 degree - if ( abs(soltim) < 2.0*timestep ) then + if ( abs(soltim) < 2.0_kp*timestep ) then call dtl_reset & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) endif @@ -553,17 +556,17 @@ subroutine sfc_nst_run & !> - Call get_dtzm_point() to computes \a dtz and \a tsurf. call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i), & zsea1,zsea2,dtz) - tsurf(i) = max(271.2, tref(i) + dtz ) + tsurf(i) = max(271.2_kp, tref(i) + dtz ) ! if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=', ! &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i) !> - Call cal_w() to calculate \a w_0 and \a w_d. - if ( xt(i) > 0.0 ) then + if ( xt(i) > zero ) then call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i)) else - w_0(i) = 0.0 - w_d(i) = 0.0 + w_0(i) = zero + w_d(i) = zero endif ! if ( xt(i) > 0.0 ) then @@ -631,7 +634,7 @@ subroutine sfc_nst_run & ! do i=1,im if ( flag(i) ) then - tem = 1.0 / rho_a(i) + tem = one / rho_a(i) hflx(i) = hflx(i) * tem * cpinv evap(i) = evap(i) * tem * hvapi endif @@ -673,14 +676,17 @@ end subroutine sfc_nst_pre_finalize !! @{ subroutine sfc_nst_pre_run & (im, wet, tsfc_wat, tsurf_wat, tseal, xt, xz, dt_cool, - & z_c, tref, cplflx, oceanfrac, errmsg, errflg) + & z_c, tref, cplflx, oceanfrac, nthreads, errmsg, errflg) use machine , only : kind_phys + use module_nst_water_prop, only: get_dtzm_2d implicit none + integer, parameter :: kp = kind_phys + ! --- inputs: - integer, intent(in) :: im + integer, intent(in) :: im, nthreads logical, dimension(im), intent(in) :: wet real (kind=kind_phys), dimension(im), intent(in) :: & tsfc_wat, xt, xz, dt_cool, z_c, oceanfrac @@ -696,11 +702,12 @@ subroutine sfc_nst_pre_run ! --- locals integer :: i - real(kind=kind_phys), parameter :: zero = 0.0d0, - & one = 1.0d0, - & half = 0.5d0, - & omz1 = 10.0d0 - real(kind=kind_phys) :: tem1, tem2, dt_warm + real(kind=kind_phys), parameter :: zero = 0.0_kp, + & one = 1.0_kp, + & half = 0.5_kp, + & omz1 = 2.0_kp + real(kind=kind_phys) :: tem1, tem2, dnsst + real(kind=kind_phys), dimension(im) :: dtzm ! Initialize CCPP error handling variables errmsg = '' @@ -712,27 +719,30 @@ subroutine sfc_nst_pre_run ! DH* 20190927 simplyfing this code because tem is zero !tem = zero !tseal(i) = tsfc_wat(i) + tem - tseal(i) = tsfc_wat(i) + tseal(i) = tsfc_wat(i) !tsurf_wat(i) = tsurf_wat(i) + tem ! *DH endif enddo +! +! update tsfc & tref with T1 from OGCM & NSST Profile if coupled +! if (cplflx) then - tem1 = half / omz1 + call get_dtzm_2d (xt, xz, dt_cool, & + & z_c, wet, zero, omz1, im, 1, nthreads, dtzm) do i=1,im if (wet(i) .and. oceanfrac(i) > zero) then - tem2 = one / xz(i) - dt_warm = (xt(i)+xt(i)) * tem2 - if ( xz(i) > omz1) then - tref(i) = tseal(i) - (one-half*omz1*tem2) * dt_warm & - & + z_c(i)*dt_cool(i)*tem1 +! dnsst = tsfc_wat(i) - tref(i) ! retrive/get difference of Ts and Tf + tref(i) = tsfc_wat(i) - dtzm(i) ! update Tf with T1 and NSST T-Profile +! tsfc_wat(i) = max(271.2,tref(i) + dnsst) ! get Ts updated due to Tf update +! tseal(i) = tsfc_wat(i) + if (abs(xz(i)) > zero) then + tem2 = one / xz(i) else - tref(i) = tseal(i) - (xz(i)*dt_warm & - & - z_c(i)*dt_cool(i))*tem1 + tem2 = zero endif - tseal(i) = tref(i) + dt_warm - dt_cool(i) -! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse + tseal(i) = tref(i) + (xt(i)+xt(i)) * tem2 - dt_cool(i) tsurf_wat(i) = tseal(i) endif enddo @@ -776,7 +786,7 @@ end subroutine sfc_nst_post_finalize subroutine sfc_nst_post_run & & ( im, rlapse, tgice, wet, icy, oro, oro_uf, nstf_name1, & & nstf_name4, nstf_name5, xt, xz, dt_cool, z_c, tref, xlon, & - & tsurf_wat, tsfc_wat, dtzm, errmsg, errflg & + & tsurf_wat, tsfc_wat, nthreads, dtzm, errmsg, errflg & & ) use machine , only : kind_phys @@ -784,8 +794,10 @@ subroutine sfc_nst_post_run & implicit none + integer, parameter :: kp = kind_phys + ! --- inputs: - integer, intent(in) :: im + integer, intent(in) :: im, nthreads logical, dimension(im), intent(in) :: wet, icy real (kind=kind_phys), intent(in) :: rlapse, tgice real (kind=kind_phys), dimension(im), intent(in) :: oro, oro_uf @@ -824,16 +836,14 @@ subroutine sfc_nst_post_run & ! --- ... run nsst model ... --- - dtzm = 0.0 if (nstf_name1 > 1) then - zsea1 = 0.001*real(nstf_name4) - zsea2 = 0.001*real(nstf_name5) - call get_dtzm_2d (xt, xz, dt_cool, & - & z_c, wet, zsea1, zsea2, & - & im, 1, dtzm) + zsea1 = 0.001_kp*real(nstf_name4) + zsea2 = 0.001_kp*real(nstf_name5) + call get_dtzm_2d (xt, xz, dt_cool, z_c, wet, zsea1, zsea2, & + & im, 1, nthreads, dtzm) do i = 1, im -! if (wet(i) .and. .not.icy(i)) then -! if (wet(i) .and. (Model%frac_grid .or. .not. icy(i))) then +! if (wet(i) .and. .not.icy(i)) then +! if (wet(i) .and. (frac_grid .or. .not. icy(i))) then if (wet(i)) then tsfc_wat(i) = max(tgice, tref(i) + dtzm(i)) ! tsfc_wat(i) = max(271.2, tref(i) + dtzm(i)) - & diff --git a/physics/sfc_nst.meta b/physics/sfc_nst.meta index 4198af0eb..44e132293 100644 --- a/physics/sfc_nst.meta +++ b/physics/sfc_nst.meta @@ -1,11 +1,7 @@ -[ccpp-arg-table] - name = sfc_nst_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = sfc_nst_finalize +[ccpp-table-properties] + name = sfc_nst type = scheme + dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] @@ -650,14 +646,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = sfc_nst_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = sfc_nst_finalize +[ccpp-table-properties] + name = sfc_nst_pre type = scheme + dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] @@ -768,6 +760,14 @@ kind = kind_phys intent = in optional = F +[nthreads] + standard_name = omp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP @@ -787,14 +787,10 @@ optional = F ######################################################################## -[ccpp-arg-table] - name = sfc_nst_post_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = sfc_nst_post_finalize +[ccpp-table-properties] + name = sfc_nst_post type = scheme + dependencies = date_def.f,funcphys.f90,machine.F,module_nst_model.f90,module_nst_parameters.f90,module_nst_water_prop.f90 ######################################################################## [ccpp-arg-table] @@ -956,6 +952,14 @@ kind = kind_phys intent = inout optional = F +[nthreads] + standard_name = omp_threads + long_name = number of OpenMP threads available for physics schemes + units = count + dimensions = () + type = integer + intent = in + optional = F [dtzm] standard_name = mean_change_over_depth_in_sea_water_temperature long_name = mean of dT(z) (zsea1 to zsea2) diff --git a/physics/sfc_ocean.F b/physics/sfc_ocean.F index 33a1d3082..20c8cdf02 100644 --- a/physics/sfc_ocean.F +++ b/physics/sfc_ocean.F @@ -28,8 +28,10 @@ end subroutine sfc_ocean_finalize !! \htmlinclude sfc_ocean_run.html !! subroutine sfc_ocean_run & - & ( im, cp, rd, eps, epsm1, hvap, rvrdm1, ps, t1, q1, & ! --- inputs - & tskin, cm, ch, prsl1, prslki, wet, lake, wind, & +!................................... +! --- inputs: + & ( im, rd, eps, epsm1, rvrdm1, ps, t1, q1, & + & tskin, cm, ch, prsl1, prslki, wet, lake, wind, &, ! --- inputs & flag_iter, & & qsurf, cmm, chh, gflux, evap, hflx, ep, & ! --- outputs & errmsg, errflg & @@ -44,7 +46,7 @@ subroutine sfc_ocean_run & ! inputs: ! ! ( im, ps, t1, q1, tskin, cm, ch, ! !! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! -! prsl1, prslki, wet, wind, flag_iter, ! +! prsl1, prslki, wet, lake, wind, flag_iter, ! ! outputs: ! ! qsurf, cmm, chh, gflux, evap, hflx, ep ) ! ! ! @@ -94,10 +96,12 @@ subroutine sfc_ocean_run & ! implicit none +! --- constant parameters: + real (kind=kind_phys), parameter :: one = 1.0_kind_phys, zero = 0.0_kind_phys & + &, qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im - real (kind=kind_phys), intent(in) :: cp, rd, eps, epsm1, hvap, & - & rvrdm1 + real (kind=kind_phys), intent(in) :: rd, eps, epsm1, rvrdm1 real (kind=kind_phys), dimension(im), intent(in) :: ps, & & t1, q1, tskin, cm, ch, prsl1, prslki, wind @@ -113,17 +117,11 @@ subroutine sfc_ocean_run & ! --- locals: - real (kind=kind_phys) :: q0, qss, rch, rho, tem, cpinv, & - & hvapi, elocp + real (kind=kind_phys) :: q0, qss, rch, rho, tem integer :: i - logical :: flag(im) -! !===> ... begin here - cpinv = 1.0/cp - hvapi = 1.0/hvap - elocp = hvap/cp ! ! -- ... initialize CCPP error handling variables errmsg = '' @@ -131,43 +129,34 @@ subroutine sfc_ocean_run & ! ! --- ... flag for open water do i = 1, im - flag(i) = (wet(i) .and. flag_iter(i)) ! --- ... initialize variables. all units are supposedly m.k.s. unless specified ! ps is in pascals, wind is wind speed, ! rho is density, qss is sat. hum. at surface - if ( flag(i) ) then - if(.not.lake(i)) then - q0 = max( q1(i), 1.0e-8 ) - rho = prsl1(i) / (rd*t1(i)*(1.0 + rvrdm1*q0)) + if (wet(i) .and. flag_iter(i) .and. .not. lake(i)) then + q0 = max( q1(i), qmin ) + rho = prsl1(i) / (rd*t1(i)*(one + rvrdm1*q0)) qss = fpvs( tskin(i) ) qss = eps*qss / (ps(i) + epsm1*qss) - evap(i) = 0.0 - hflx(i) = 0.0 - ep(i) = 0.0 - gflux(i) = 0.0 - ! --- ... rcp = rho cp ch v - rch = rho * cp * ch(i) * wind(i) + tem = ch(i) * wind(i) cmm(i) = cm(i) * wind(i) - chh(i) = rho * ch(i) * wind(i) + chh(i) = rho * tem ! --- ... sensible and latent heat flux over open water - hflx(i) = rch * (tskin(i) - t1(i) * prslki(i)) + hflx(i) = tem * (tskin(i) - t1(i) * prslki(i)) - evap(i) = elocp*rch * (qss - q0) - qsurf(i) = qss + evap(i) = tem * (qss - q0) - tem = 1.0 / rho - hflx(i) = hflx(i) * tem * cpinv - evap(i) = evap(i) * tem * hvapi + ep(i) = evap(i) + qsurf(i) = qss + gflux(i) = zero endif - endif !end of if not lake enddo ! return diff --git a/physics/sfc_ocean.meta b/physics/sfc_ocean.meta index 733e69f54..95b9aa37d 100644 --- a/physics/sfc_ocean.meta +++ b/physics/sfc_ocean.meta @@ -1,11 +1,7 @@ -[ccpp-arg-table] - name = sfc_ocean_init - type = scheme - -######################################################################## -[ccpp-arg-table] - name = sfc_ocean_finalize +[ccpp-table-properties] + name = sfc_ocean type = scheme + dependencies = funcphys.f90,machine.F ######################################################################## [ccpp-arg-table] @@ -19,15 +15,6 @@ type = integer intent = in optional = F -[cp] - standard_name = specific_heat_of_dry_air_at_constant_pressure - long_name = specific heat of dry air at constant pressure - units = J kg-1 K-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [rd] standard_name = gas_constant_dry_air long_name = ideal gas constant for dry air @@ -55,15 +42,6 @@ kind = kind_phys intent = in optional = F -[hvap] - standard_name = latent_heat_of_vaporization_of_water_at_0C - long_name = latent heat of evaporation/sublimation - units = J kg-1 - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [rvrdm1] standard_name = ratio_of_vapor_to_dry_air_gas_constants_minus_one long_name = (rv/rd) - 1 (rv = ideal gas constant for water vapor) diff --git a/physics/sfc_sice.f b/physics/sfc_sice.f index 6010fa4c9..ab67f849e 100644 --- a/physics/sfc_sice.f +++ b/physics/sfc_sice.f @@ -43,11 +43,12 @@ subroutine sfc_sice_run & & ( im, kice, sbc, hvap, tgice, cp, eps, epsm1, rvrdm1, grav, & ! --- inputs: & t0c, rd, ps, t1, q1, delt, & & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & - & cm, ch, prsl1, prslki, prsik1, prslk1, islimsk, wind, & - & flag_iter, lprnt, ipr, cimin, & + & cm, ch, prsl1, prslki, prsik1, prslk1, wind, & + & flag_iter, lprnt, ipr, & & hice, fice, tice, weasd, tskin, tprcp, tiice, ep, & ! --- input/outputs: & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx, & ! - & cplflx, cplchm, flag_cice, islmsk_cice, & + & frac_grid, icy, islmsk_cice, & + & min_lakeice, min_seaice, oceanfrac, & & errmsg, errflg & ) @@ -60,10 +61,10 @@ subroutine sfc_sice_run & ! inputs: ! ! ( im, kice, ps, t1, q1, delt, ! ! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! -! cm, ch, prsl1, prslki, prsik1, prslk1, islimsk, wind, ! +! cm, ch, prsl1, prslki, prsik1, prslk1, wind, ! ! flag_iter, ! ! input/outputs: ! -! hice, fice, tice, weasd, tskin, tprcp, tiice, ep, ! +! hice, fice, tice, weasd, tskin, tprcp, tiice, ep, ! ! outputs: ! ! snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx ) ! ! ! @@ -138,32 +139,34 @@ subroutine sfc_sice_run & implicit none ! ! - Define constant parameters - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 - real(kind=kind_phys), parameter :: himax = 8.0d0 !< maximum ice thickness allowed - real(kind=kind_phys), parameter :: himin = 0.1d0 !< minimum ice thickness required - real(kind=kind_phys), parameter :: hsmax = 2.0d0 !< maximum snow depth allowed - real(kind=kind_phys), parameter :: timin = 173.0d0 !< minimum temperature allowed for snow/ice - real(kind=kind_phys), parameter :: albfw = 0.06d0 !< albedo for lead - real(kind=kind_phys), parameter :: dsi = one/0.33d0 + 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 :: 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 + real(kind=kind_phys), parameter :: timin = 173.0_kind_phys !< minimum temperature allowed for snow/ice + real(kind=kind_phys), parameter :: albfw = 0.06_kind_phys !< albedo for lead + real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys ! --- inputs: integer, intent(in) :: im, kice, ipr logical, intent(in) :: lprnt - logical, intent(in) :: cplflx - logical, intent(in) :: cplchm + logical, intent(in) :: frac_grid real (kind=kind_phys), intent(in) :: sbc, hvap, tgice, cp, eps, & & epsm1, grav, rvrdm1, t0c, rd real (kind=kind_phys), dimension(im), intent(in) :: ps, & & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & - & prsl1, prslki, prsik1, prslk1, wind + & prsl1, prslki, prsik1, prslk1, wind, oceanfrac - integer, dimension(im), intent(in) :: islimsk +! integer, dimension(im), intent(in) :: islimsk integer, dimension(im), intent(in) :: islmsk_cice - real (kind=kind_phys), intent(in) :: delt, cimin + real (kind=kind_phys), intent(in) :: delt, min_seaice, & + & min_lakeice - logical, dimension(im), intent(in) :: flag_iter, flag_cice + logical, dimension(im), intent(in) :: flag_iter, icy ! --- input/outputs: real (kind=kind_phys), dimension(im), intent(inout) :: hice, & @@ -180,14 +183,14 @@ subroutine sfc_sice_run & ! --- locals: real (kind=kind_phys), dimension(im) :: ffw, evapi, evapw, & - & sneti, snetw, hfd, hfi, & + & sneti, hfd, hfi, & ! & hflxi, hflxw, sneti, snetw, qssi, qssw, hfd, hfi, hfw, & & focn, snof, rch, rho, & & snowd, theta1 real (kind=kind_phys) :: t12, t14, tem, stsice(im,kice) &, hflxi, hflxw, q0, qs1, qssi, qssw - real (kind=kind_phys) :: cpinv, hvapi, elocp + real (kind=kind_phys) :: cpinv, hvapi, elocp, snetw, cimin integer :: i, k integer, dimension(im) :: islmsk_local @@ -205,15 +208,22 @@ subroutine sfc_sice_run & errflg = 0 - if (cplflx) then - where (flag_cice) - islmsk_local = islmsk_cice - elsewhere - islmsk_local = islimsk - endwhere - else - islmsk_local = islimsk - end if + islmsk_local = islmsk_cice + if (frac_grid) then + do i=1,im + if (icy(i) .and. islmsk_local(i) < 2) then + if (oceanfrac(i) > zero) then + tem = min_seaice + else + tem = min_lakeice + endif + if (fice(i) > tem) then + islmsk_local(i) = 2 + tice(i) =min( tice(i), tgice) + endif + endif + enddo + endif ! !> - Set flag for sea-ice. @@ -230,7 +240,7 @@ subroutine sfc_sice_run & if (flag(i)) then if (srflag(i) > zero) then ep(i) = ep(i)*(one-srflag(i)) - weasd(i) = weasd(i) + 1.e3*tprcp(i)*srflag(i) + weasd(i) = weasd(i) + 1000.0_kind_phys*tprcp(i)*srflag(i) tprcp(i) = tprcp(i)*(one-srflag(i)) endif endif @@ -253,13 +263,18 @@ subroutine sfc_sice_run & do i = 1, im if (flag(i)) then + if (oceanfrac(i) > zero) then + cimin = min_seaice + else + cimin = min_lakeice + endif ! psurf(i) = 1000.0 * ps(i) ! ps1(i) = 1000.0 * prsl1(i) ! dlwflx has been given a negative sign for downward longwave ! sfcnsw is the net shortwave flux (direction: dn-up) - q0 = max(q1(i), 1.0e-8) + q0 = max(q1(i), qmin) ! tsurf(i) = tskin(i) #ifdef GSD_SURFACE_FLUXES_BUGFIX theta1(i) = t1(i) / prslk1(i) ! potential temperature in middle of lowest atm. layer @@ -268,7 +283,7 @@ subroutine sfc_sice_run & #endif rho(i) = prsl1(i) / (rd*t1(i)*(one+rvrdm1*q0)) qs1 = fpvs(t1(i)) - qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), 1.e-8) + qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), qmin) q0 = min(qs1, q0) if (fice(i) < cimin) then @@ -278,7 +293,7 @@ subroutine sfc_sice_run & tskin(i)= tgice print *,'fix ice fraction: reset it to:', fice(i) endif - ffw(i) = 1.0 - fice(i) + ffw(i) = one - fice(i) qssi = fpvs(tice(i)) qssi = eps*qssi / (ps(i) + epsm1*qssi) @@ -287,7 +302,7 @@ subroutine sfc_sice_run & !> - Convert snow depth in water equivalent from mm to m unit. - snowd(i) = weasd(i) * 0.001d0 + snowd(i) = weasd(i) * 0.001_kind_phys ! flagsnw(i) = .false. ! --- ... when snow depth is less than 1 mm, a patchy snow is assumed and @@ -307,10 +322,11 @@ subroutine sfc_sice_run & evapw(i) = elocp * rch(i) * (qssw - q0) ! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) - snetw(i) = sfcdsw(i) * (one - albfw) - snetw(i) = min(3.0*sfcnsw(i)/(one+2.0d0*ffw(i)), snetw(i)) + snetw = sfcdsw(i) * (one - albfw) + snetw = min(3.0_kind_phys*sfcnsw(i) & + & / (one+2.0_kind_phys*ffw(i)), snetw) !> - Calculate net solar incoming at top \a sneti. - sneti(i) = (sfcnsw(i) - ffw(i)*snetw(i)) / fice(i) + sneti(i) = (sfcnsw(i) - ffw(i)*snetw) / fice(i) t12 = tice(i) * tice(i) t14 = t12 * t12 @@ -325,7 +341,7 @@ subroutine sfc_sice_run & & + rch(i)*(tice(i) - theta1(i)) #endif !> - Calculate heat flux derivative at surface \a hfd. - hfd(i) = 4.0d0*sfcemis(i)*sbc*tice(i)*t12 & + hfd(i) = 4.0_kind_phys*sfcemis(i)*sbc*tice(i)*t12 & & + (one + elocp*eps*hvap*qs1/(rd*t12)) * rch(i) t12 = tgice * tgice @@ -334,18 +350,18 @@ subroutine sfc_sice_run & ! --- ... hfw = net heat flux @ water surface (within ice) ! hfw(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapw(i) & -! & + rch(i)*(tgice - theta1(i)) - snetw(i) +! & + rch(i)*(tgice - theta1(i)) - snetw !> - Assigin heat flux from ocean \a focn and snowfall rate as constants, which !! should be from ocean model and other physics. - focn(i) = 2.0d0 ! heat flux from ocean - should be from ocn model + focn(i) = 2.0_kind_phys ! heat flux from ocean - should be from ocn model snof(i) = zero ! snowfall rate - snow accumulates in gbphys !> - Initialize snow depth \a snowd. hice(i) = max( min( hice(i), himax ), himin ) snowd(i) = min( snowd(i), hsmax ) - if (snowd(i) > (2.0d0*hice(i))) then + if (snowd(i) > (2.0_kind_phys*hice(i))) then print *, 'warning: too much snow :',snowd(i) snowd(i) = hice(i) + hice(i) print *,'fix: decrease snow depth to:',snowd(i) @@ -415,10 +431,10 @@ subroutine sfc_sice_run & ! --- ... convert snow depth back to mm of water equivalent - weasd(i) = snowd(i) * 1000.0 + weasd(i) = snowd(i) * 1000.0_kind_phys snwdph(i) = weasd(i) * dsi ! snow depth in mm - tem = 1.0 / rho(i) + tem = one / rho(i) hflx(i) = hflx(i) * tem * cpinv evap(i) = evap(i) * tem * hvapi endif @@ -518,28 +534,28 @@ subroutine ice3lay ! ! --- constant parameters: (properties of ice, snow, and seawater) - real (kind=kind_phys), parameter :: ds = 330.0d0 !< snow (ov sea ice) density (kg/m^3) - real (kind=kind_phys), parameter :: dw =1000.0d0 !< fresh water density (kg/m^3) + real (kind=kind_phys), parameter :: ds = 330.0_kind_phys !< snow (ov sea ice) density (kg/m^3) + real (kind=kind_phys), parameter :: dw =1000.0_kind_phys !< fresh water density (kg/m^3) real (kind=kind_phys), parameter :: dsdw = ds/dw real (kind=kind_phys), parameter :: dwds = dw/ds - real (kind=kind_phys), parameter :: ks = 0.31d0 !< conductivity of snow (w/mk) - real (kind=kind_phys), parameter :: i0 = 0.3d0 !< ice surface penetrating solar fraction - real (kind=kind_phys), parameter :: ki = 2.03d0 !< conductivity of ice (w/mk) - real (kind=kind_phys), parameter :: di = 917.0d0 !< density of ice (kg/m^3) + real (kind=kind_phys), parameter :: ks = 0.31_kind_phys !< conductivity of snow (w/mk) + real (kind=kind_phys), parameter :: i0 = 0.3_kind_phys !< ice surface penetrating solar fraction + real (kind=kind_phys), parameter :: ki = 2.03_kind_phys !< conductivity of ice (w/mk) + real (kind=kind_phys), parameter :: di = 917.0_kind_phys !< density of ice (kg/m^3) real (kind=kind_phys), parameter :: didw = di/dw real (kind=kind_phys), parameter :: dsdi = ds/di - real (kind=kind_phys), parameter :: ci = 2054.0d0 !< heat capacity of fresh ice (j/kg/k) - real (kind=kind_phys), parameter :: li = 3.34e5 !< latent heat of fusion (j/kg-ice) - real (kind=kind_phys), parameter :: si = 1.0d0 !< salinity of sea ice - real (kind=kind_phys), parameter :: mu = 0.054d0 !< relates freezing temp to salinity - real (kind=kind_phys), parameter :: tfi = -mu*si !< sea ice freezing temp = -mu*salinity - real (kind=kind_phys), parameter :: tfw = -1.8d0 !< tfw - seawater freezing temp (c) - real (kind=kind_phys), parameter :: tfi0 = tfi-0.0001d0 + real (kind=kind_phys), parameter :: ci = 2054.0_kind_phys !< heat capacity of fresh ice (j/kg/k) + real (kind=kind_phys), parameter :: li = 3.34e5_kind_phys !< latent heat of fusion (j/kg-ice) + real (kind=kind_phys), parameter :: si = 1.0_kind_phys !< salinity of sea ice + real (kind=kind_phys), parameter :: mu = 0.054_kind_phys !< relates freezing temp to salinity + real (kind=kind_phys), parameter :: tfi = -mu*si !< sea ice freezing temp = -mu*salinity + real (kind=kind_phys), parameter :: tfw = -1.8_kind_phys !< tfw - seawater freezing temp (c) + real (kind=kind_phys), parameter :: tfi0 = tfi-0.0001_kind_phys real (kind=kind_phys), parameter :: dici = di*ci real (kind=kind_phys), parameter :: dili = di*li real (kind=kind_phys), parameter :: dsli = ds*li - real (kind=kind_phys), parameter :: ki4 = ki*4.0d0 - real (kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 + 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 ! --- inputs: integer, intent(in) :: im, kmi, ipr @@ -572,9 +588,9 @@ subroutine ice3lay ! !===> ... begin here ! - dt2 = 2.0d0 * delt - dt4 = 4.0d0 * delt - dt6 = 6.0d0 * delt + dt2 = delt + delt + dt4 = dt2 + dt2 + dt6 = dt2 + dt4 dt2i = one / dt2 do i = 1, im @@ -629,7 +645,7 @@ subroutine ice3lay !> - Calculate the new upper ice temperature following \a eq.(21) !! in Winton (2000) \cite winton_2000. - stsice(i,1) = -(sqrt(b1*b1 - 4.0d0*a1*c1) + b1)/(a1+a1) + stsice(i,1) = -(sqrt(b1*b1-4.0_kind_phys*a1*c1) + b1)/(a1+a1) tice(i) = (k12*stsice(i,1) - ai) / (k12 + bi) !> - If the surface temperature is greater than the freezing temperature @@ -642,7 +658,8 @@ subroutine ice3lay if (tice(i) > tsf) then a1 = a10 + k12 b1 = b10 - k12*tsf - stsice(i,1) = -(sqrt(b1*b1 - 4.0d0*a1*c1) + b1)/(a1+a1) + stsice(i,1) = -(sqrt(b1*b1-4.0_kind_phys*a1*c1) + b1) & + & / (a1+a1) tice(i) = tsf tmelt = (k12*(stsice(i,1)-tsf) - (ai+bi*tsf)) * delt else @@ -662,8 +679,8 @@ subroutine ice3lay !> - Calculation of ice and snow mass changes. - h1 = 0.5d0 * hice(i) - h2 = 0.5d0 * hice(i) + h1 = 0.5_kind_phys * hice(i) + h2 = 0.5_kind_phys * hice(i) !> - Calculate the top layer thickness. @@ -695,7 +712,7 @@ subroutine ice3lay hice(i) = h1 + h2 if (hice(i) > zero) then - if (h1 > 0.5d0*hice(i)) then + if (h1 > 0.5_kind_phys*hice(i)) then f1 = one - (h2+h2) / hice(i) stsice(i,2) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& & + (one - f1)*stsice(i,2) @@ -709,7 +726,7 @@ subroutine ice3lay stsice(i,1) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& & + (one - f1)*stsice(i,2) stsice(i,1) = (stsice(i,1) - sqrt(stsice(i,1)*stsice(i,1) & - & - 4.0d0*tfi*li/ci)) * 0.5d0 + & - 4.0_kind_phys*tfi*li/ci)) * 0.5_kind_phys endif k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) diff --git a/physics/sfc_sice.meta b/physics/sfc_sice.meta index f916d09fd..10fcfb6ab 100644 --- a/physics/sfc_sice.meta +++ b/physics/sfc_sice.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = sfc_sice + type = scheme + dependencies = funcphys.f90,machine.F + +######################################################################## [ccpp-arg-table] name = sfc_sice_run type = scheme @@ -242,14 +248,6 @@ kind = kind_phys intent = in optional = F -[islimsk] - standard_name = sea_land_ice_mask - long_name = sea/land/ice mask (=0/1/2) - units = flag - dimensions = (horizontal_dimension) - type = integer - intent = in - optional = F [wind] standard_name = wind_speed_at_lowest_model_layer long_name = wind speed at lowest model level @@ -283,15 +281,6 @@ type = integer intent = in optional = F -[cimin] - standard_name = lake_ice_minimum - long_name = minimum lake ice value - units = ??? - dimensions = () - type = real - kind = kind_phys - intent = in - optional = F [hice] standard_name = sea_ice_thickness long_name = sea-ice thickness @@ -436,25 +425,17 @@ kind = kind_phys intent = inout optional = F -[cplflx] - standard_name = flag_for_flux_coupling - long_name = flag controlling cplflx collection (default off) +[frac_grid] + standard_name = flag_for_fractional_grid + long_name = flag for fractional grid units = flag dimensions = () type = logical intent = in optional = F -[cplchm] - standard_name = flag_for_chemistry_coupling - long_name = flag controlling cplchm collection (default off) - units = flag - dimensions = () - type = logical - intent = in - optional = F -[flag_cice] - standard_name = flag_for_cice - long_name = flag for cice +[icy] + standard_name = flag_nonzero_sea_ice_surface_fraction + long_name = flag indicating presence of some sea ice surface area fraction units = flag dimensions = (horizontal_dimension) type = logical @@ -468,6 +449,33 @@ type = integer intent = in optional = F +[min_lakeice] + standard_name = lake_ice_minimum + long_name = minimum lake ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[min_seaice] + standard_name = sea_ice_minimum + long_name = minimum sea ice value + units = frac + dimensions = () + type = real + kind = kind_phys + intent = in + optional = F +[oceanfrac] + standard_name = sea_area_fraction + long_name = fraction of horizontal grid area occupied by ocean + units = frac + dimensions = (horizontal_dimension) + type = real + kind = kind_phys + intent = in + optional = F [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/sfcsub.F b/physics/sfcsub.F index b0fe168bd..a7679d66c 100644 --- a/physics/sfcsub.F +++ b/physics/sfcsub.F @@ -35,6 +35,7 @@ module sfccyc_module integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata integer :: veg_type_landice integer :: soil_type_landice + integer :: num_threads ! ! contains @@ -79,16 +80,21 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & &, vegfcs,vetfcs,sotfcs,alffcs & - &, cvfcs,cvbfcs,cvtfcs,me,nlunit & + &, cvfcs,cvbfcs,cvtfcs,me,nthrds,nlunit & &, sz_nml,input_nml_file & + &, lake, min_lakeice, min_seaice & &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) ! use machine , only : kind_io8,kind_io4 use sfccyc_module implicit none - character(len=*), intent(in) :: tile_num_ch - integer,intent(in) :: i_index(len), j_index(len) - logical use_ufo, nst_anl + character(len=*), intent(in) :: tile_num_ch + integer, intent(in) :: i_index(len), j_index(len), & + & me, nthrds + logical, intent(in) :: use_ufo, nst_anl + logical, intent(in) :: lake(len) + real (kind=kind_io8), intent(in) :: min_lakeice, min_seaice + real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, & & orolmx,orolmn,oroomx,oroomn,orosmx, & & orosmn,oroimx,oroimn,orojmx,orojmn, & @@ -99,7 +105,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & snolmx,snolmn,snoomx,snoomn,snosmx, & & snosmn,snoimx,snoimn,snojmx,snojmn, & & zorlmx,zorlmn,zoromx,zoromn,zorsmx, & - & zorsmn,zorimx,zorimn,zorjmx, zorjmn, & + & zorsmn,zorimx,zorimn,zorjmx,zorjmn, & & plrlmx,plrlmn,plromx,plromn,plrsmx, & & plrsmn,plrimx,plrimn,plrjmx,plrjmn, & & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, & @@ -160,17 +166,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, sihnew integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, & - & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, & + & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, & & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, & & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, & & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, & - & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb & + & icsnos,irttg3,kqcm,nlunit,sz_nml,ialb & &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc logical gausm, deads, qcmsk, znlst, monclm, monanl, & & monfcs, monmer, mondif, landice character(len=*), intent(in) :: input_nml_file(sz_nml) - - integer num_parthds ! !> This is a limited point version of surface program. !! @@ -296,8 +300,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! & sihsmx=8.0,sihsmn=0.0,sihimx=8.0,sihimn=0.10, ! & sihjmx=8.0,sihjmn=0.10,glacir_hice=3.0) parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, - & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15, - & sicjmx=1.0,sicjmn=0.15) + & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicjmx=1.0) +! & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15, +! & sicjmx=1.0,sicjmn=0.15) parameter(wetlmx=0.15,wetlmn=0.00,wetomx=0.15,wetomn=0.15, & wetsmx=0.15,wetsmn=0.15,wetimx=0.15,wetimn=0.15, @@ -460,34 +465,34 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! climatology surface fields (last character 'c' or 'clm' indicate climatology) ! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & - & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, & - & fnvegc,fnvetc,fnsotc & + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc & + &, fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc & + &, fnvegc,fnvetc,fnsotc & &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2 - real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), & - & zorclm(len), albclm(len,4), aisclm(len), & - & tg3clm(len), acnclm(len), cnpclm(len), & - & cvclm (len), cvbclm(len), cvtclm(len), & - & scvclm(len), tsfcl2(len), vegclm(len), & - & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), & - & smcclm(len,lsoil), stcclm(len,lsoil) & + real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len) & + &, zorclm(len), albclm(len,4), aisclm(len) & + &, tg3clm(len), acnclm(len), cnpclm(len) & + &, cvclm (len), cvbclm(len), cvtclm(len) & + &, scvclm(len), tsfcl2(len), vegclm(len) & + &, vetclm(len), sotclm(len), alfclm(len,2), sliclm(len) & + &, smcclm(len,lsoil), stcclm(len,lsoil) & &, sihclm(len), sicclm(len) & &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) ! ! analyzed surface fields (last character 'a' or 'anl' indicate analysis) ! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & - & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, & - & fnvega,fnveta,fnsota & - &, fnvmna,fnvmxa,fnslpa,fnabsa -! - real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), & - & zoranl(len), albanl(len,4), aisanl(len), & - & tg3anl(len), acnanl(len), cnpanl(len), & - & cvanl (len), cvbanl(len), cvtanl(len), & - & scvanl(len), tsfan2(len), veganl(len), & - & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), & - & smcanl(len,lsoil), stcanl(len,lsoil) & + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa & + &, fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna & + &, fnvega,fnveta,fnsota & + &, fnvmna,fnvmxa,fnslpa,fnabsa +! + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len) & + &, zoranl(len), albanl(len,4), aisanl(len) & + &, tg3anl(len), acnanl(len), cnpanl(len) & + &, cvanl (len), cvbanl(len), cvtanl(len) & + &, scvanl(len), tsfan2(len), veganl(len) & + &, vetanl(len), sotanl(len), alfanl(len,2), slianl(len) & + &, smcanl(len,lsoil), stcanl(len,lsoil) & &, sihanl(len), sicanl(len) & &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) ! @@ -495,13 +500,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! predicted surface fields (last characters 'fcs' indicates forecast) ! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & - & zorfcs(len), albfcs(len,4), aisfcs(len), & - & tg3fcs(len), acnfcs(len), cnpfcs(len), & - & cvfcs (len), cvbfcs(len), cvtfcs(len), & - & slifcs(len), vegfcs(len), & - & vetfcs(len), sotfcs(len), alffcs(len,2), & - & smcfcs(len,lsoil), stcfcs(len,lsoil) & + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len) & + &, zorfcs(len), albfcs(len,4), aisfcs(len) & + &, tg3fcs(len), acnfcs(len), cnpfcs(len) & + &, cvfcs (len), cvbfcs(len), cvtfcs(len) & + &, slifcs(len), vegfcs(len) & + &, vetfcs(len), sotfcs(len), alffcs(len,2) & + &, smcfcs(len,lsoil), stcfcs(len,lsoil) & &, sihfcs(len), sicfcs(len), sitfcs(len) & &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) & &, swdfcs(len), slcfcs(len,lsoil) @@ -585,8 +590,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! lqcbgs=.true. quality controls input bges file before merging (should have been ! qced in the forecast program) ! - logical ldebug,lqcbgs - logical lprnt + logical :: ldebug, lqcbgs, lprnt ! ! debug only ! @@ -769,6 +773,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & &, imsk, jmsk, slmskh, blnmsk, bltmsk &, glacir, amxice, tsfcl0 &, caisl, caiss, cvegs +! Set number of threads num_threads in sfccyc_module for later use +! to the value received from the calling routine (nthrds) + num_threads = nthrds ! lprnt = .false. iprnt = 1 @@ -807,7 +814,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & abslmn = .01 abssmn = .01 endif - if(ifp.eq.0) then + if (ifp == 0) then ifp = 1 do k=1,lsoil fsmcl(k) = 99999. @@ -824,15 +831,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & #endif ! write(6,namsfc) ! - if (me .eq. 0) then - print *,'ftsfl,falbl,faisl,fsnol,fzorl=', - & ftsfl,falbl,faisl,fsnol,fzorl - print *,'fsmcl=',fsmcl(1:lsoil) - print *,'fstcl=',fstcl(1:lsoil) - print *,'ftsfs,falbs,faiss,fsnos,fzors=', - & ftsfs,falbs,faiss,fsnos,fzors - print *,'fsmcs=',fsmcs(1:lsoil) - print *,'fstcs=',fstcs(1:lsoil) + if (me == 0) then + print *,' ftsfl,falbl,faisl,fsnol,fzorl=', & + & ftsfl,falbl,faisl,fsnol,fzorl + print *,' fsmcl=',fsmcl(1:lsoil) + print *,' fstcl=',fstcl(1:lsoil) + print *,' ftsfs,falbs,faiss,fsnos,fzors=', & + & ftsfs,falbs,faiss,fsnos,fzors + print *,' fsmcs=',fsmcs(1:lsoil) + print *,' fstcs=',fstcs(1:lsoil) print *,' aislim=',aislim,' sihnew=',sihnew print *,' isot=', isot,' ivegsrc=',ivegsrc endif @@ -850,176 +857,176 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! deltf = deltsfc / 24.0 ! - ctsfl=0. !... tsfc over land - if(ftsfl.ge.99999.) ctsfl=1. - if((ftsfl.gt.0.).and.(ftsfl.lt.99999)) ctsfl=exp(-deltf/ftsfl) + ctsfl = 0. !... tsfc over land + if (ftsfl >= 99999.) ctsfl = 1. + if (ftsfl > 0. .and. ftsfl < 99999) ctsfl = exp(-deltf/ftsfl) ! ctsfs=0. !... tsfc over sea - if(ftsfs.ge.99999.) ctsfs=1. - if((ftsfs.gt.0.).and.(ftsfs.lt.99999)) ctsfs=exp(-deltf/ftsfs) + if (ftsfs >= 99999.) ctsfs=1. + if (ftsfs > 0. .and. ftsfs < 99999) ctsfs = exp(-deltf/ftsfs) ! do k=1,lsoil - csmcl(k)=0. !... soilm over land - if(fsmcl(k).ge.99999.) csmcl(k)=1. - if((fsmcl(k).gt.0.).and.(fsmcl(k).lt.99999)) - & csmcl(k)=exp(-deltf/fsmcl(k)) + csmcl(k) = 0. !... soilm over land + if (fsmcl(k) >= 99999.) csmcl(k) = 1. + if (fsmcl(k) > 0. .and. fsmcl(k) < 99999) + & csmcl(k) = exp(-deltf/fsmcl(k)) csmcs(k)=0. !... soilm over sea - if(fsmcs(k).ge.99999.) csmcs(k)=1. - if((fsmcs(k).gt.0.).and.(fsmcs(k).lt.99999)) - & csmcs(k)=exp(-deltf/fsmcs(k)) + if (fsmcs(k) >= 99999.) csmcs(k) = 1. + if (fsmcs(k) > 0. .and. fsmcs(k) < 99999) + & csmcs(k) = exp(-deltf/fsmcs(k)) enddo ! - calbl=0. !... albedo over land - if(falbl.ge.99999.) calbl=1. - if((falbl.gt.0.).and.(falbl.lt.99999)) calbl=exp(-deltf/falbl) + calbl = 0. !... albedo over land + if (falbl >= 99999.) calbl = 1. + if (falbl > 0. .and. falbl < 99999) calbl = exp(-deltf/falbl) ! calfl=0. !... fraction field for albedo over land - if(falfl.ge.99999.) calfl=1. - if((falfl.gt.0.).and.(falfl.lt.99999)) calfl=exp(-deltf/falfl) + if (falfl >= 99999.) calfl = 1. + if (falfl > 0. .and. falfl < 99999) calfl = exp(-deltf/falfl) ! calbs=0. !... albedo over sea - if(falbs.ge.99999.) calbs=1. - if((falbs.gt.0.).and.(falbs.lt.99999)) calbs=exp(-deltf/falbs) + if (falbs >= 99999.) calbs = 1. + if (falbs > 0. .and. falbs < 99999) calbs = exp(-deltf/falbs) ! - calfs=0. !... fraction field for albedo over sea - if(falfs.ge.99999.) calfs=1. - if((falfs.gt.0.).and.(falfs.lt.99999)) calfs=exp(-deltf/falfs) + calfs = 0. !... fraction field for albedo over sea + if (falfs >= 99999.) calfs = 1. + if (falfs > 0. .and. falfs < 99999) calfs = exp(-deltf/falfs) ! - caisl=0. !... sea ice over land - if(faisl.ge.99999.) caisl=1. - if((faisl.gt.0.).and.(faisl.lt.99999)) caisl=1. + caisl = 0. !... sea ice over land + if (faisl >= 99999.) caisl = 1. + if (faisl > 0. .and. faisl < 99999) caisl = 1. ! - caiss=0. !... sea ice over sea - if(faiss.ge.99999.) caiss=1. - if((faiss.gt.0.).and.(faiss.lt.99999)) caiss=1. + caiss = 0. !... sea ice over sea + if (faiss >= 99999.) caiss = 1. + if (faiss > 0. .and. faiss < 99999) caiss = 1. ! - csnol=0. !... snow over land - if(fsnol.ge.99999.) csnol=1. - if((fsnol.gt.0.).and.(fsnol.lt.99999)) csnol=exp(-deltf/fsnol) + csnol = 0. !... snow over land + if (fsnol >= 99999.) csnol = 1. + if (fsnol > 0. .and. fsnol < 99999) csnol = exp(-deltf/fsnol) ! using the same way to bending snow as narr when fsnol is the negative value ! the magnitude of fsnol is the thread to determine the lower and upper bound ! of final swe - if(fsnol.lt.0.)csnol=fsnol + if (fsnol < 0.) csnol = fsnol ! - csnos=0. !... snow over sea - if(fsnos.ge.99999.) csnos=1. - if((fsnos.gt.0.).and.(fsnos.lt.99999)) csnos=exp(-deltf/fsnos) + csnos = 0. !... snow over sea + if (fsnos >= 99999.) csnos = 1. + if (fsnos > 0 .and. fsnos < 99999) csnos = exp(-deltf/fsnos) ! - czorl=0. !... roughness length over land - if(fzorl.ge.99999.) czorl=1. - if((fzorl.gt.0.).and.(fzorl.lt.99999)) czorl=exp(-deltf/fzorl) + czorl = 0. !... roughness length over land + if (fzorl >= 99999.) czorl = 1. + if (fzorl > 0. .and. fzorl < 99999) czorl = exp(-deltf/fzorl) ! - czors=0. !... roughness length over sea - if(fzors.ge.99999.) czors=1. - if((fzors.gt.0.).and.(fzors.lt.99999)) czors=exp(-deltf/fzors) + czors = 0. !... roughness length over sea + if (fzors >= 99999.) czors = 1. + if (fzors > 0. .and. fzors < 99999) czors = exp(-deltf/fzors) ! -! cplrl=0. !... plant resistance over land -! if(fplrl.ge.99999.) cplrl=1. -! if((fplrl.gt.0.).and.(fplrl.lt.99999)) cplrl=exp(-deltf/fplrl) +! cplrl = 0. !... plant resistance over land +! if (fplrl >= 99999.) cplrl = 1. +! if (fplrl > 0. .and. fplrl < 99999) cplrl=exp(-deltf/fplrl) ! -! cplrs=0. !... plant resistance over sea -! if(fplrs.ge.99999.) cplrs=1. -! if((fplrs.gt.0.).and.(fplrs.lt.99999)) cplrs=exp(-deltf/fplrs) +! cplrs = 0. !... plant resistance over sea +! if (fplrs >= 99999.) cplrs = 1. +! if (fplrs > 0. .and. fplrs < 99999) cplrs=exp(-deltf/fplrs) ! do k=1,lsoil - cstcl(k)=0. !... soilt over land - if(fstcl(k).ge.99999.) cstcl(k)=1. - if((fstcl(k).gt.0.).and.(fstcl(k).lt.99999)) - & cstcl(k)=exp(-deltf/fstcl(k)) - cstcs(k)=0. !... soilt over sea - if(fstcs(k).ge.99999.) cstcs(k)=1. - if((fstcs(k).gt.0.).and.(fstcs(k).lt.99999)) - & cstcs(k)=exp(-deltf/fstcs(k)) + cstcl(k) = 0. !... soilt over land + if (fstcl(k) >= 99999.) cstcl(k) = 1. + if (fstcl(k) > 0. .and. fstcl(k) < 99999) & + & cstcl(k) = exp(-deltf/fstcl(k)) + cstcs(k) = 0. !... soilt over sea + if (fstcs(k) >= 99999.) cstcs(k) = 1. + if (fstcs(k) > 0. .and. fstcs(k) < 99999) & + & cstcs(k) = exp(-deltf/fstcs(k)) enddo ! - cvegl=0. !... vegetation fraction over land - if(fvegl.ge.99999.) cvegl=1. - if((fvegl.gt.0.).and.(fvegl.lt.99999)) cvegl=exp(-deltf/fvegl) + cvegl = 0. !... vegetation fraction over land + if (fvegl >= 99999.) cvegl = 1. + if (fvegl > 0. .and. fvegl < 99999) cvegl = exp(-deltf/fvegl) ! - cvegs=0. !... vegetation fraction over sea - if(fvegs.ge.99999.) cvegs=1. - if((fvegs.gt.0.).and.(fvegs.lt.99999)) cvegs=exp(-deltf/fvegs) + cvegs = 0. !... vegetation fraction over sea + if (fvegs >= 99999.) cvegs = 1. + if (fvegs > 0. .and. fvegs < 99999) cvegs = exp(-deltf/fvegs) ! - cvetl=0. !... vegetation type over land - if(fvetl.ge.99999.) cvetl=1. - if((fvetl.gt.0.).and.(fvetl.lt.99999)) cvetl=exp(-deltf/fvetl) + cvetl = 0. !... vegetation type over land + if (fvetl >= 99999.) cvetl = 1. + if (fvetl > 0. .and. fvetl < 99999) cvetl = exp(-deltf/fvetl) ! - cvets=0. !... vegetation type over sea - if(fvets.ge.99999.) cvets=1. - if((fvets.gt.0.).and.(fvets.lt.99999)) cvets=exp(-deltf/fvets) + cvets = 0. !... vegetation type over sea + if (fvets >= 99999.) cvets = 1. + if (fvets > 0. .and. fvets < 99999) cvets = exp(-deltf/fvets) ! - csotl=0. !... soil type over land - if(fsotl.ge.99999.) csotl=1. - if((fsotl.gt.0.).and.(fsotl.lt.99999)) csotl=exp(-deltf/fsotl) + csotl = 0. !... soil type over land + if (fsotl >= 99999.) csotl = 1. + if (fsotl > 0. .and. fsotl < 99999) csotl = exp(-deltf/fsotl) ! - csots=0. !... soil type over sea - if(fsots.ge.99999.) csots=1. - if((fsots.gt.0.).and.(fsots.lt.99999)) csots=exp(-deltf/fsots) + csots = 0. !... soil type over sea + if (fsots >= 99999.) csots = 1. + if (fsots > 0. .and. fsots < 99999) csots = exp(-deltf/fsots) !cwu [+16l]--------------------------------------------------------------- ! - csihl=0. !... sea ice thickness over land - if(fsihl.ge.99999.) csihl=1. - if((fsihl.gt.0.).and.(fsihl.lt.99999)) csihl=exp(-deltf/fsihl) + csihl = 0. !... sea ice thickness over land + if (fsihl >= 99999.) csihl = 1. + if (fsihl > 0. .and. fsihl < 99999) csihl = exp(-deltf/fsihl) ! - csihs=0. !... sea ice thickness over sea - if(fsihs.ge.99999.) csihs=1. - if((fsihs.gt.0.).and.(fsihs.lt.99999)) csihs=exp(-deltf/fsihs) + csihs = 0. !... sea ice thickness over sea + if (fsihs >= 99999.) csihs = 1. + if (fsihs > 0. .and. fsihs < 99999) csihs = exp(-deltf/fsihs) ! - csicl=0. !... sea ice concentration over land - if(fsicl.ge.99999.) csicl=1. - if((fsicl.gt.0.).and.(fsicl.lt.99999)) csicl=exp(-deltf/fsicl) + csicl = 0. !... sea ice concentration over land + if (fsicl >= 99999.) csicl = 1. + if (fsicl > 0. .and. fsicl < 99999) csicl = exp(-deltf/fsicl) ! - csics=0. !... sea ice concentration over sea - if(fsics.ge.99999.) csics=1. - if((fsics.gt.0.).and.(fsics.lt.99999)) csics=exp(-deltf/fsics) + csics = 0. !... sea ice concentration over sea + if (fsics >= 99999.) csics = 1. + if (fsics > 0. .and. fsics < 99999) csics = exp(-deltf/fsics) !clu [+32l]--------------------------------------------------------------- ! - cvmnl=0. !... min veg cover over land - if(fvmnl.ge.99999.) cvmnl=1. - if((fvmnl.gt.0.).and.(fvmnl.lt.99999)) cvmnl=exp(-deltf/fvmnl) + cvmnl = 0. !... min veg cover over land + if (fvmnl >= 99999.) cvmnl = 1. + if (fvmnl > 0. .and. fvmnl < 99999) cvmnl = exp(-deltf/fvmnl) ! - cvmns=0. !... min veg cover over sea - if(fvmns.ge.99999.) cvmns=1. - if((fvmns.gt.0.).and.(fvmns.lt.99999)) cvmns=exp(-deltf/fvmns) + cvmns = 0. !... min veg cover over sea + if (fvmns >= 99999.) cvmns = 1. + if (fvmns > 0. .and. fvmns < 99999) cvmns = exp(-deltf/fvmns) ! - cvmxl=0. !... max veg cover over land - if(fvmxl.ge.99999.) cvmxl=1. - if((fvmxl.gt.0.).and.(fvmxl.lt.99999)) cvmxl=exp(-deltf/fvmxl) + cvmxl = 0. !... max veg cover over land + if (fvmxl >= 99999.) cvmxl = 1. + if (fvmxl > 0. .and. fvmxl < 99999) cvmxl = exp(-deltf/fvmxl) ! - cvmxs=0. !... max veg cover over sea - if(fvmxs.ge.99999.) cvmxs=1. - if((fvmxs.gt.0.).and.(fvmxs.lt.99999)) cvmxs=exp(-deltf/fvmxs) + cvmxs = 0. !... max veg cover over sea + if (fvmxs >= 99999.) cvmxs = 1. + if (fvmxs > 0. .and. fvmxs < 99999) cvmxs = exp(-deltf/fvmxs) ! - cslpl=0. !... slope type over land - if(fslpl.ge.99999.) cslpl=1. - if((fslpl.gt.0.).and.(fslpl.lt.99999)) cslpl=exp(-deltf/fslpl) + cslpl = 0. !... slope type over land + if (fslpl >= 99999.) cslpl = 1. + if (fslpl > 0. .and. fslpl < 99999) cslpl = exp(-deltf/fslpl) ! - cslps=0. !... slope type over sea - if(fslps.ge.99999.) cslps=1. - if((fslps.gt.0.).and.(fslps.lt.99999)) cslps=exp(-deltf/fslps) + cslps = 0. !... slope type over sea + if (fslps >= 99999.) cslps = 1. + if (fslps > 0. .and. fslps < 99999) cslps = exp(-deltf/fslps) ! - cabsl=0. !... snow albedo over land - if(fabsl.ge.99999.) cabsl=1. - if((fabsl.gt.0.).and.(fabsl.lt.99999)) cabsl=exp(-deltf/fabsl) + cabsl = 0. !... snow albedo over land + if (fabsl >= 99999.) cabsl = 1. + if (fabsl > 0. .and. fabsl < 99999) cabsl = exp(-deltf/fabsl) ! - cabss=0. !... snow albedo over sea - if(fabss.ge.99999.) cabss=1. - if((fabss.gt.0.).and.(fabss.lt.99999)) cabss=exp(-deltf/fabss) + cabss = 0. !... snow albedo over sea + if (fabss >= 99999.) cabss = 1. + if (fabss > 0. .and. fabss < 99999) cabss = exp(-deltf/fabss) !clu ---------------------------------------------------------------------- ! !> - Call hmskrd() to read a high resolution mask field for use in grib interpolation ! - call hmskrd(lugb,imsk,jmsk,fnmskh, + call hmskrd(lugb,imsk,jmsk,fnmskh, & & kpdmsk,slmskh,gausm,blnmsk,bltmsk,me) ! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo) ! - if (me .eq. 0) then + if (me == 0) then write(6,*) ' ' write(6,*) ' lugb=',lugb,' len=',len, ' lsoil=',lsoil - write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh - &, ' sig1t(1)=',sig1t(1) + write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh & + &, ' sig1t(1)=',sig1t(1) & &, ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk write(6,*) ' ' endif @@ -1127,32 +1134,35 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & !* ice concentration or ice mask (only ice mask used in the model now) ! ice concentration and ice mask (both are used in the model now) ! - if(fnaisc(1:8).ne.' ') then + if(fnaisc(1:8) /= ' ') then !cwu [+5l/-1l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*aisclm(i) sicclm(i) = aisclm(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicclm(i).ne.1.) then + if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicclm(i) /= 1.0) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo crit=aislim !* crit=0.5 - call rof01(aisclm,len,'ge',crit) - elseif(fnacnc(1:8).ne.' ') then +! call rof01(aisclm,len,'ge',crit) + call rof01_len(aisclm, len, 'ge', lake, min_lakeice, min_seaice) + + elseif(fnacnc(1:8) /= ' ') then !cwu [+4l] update sihclm, sicclm do i=1,len sihclm(i) = 3.0*acnclm(i) sicclm(i) = acnclm(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicclm(i).ne.1.) then + if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicclm(i).ne.1.) then sicclm(i) = sicimx sihfcs(i) = glacir_hice endif enddo - call rof01(acnclm,len,'ge',aislim) +! call rof01(acnclm,len,'ge',aislim) + call rof01_len(acnclm, len, 'ge', lake, min_lakeice, min_seaice) do i=1,len aisclm(i) = acnclm(i) enddo @@ -1166,6 +1176,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! set ocean/land/sea-ice mask ! call setlsi(slmask,aisclm,len,aicice,sliclm) + ! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' ! *,sliclm(iprnt),' slmask=',slmask(iprnt) ! @@ -1183,7 +1194,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! quality control of snow depth (note that snow should be corrected first ! because it influences tsf ! - kqcm=1 + kqcm = 1 call qcmxmn('snow ',snoclm,sliclm,snoclm,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, & snojmx,snojmn,snosmx,snosmn,epssno, @@ -1207,7 +1218,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! quality control ! do i=1,len - icefl2(i) = sicclm(i) .gt. 0.99999 + icefl2(i) = sicclm(i) > 0.99999 enddo kqcm=1 call qcmxmn('tsfc ',tsfclm,sliclm,snoclm,icefl2, @@ -1267,7 +1278,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -1285,10 +1295,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, & sihjmx,sihjmn,sihsmx,sihsmn,epssih, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) +! call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1, +! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, +! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, +! & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+16l] --------------------------------------------------------------- call qcmxmn('vmnc ',vmnclm,sliclm,snoclm,icefl1, & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, @@ -1311,7 +1321,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! monitoring prints ! if (monclm) then - if (me .eq. 0) then + if (me == 0) then print *,' ' print *,'monitor of time and space interpolated climatology' print *,' ' @@ -1354,7 +1364,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! ! - if (me .eq. 0) then + if (me == 0) then write(6,*) '==============' write(6,*) ' analysis' write(6,*) '==============' @@ -1378,9 +1388,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! reverse scaling to match with grib analysis input ! - zsca=0.01 + zsca = 0.01 call scale(zoranl,len, zsca) - zsca=100. + zsca = 100. call scale(albanl,len,zsca) call scale(albanl(1,2),len,zsca) call scale(albanl(1,3),len,zsca) @@ -1388,12 +1398,12 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call scale(alfanl,len,zsca) call scale(alfanl(1,2),len,zsca) !clu [+4l] reverse scale for vmn, vmx, abs - zsca=100. + zsca = 100. call scale(vmnanl,len,zsca) call scale(vmxanl,len,zsca) call scale(absanl,len,zsca) ! - percrit=critp2 + percrit = critp2 ! ! read analysis fields ! @@ -1421,9 +1431,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! scale zor and alb to match forecast model units ! - zsca=100. + zsca = 100. call scale(zoranl,len, zsca) - zsca=0.01 + zsca = 0.01 call scale(albanl,len,zsca) call scale(albanl(1,2),len,zsca) call scale(albanl(1,3),len,zsca) @@ -1431,7 +1441,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call scale(alfanl,len,zsca) call scale(alfanl(1,2),len,zsca) !clu [+4] scale vmn, vmx, abs from percent to fraction - zsca=0.01 + zsca = 0.01 call scale(vmnanl,len,zsca) call scale(vmxanl,len,zsca) call scale(absanl,len,zsca) @@ -1453,42 +1463,48 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! ice concentration or ice mask (only ice mask used in the model now) ! - if(fnaisa(1:8).ne.' ') then + if(fnaisa(1:8) /= ' ') then !cwu [+5l/-1l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*aisanl(i) sicanl(i) = aisanl(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicanl(i).ne.1.) then + if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice endif enddo - crit=aislim +! crit=aislim !* crit=0.5 - call rof01(aisanl,len,'ge',crit) - elseif(fnacna(1:8).ne.' ') then +! call rof01(aisanl,len,'ge',crit) + call rof01_len(aisanl, len, 'ge', lake, min_lakeice, min_seaice) + elseif(fnacna(1:8) /= ' ') then !cwu [+17l] update sihanl, sicanl do i=1,len sihanl(i) = 3.0*acnanl(i) sicanl(i) = acnanl(i) - if(slmask(i).eq.0..and.glacir(i).eq.1..and. - & sicanl(i).ne.1.) then + if(nint(slmask(i)) == 0 .and. nint(glacir(i)) == 1 & + & .and. sicanl(i) /= 1.) then sicanl(i) = sicimx sihfcs(i) = glacir_hice endif enddo - crit=aislim +! crit=aislim do i=1,len - if((slianl(i).eq.0.).and.(sicanl(i).ge.crit)) then - slianl(i)=2. + if (lake(i)) then + crit = min_lakeice + else + crit = min_seaice + endif + if (nint(slianl(i)) == 0 .and. sicanl(i) >= crit) then + slianl(i) = 2. ! print *,'cycle - new ice form: fice=',sicanl(i) - else if((slianl(i).ge.2.).and.(sicanl(i).lt.crit)) then - slianl(i)=0. + elseif (nint(slianl(i)) >= 2 .and. sicanl(i) < crit) then + slianl(i) = 0. ! print *,'cycle - ice free: fice=',sicanl(i) - else if((slianl(i).eq.1.).and.(sicanl(i).ge.sicimn)) then + elseif (nint(slianl(i)) == 1 .and. sicanl(i) > crit) then ! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) - sicanl(i)=0. + sicanl(i) = 0. endif enddo ! znnt=10. @@ -1499,9 +1515,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! & .and. aisfcs(i) .ge. 0.75) acnanl(i) = aislim ! enddo ! if(lprnt) print *,' acnanl=',acnanl(iprnt) - call rof01(acnanl,len,'ge',aislim) +! call rof01(acnanl,len,'ge',aislim) + call rof01_len(acnanl, len, 'ge', lake, min_lakeice, min_seaice) do i=1,len - aisanl(i)=acnanl(i) + aisanl(i) = acnanl(i) enddo endif ! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' @@ -1534,10 +1551,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, & sihjmx,sihjmn,sihsmx,sihsmn,epssih, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) +! call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1, +! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, +! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, +! & rla,rlo,len,kqcm,percrit,lgchek,me) ! ! set albedo over ocean to albomx ! @@ -1546,13 +1563,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! quality control of snow and sea-ice ! process snow depth or snow cover ! - if(fnsnoa(1:8).ne.' ') then + if (fnsnoa(1:8) /= ' ') then call setzro(snoanl,epssno,len) call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) if (.not.landice) then call snodpth2(glacir,snosmx,snoanl, len, me) endif - kqcm=1 + kqcm = 1 call snosfc(snoanl,tsfanl,tsfsmx,len,me) call qcmxmn('snoa ',snoanl,slianl,snoanl,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, @@ -1564,7 +1581,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, & rla,rlo,len,kqcm,percrit,lgchek,me) else - crit=0.5 + crit = 0.5 call rof01(scvanl,len,'ge',crit) call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1, @@ -1582,7 +1599,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! do i=1,len - icefl2(i) = sicanl(i) .gt. 0.99999 + icefl2(i) = sicanl(i) > 0.99999 enddo call qcmxmn('tsfa ',tsfanl,slianl,snoanl,icefl2, & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, @@ -1594,7 +1611,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & albjmx,albjmn,albsmx,albsmn,epsalb, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) then + if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ' ) then call qcmxmn('weta ',wetanl,slianl,snoanl,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, & wetjmx,wetjmn,wetsmx,wetsmn,epswet, @@ -1617,7 +1634,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! get soil temp and moisture ! - if(fnsmca(1:8).eq.' ' .and. fnsmcc(1:8).eq.' ') then + if(fnsmca(1:8) == ' ' .and. fnsmcc(1:8) == ' ') then call getsmc(wetanl,len,lsoil,smcanl,me) endif !-- soil moisture @@ -1671,7 +1688,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! monitoring prints ! if (monanl) then - if (me .eq. 0) then + if (me == 0) then print *,' ' print *,'monitor of time and space interpolated analysis' print *,' ' @@ -1713,20 +1730,20 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! read in forecast fields if needed ! - if (me .eq. 0) then + if (me == 0) then write(6,*) '==============' write(6,*) ' fcst guess' write(6,*) '==============' endif ! - percrit=critp2 + percrit = critp2 ! if(deads) then ! ! fill in guess array with analysis if dead start. ! percrit=critp3 - if (me .eq. 0) write(6,*) 'this run is dead start run' + if (me == 0) write(6,*) 'this run is dead start run' call filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & tg3fcs,cvfcs ,cvbfcs,cvtfcs, & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, @@ -1744,13 +1761,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & !clu [+1l] add ()anl for vmn, vmx, slp, abs & vmnanl,vmxanl,slpanl,absanl, & len,lsoil) - if(sig1t(1).ne.0.) then + if (sig1t(1) /= 0.) then call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, & tsfimx) do i=1,len - icefl2(i) = sicfcs(i) .gt. 0.99999 + icefl2(i) = sicfcs(i) > 0.99999 enddo - kqcm=1 + kqcm = 1 call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, @@ -1765,7 +1782,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & rla,rlo,len,kqcm,percrit,lgchek,me) endif else - percrit=critp2 + percrit = critp2 ! ! make reverse angulation correction to tsf ! make reverse orography correction to tg3 @@ -1793,23 +1810,23 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! compute soil moisture liquid-to-total ratio over land ! do j=1, lsoil - do i=1, len - if(smcfcs(i,j) .ne. 0.) then - swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) - else - swratio(i,j) = -999. - endif - enddo + do i=1, len + if(smcfcs(i,j) /= 0.) then + swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) + else + swratio(i,j) = -999. + endif + enddo enddo !clu ----------------------------------------------------------------------- ! - if(lqcbgs .and. irtacn .eq. 0) then + if (lqcbgs .and. irtacn == 0) then call qcsli(slianl,slifcs,len,me) call albocn(albfcs,slmask,albomx,len) do i=1,len icefl2(i) = sicfcs(i) .gt. 0.99999 enddo - kqcm=1 + kqcm = 1 call qcmxmn('snof ',snofcs,slifcs,snofcs,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, & snojmx,snojmn,snosmx,snosmn,epssno, @@ -1824,7 +1841,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & albjmx,albjmn,albsmx,albsmn,epsalb, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) + if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ' ) & then call qcmxmn('wetf ',wetfcs,slifcs,snofcs,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, @@ -1850,10 +1867,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, & sihjmx,sihjmn,sihsmx,sihsmn,epssih, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) +! call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1, +! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, +! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, +! & rla,rlo,len,kqcm,percrit,lgchek,me) !-- soil moisture forecast do k=1,lsoil call qcmxmn(message('smcfcw',k),smcfcs(1,k),slifcs, @@ -1905,7 +1922,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & endif ! if (monfcs) then - if (me .eq. 0) then + if (me == 0) then print *,' ' print *,'monitor of guess' print *,' ' @@ -1965,14 +1982,14 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! blend climatology and predicted fields ! - if(me .eq. 0) then + if(me == 0) then write(6,*) '==============' write(6,*) ' merging' write(6,*) '==============' endif ! if(lprnt) print *,' tsffcs=',tsffcs(iprnt) ! - percrit=critp3 + percrit = critp3 ! ! merge analysis and forecast. note tg3, ais are not merged ! @@ -2026,9 +2043,9 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & call snosfc(snoanl,tsfanl,tsfsmx,len,me) ! do i=1,len - icefl2(i) = sicanl(i) .gt. 0.99999 + icefl2(i) = sicanl(i) > 0.99999 enddo - kqcm=0 + kqcm = 0 call qcmxmn('snowm ',snoanl,slianl,snoanl,icefl1, & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, & snojmx,snojmn,snosmx,snosmn,epssno, @@ -2043,8 +2060,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & albjmx,albjmn,albsmx,albsmn,epsalb, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) - & then + if(fnwetc(1:8) /= ' ' .or. fnweta(1:8) /= ' ') then call qcmxmn('wetm ',wetanl,slianl,snoanl,icefl1, & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, & wetjmx,wetjmn,wetsmx,wetsmn,epswet, @@ -2073,7 +2089,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) enddo - kqcm=1 + kqcm = 1 call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -2091,10 +2107,10 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, & sihjmx,sihjmn,sihsmx,sihsmn,epssih, & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1, - & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, - & sicjmx,sicjmn,sicsmx,sicsmn,epssic, - & rla,rlo,len,kqcm,percrit,lgchek,me) +! call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1, +! & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, +! & sicjmx,sicjmn,sicsmx,sicsmn,epssic, +! & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+16l] add vmn, vmx, slp, abs call qcmxmn('vmnm ',vmnanl,slianl,snoanl,icefl1, & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, @@ -2114,7 +2130,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & & rla,rlo,len,kqcm,percrit,lgchek,me) ! - if(me .eq. 0) then + if(me == 0) then write(6,*) '==============' write(6,*) 'final results' write(6,*) '==============' @@ -2144,7 +2160,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! check the final merged product ! if (monmer) then - if(me .eq. 0) then + if(me == 0) then print *,' ' print *,'monitor of updated surface fields' print *,' (includes angulation correction)' @@ -2221,7 +2237,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! monitoring prints ! - if(me .eq. 0) then + if(me == 0) then print *,' ' print *,'monitor of difference' print *,' (includes angulation correction)' @@ -2288,7 +2304,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & do j = 1,lsoil do i = 1,len smcfcs(i,j) = smcanl(i,j) - if (slifcs(i) .gt. 0.0) then + if (slifcs(i) > 0.0_kind_io8) then stcfcs(i,j) = stcanl(i,j) else stcfcs(i,j) = tsffcs(i) @@ -2307,62 +2323,83 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & enddo !cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points - crit=aislim +! crit = aislim do i=1,len sihfcs(i) = sihanl(i) sitfcs(i) = tsffcs(i) - if (slifcs(i).ge.2.) then - if (sicfcs(i).gt.crit) then + if (lake(i)) then + crit = min_lakeice + else + crit = min_seaice + endif + if (slifcs(i) >= 1.99_kind_io8) then + if (sicfcs(i) > crit) then + tem1 = 1.0_kind_io8 / sicfcs(i) tsffcs(i) = (sicanl(i)*tsffcs(i) - & + (sicfcs(i)-sicanl(i))*tgice)/sicfcs(i) - sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) / sicfcs(i) + & + (sicfcs(i)-sicanl(i))*tgice) * tem1 + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) * tem1 + sicfcs(i) = sicanl(i) else tsffcs(i) = tsfanl(i) ! tsffcs(i) = tgice - sihfcs(i) = sihnew +! sihfcs(i) = sihnew + sihfcs(i) = 0.0_kind_io8 + sicfcs(i) = 0.0_kind_io8 + slifcs(i) = 0.0_kind_io8 endif endif - sicfcs(i) = sicanl(i) - enddo - do i=1,len - if (slifcs(i).lt.1.5) then - sihfcs(i) = 0. - sicfcs(i) = 0. - sitfcs(i) = tsffcs(i) - else if ((slifcs(i).ge.1.5).and.(sicfcs(i).lt.crit)) then - print *,'warning: check, slifcs and sicfcs', - & slifcs(i),sicfcs(i) + if (slifcs(i) > 1.5_kind_io8 .and. sicfcs(i) < crit) then + print *,'warning: check, slifcs and sicfcs', & + & slifcs(i),sicfcs(i) endif enddo +! do i=1,len +! if (slifcs(i) < 1.5_kind_io8) then +! sihfcs(i) = 0.0_kind_io8 +! sicfcs(i) = 0.0_kind_io8 +! sitfcs(i) = tsffcs(i) +! else +! if (lake(i)) then +! crit = min_lakeice +! else +! crit = min_seaice +! endif +! if (sicfcs(i) < crit) then +! print *,'warning: check, slifcs and sicfcs', & +! & slifcs(i),sicfcs(i) +! endif +! endif +! enddo + ! ! ensure the consistency between slc and smc ! do k=1, lsoil fixratio(k) = .false. - if (fsmcl(k).lt.99999.) fixratio(k) = .true. + if (fsmcl(k) < 99999.) fixratio(k) = .true. enddo - if(me .eq. 0) then - print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) + if(me == 0) then + print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) endif do k=1, lsoil if(fixratio(k)) then do i = 1, len - if(swratio(i,k) .eq. -999.) then + if(swratio(i,k) == -999.) then slcfcs(i,k) = smcfcs(i,k) else slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) endif - if (slifcs(i) .ne. 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. + if (slifcs(i) /= 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. enddo endif enddo ! set liquid soil moisture to a flag value of 1.0 if (landice) then do i = 1, len - if (slifcs(i) .eq. 1.0 .and. + if (slifcs(i) == 1.0 .and. & nint(vetfcs(i)) == veg_type_landice) then do k=1, lsoil slcfcs(i,k) = 1.0 @@ -2373,13 +2410,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! ! ensure the consistency between snwdph and sheleg ! - if(fsnol .lt. 99999.) then - if(me .eq. 0) then - print *,'dbgx -- scale snwdph from sheleg' - endif - do i = 1, len - if(slifcs(i).eq.1.) swdfcs(i) = 10.* snofcs(i) - enddo + if(fsnol < 99999.) then + if(me == 0) then + print *,'dbgx -- scale snwdph from sheleg' + endif + do i = 1, len + if(slifcs(i) == 1.) swdfcs(i) = 10.* snofcs(i) + enddo endif ! sea ice model only uses the liquid equivalent depth. @@ -2387,16 +2424,16 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! use the same 3:1 ratio used by ice model. do i = 1, len - if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i) + if (slifcs(i) /= 1) swdfcs(i) = 3.*snofcs(i) enddo do i = 1, len - if(slifcs(i).eq.1.) then - if(snofcs(i).ne.0. .and. swdfcs(i).eq.0.) then - print *,'dbgx --scale snwdph from sheleg', - + i, swdfcs(i), snofcs(i) - swdfcs(i) = 10.* snofcs(i) - endif + if(slifcs(i) == 1.) then + if(snofcs(i) /= 0. .and. swdfcs(i) == 0.) then + print *,'dbgx --scale snwdph from sheleg', & + & i, swdfcs(i), snofcs(i) + swdfcs(i) = 10.* snofcs(i) + endif endif enddo ! landice mods - impose same minimum snow depth at @@ -2406,7 +2443,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & ! after adjustment to terrain. if (landice) then do i = 1, len - if (slifcs(i) .eq. 1.0 .and. + if (slifcs(i) == 1.0 .and. & & nint(vetfcs(i)) == veg_type_landice) then snofcs(i) = max(snofcs(i),100.0) ! in mm swdfcs(i) = max(swdfcs(i),1000.0) ! in mm @@ -2715,8 +2752,7 @@ subroutine fixrdg(lugb,idim,jdim,fngrib, & !>\ingroup mod_sfcsub !! This subroutine get area of the grib record. - subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr & - &, me) + subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) use machine , only : kind_io8,kind_io4 implicit none integer j,me,kgds11 @@ -2935,6 +2971,7 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& & gauout,len,lmask,rslmsk,slmask & &, outlat, outlon,me) use machine , only : kind_io8,kind_io4 + use sfccyc_module , only : num_threads implicit none real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, & & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, & @@ -2958,15 +2995,12 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp,& logical lmask ! logical first - integer num_threads data first /.true./ - save num_threads, first + save first ! integer len_thread_m, len_thread, i1_t, i2_t - integer num_parthds ! if (first) then - num_threads = num_parthds() first = .false. if (.not. allocated(imxnx)) allocate (imxnx(num_threads)) endif @@ -3607,7 +3641,7 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & & kprvet,kpdsot,kpdalf, & & kpdvmn,kpdvmx,kpdslp,kpdabs, & !clu [+1l] add kpd() for vmn, vmx, slp, abs - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & !cggg snow mods & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & & irtvet,irtsot,irtalf & &, irtvmn,irtvmx,irtslp,irtabs & !clu [+1l] add irt() for vmn, vmx, slp, abs @@ -3698,36 +3732,36 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & endif else do i=1,len - tsfan0(i)=-999.9 + tsfan0(i) = -999.9 enddo endif ! ! albedo ! - irtalb=0 + irtalb = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 4 call fixrda(lugb,fnalba,kpdalb(kk),slmask, & iy,im,id,ih,fh,albanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - irtalb=iret - if(iret.eq.1) then + irtalb = iret + if(iret == 1) then write(6,*) 'albedo analysis read error' call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then + elseif(iret == -1) then + if (me == 0) then print *,'old albedo analysis provided, indicating proper', & ' file name is given. no error suspected.' write(6,*) 'forecast guess will be used' endif else - if (me .eq. 0 .and. kk .eq. 4) + if (me == 0 .and. kk == 4) & print *,'albedo analysis provided.' endif enddo else - if (me .eq. 0) then + if (me == 0) then ! print *,'************************************************' print *,'no albedo analysis available. climatology used' endif @@ -3735,30 +3769,30 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & ! ! vegetation fraction for albedo ! - irtalf=0 + irtalf = 0 if(fnalba(1:8).ne.' ') then do kk = 1, 2 call fixrda(lugb,fnalba,kpdalf(kk),slmask, & iy,im,id,ih,fh,alfanl(1,kk),len,iret &, imsk, jmsk, slmskh, gaus,blno, blto &, outlat, outlon, me) - irtalf=iret - if(iret.eq.1) then + irtalf = iret + if(iret == 1) then write(6,*) 'albedo analysis read error' call abort - elseif(iret.eq.-1) then - if (me .eq. 0) then + elseif(iret == -1) then + if (me == 0) then print *,'old albedo analysis provided, indicating proper', & ' file name is given. no error suspected.' write(6,*) 'forecast guess will be used' endif else - if (me .eq. 0 .and. kk .eq. 4) + if (me == 0 .and. kk == 4) & print *,'albedo analysis provided.' endif enddo else - if (me .eq. 0) then + if (me == 0) then ! print *,'************************************************' print *,'no vegfalbedo analysis available. climatology used' endif @@ -4364,43 +4398,43 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) end !>\ingroup mod_sfcsub - subroutine rof01(aisfld,len,op,crit) + subroutine rof01(aisfld, len, op, crit) use machine , only : kind_io8,kind_io4 implicit none integer i,len real (kind=kind_io8) aisfld(len),crit character*2 op ! - if(op.eq.'ge') then + if(op == 'ge') then do i=1,len - if(aisfld(i).ge.crit) then - aisfld(i)=1. + if(aisfld(i) >= crit) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo - elseif(op.eq.'gt') then + elseif(op == 'gt') then do i=1,len - if(aisfld(i).gt.crit) then - aisfld(i)=1. + if(aisfld(i) > crit) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo - elseif(op.eq.'le') then + elseif(op == 'le') then do i=1,len - if(aisfld(i).le.crit) then - aisfld(i)=1. + if(aisfld(i) <= crit) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo - elseif(op.eq.'lt') then + elseif(op == 'lt') then do i=1,len - if(aisfld(i).lt.crit) then - aisfld(i)=1. + if(aisfld(i) < crit) then + aisfld(i) = 1. else - aisfld(i)=0. + aisfld(i) = 0. endif enddo else @@ -4411,6 +4445,61 @@ subroutine rof01(aisfld,len,op,crit) return end +!>\ingroup mod_sfcsub + subroutine rof01_len(aisfld, len, op, lake, critl, crits) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + logical :: lake(len) + real (kind=kind_io8) aisfld(len), critl, crits, crit(len) + character*2 op +! + do i=1,len + if (lake(i)) then + crit(i) = critl + else + crit(i) = crits + endif + enddo + if(op == 'ge') then + do i=1,len + if(aisfld(i) >= crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'gt') then + do i=1,len + if(aisfld(i) > crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'le') then + do i=1,len + if(aisfld(i) <= crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + elseif(op == 'lt') then + do i=1,len + if(aisfld(i) < crit(i)) then + aisfld(i) = 1. + else + aisfld(i) = 0. + endif + enddo + else + write(6,*) ' illegal operator in rof01. op=',op + call abort + endif +! + return + end !>\ingroup mod_sfcsub subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) ! @@ -4511,7 +4600,8 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & & irtvmn,irtvmx,irtslp,irtabs, & & irtvet,irtsot,irtalf, landice, me) use machine , only : kind_io8,kind_io4 - use sfccyc_module, only : veg_type_landice, soil_type_landice + use sfccyc_module, only : veg_type_landice, soil_type_landice, & + & num_threads implicit none integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & @@ -4563,15 +4653,12 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), & & qstcl(lsoil), qstcs(lsoil) logical first - integer num_threads data first /.true./ - save num_threads, first + save first ! integer len_thread_m, i1_t, i2_t, it - integer num_parthds ! if (first) then - num_threads = num_parthds() first = .false. endif ! @@ -5098,7 +5185,7 @@ subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, & ! ! check sea-ice cover mask against land-sea mask ! - if (me .eq. 0) write(6,*) 'qc of sea ice' + if (me == 0) write(6,*) 'qc of sea ice' kount = 0 kount1 = 0 do i=1,len @@ -5198,9 +5285,8 @@ subroutine setlsi(slmask,aisfld,len,aicice,slifld) ! do i=1,len slifld(i) = slmask(i) -! if(aisfld(i).eq.aicice) slifld(i) = 2.0 - if(aisfld(i).eq.aicice .and. slmask(i) .eq. 0.0) - & slifld(i) = 2.0 + if(aisfld(i) == aicice .and. slmask(i) == 0.0) & + & slifld(i) = 2.0 enddo return end @@ -5224,60 +5310,56 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & & rla,rlo,len,mode,percrit,lgchek,me) ! use machine , only : kind_io8,kind_io4 + use sfccyc_module , only : num_threads implicit none - real (kind=kind_io8) permax,per,fldimx,fldimn,fldjmx,fldomn, & - & fldlmx,fldlmn,fldomx,fldjmn,percrit, & - & fldsmx,fldsmn,epsfld - integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj, & - & ij,nprt,kmaxs,kmins,i,me,len,mode - parameter(mmprt=2) + integer, intent(in) :: len, mode, me + real (kind=kind_io8), intent(in) :: fldimx,fldimn,fldjmx,fldomn, & + & fldlmx,fldlmn,fldomx,fldjmn, & + & fldsmx,fldsmn,epsfld,percrit & + integer, parameter :: mmprt=2 ! character(len=*) ttl logical iceflg(len) - real (kind=kind_io8) fld(len),slimsk(len),sno(len), & - & rla(len), rlo(len) - integer iwk(len) + real (kind=kind_io8), dimension(len) :: fld, slimsk, sno, rla, rlo logical lgchek ! logical first - integer num_threads + real (kind=kind_io8) permax, per data first /.true./ - save num_threads, first + save first ! - integer len_thread_m, i1_t, i2_t, it - integer num_parthds + integer :: len_thread_m, i1_t, i2_t, it, & + & kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,kminj, & + & ij,nprt,kmaxs,kmins,i + integer :: islimsk(len), iwk(len) ! if (first) then - num_threads = num_parthds() first = .false. endif + do it=1,len + islimsk(it) = nint(slimsk(it)) + enddo ! ! check against land-sea mask and ice cover mask ! - if(me .eq. 0) then -! print *,' ' - print *,'performing qc of ',ttl,' mode=',mode, - & '(0=count only, 1=replace)' + if(me == 0) then + print *,'performing qc of ',ttl,' mode=',mode, + & '(0=count only, 1=replace)' endif ! len_thread_m = (len+num_threads-1) / num_threads - kmaxl = 0 - kminl = 0 - kmaxo = 0 - kmino = 0 - kmaxi = 0 - kmini = 0 - kmaxj = 0 - kminj = 0 - kmaxs = 0 - kmins = 0 + + kmaxl = 0 ; kminl = 0 ; kmaxo = 0 ; kmino = 0 + kmaxi = 0 ; kmini = 0 ; kmaxj = 0 ; kminj = 0 + kmaxs = 0 ; kmins = 0 + !$omp parallel do private(i1_t,i2_t,it,i) !$omp+private(nprt,ij,iwk) !$omp+reduction(+:kmaxs,kmins,kmaxl,kminl,kmaxo) !$omp+reduction(+:kmino,kmaxi,kmini,kmaxj,kminj) !$omp+shared(mode,epsfld) !$omp+shared(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn) -!$omp+shared(fld,slimsk,sno,rla,rlo) +!$omp+shared(fld,islimsk,sno,rla,rlo) do it=1,num_threads ! start of threaded loop i1_t = (it-1)*len_thread_m+1 i2_t = min(i1_t+len_thread_m-1,len) @@ -5286,24 +5368,24 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over bare land ! - if (fldlmn .ne. 999.0) then + if (fldlmn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).le.0..and. - & fld(i).lt.fldlmn-epsfld) then - kminl=kminl+1 + if(islimsk(i) == 1 .and. sno(i) <= 0.0 & + & .and. fld(i) < fldlmn-epsfld) then + kminl = kminl + 1 iwk(kminl) = i endif enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then + if(me == 0 .and. it == 1 .and. num_threads == 1) then nprt = min(mmprt,kminl) do i=1,nprt ij = iwk(i) print 8001,rla(ij),rlo(ij),fld(ij),fldlmn - 8001 format(' bare land min. check. lat=',f5.1, + 8001 format(' bare land min. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kminl fld(iwk(i)) = fldlmn enddo @@ -5312,11 +5394,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over bare land ! - if (fldlmx .ne. 999.0) then + if (fldlmx /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).le.0..and. - & fld(i).gt.fldlmx+epsfld) then - kmaxl=kmaxl+1 + if(islimsk(i) == 1 .and. sno(i) <= 0.0 & + & .and. fld(i) > fldlmx+epsfld) then + kmaxl = kmaxl + 1 iwk(kmaxl) = i endif enddo @@ -5325,11 +5407,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & do i=1,nprt ij = iwk(i) print 8002,rla(ij),rlo(ij),fld(ij),fldlmx - 8002 format(' bare land max. check. lat=',f5.1, + 8002 format(' bare land max. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxl fld(iwk(i)) = fldlmx enddo @@ -5338,11 +5420,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over snow covered land ! - if (fldsmn .ne. 999.0) then + if (fldsmn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).gt.0..and. - & fld(i).lt.fldsmn-epsfld) then - kmins=kmins+1 + if(islimsk(i) == 1 .and. sno(i) > 0.0 & + & .and. fld(i) < fldsmn-epsfld) then + kmins = kmins + 1 iwk(kmins) = i endif enddo @@ -5351,11 +5433,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & do i=1,nprt ij = iwk(i) print 8003,rla(ij),rlo(ij),fld(ij),fldsmn - 8003 format(' sno covrd land min. check. lat=',f5.1, + 8003 format(' sno covrd land min. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmins fld(iwk(i)) = fldsmn enddo @@ -5364,11 +5446,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over snow covered land ! - if (fldsmx .ne. 999.0) then + if (fldsmx /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.1..and.sno(i).gt.0..and. - & fld(i).gt.fldsmx+epsfld) then - kmaxs=kmaxs+1 + if(islimsk(i) == 1 .and. sno(i) > 0.0 & + & .and. fld(i) > fldsmx+epsfld) then + kmaxs = kmaxs + 1 iwk(kmaxs) = i endif enddo @@ -5377,11 +5459,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & do i=1,nprt ij = iwk(i) print 8004,rla(ij),rlo(ij),fld(ij),fldsmx - 8004 format(' snow land max. check. lat=',f5.1, + 8004 format(' snow land max. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxs fld(iwk(i)) = fldsmx enddo @@ -5390,11 +5472,10 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over open ocean ! - if (fldomn .ne. 999.0) then + if (fldomn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.0..and. - & fld(i).lt.fldomn-epsfld) then - kmino=kmino+1 + if(islimsk(i) == 0.0 .and. fld(i) < fldomn-epsfld) then + kmino = kmino + 1 iwk(kmino) = i endif enddo @@ -5403,11 +5484,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & do i=1,nprt ij = iwk(i) print 8005,rla(ij),rlo(ij),fld(ij),fldomn - 8005 format(' open ocean min. check. lat=',f5.1, + 8005 format(' open ocean min. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4,' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmino fld(iwk(i)) = fldomn enddo @@ -5416,24 +5497,23 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over open ocean ! - if (fldomx .ne. 999.0) then + if (fldomx /= 999.0) then do i=i1_t,i2_t - if(fldomx.ne.999..and.slimsk(i).eq.0..and. - & fld(i).gt.fldomx+epsfld) then - kmaxo=kmaxo+1 + if(islimsk(i) ==.0 .and. fld(i) > fldomx+epsfld) then + kmaxo = kmaxo+1 iwk(kmaxo) = i endif enddo - if(me == 0 . and. it == 1 .and. num_threads == 1) then + if(me == 0 .and. it == 1 .and. num_threads == 1) then nprt = min(mmprt,kmaxo) do i=1,nprt ij = iwk(i) print 8006,rla(ij),rlo(ij),fld(ij),fldomx - 8006 format(' open ocean max. check. lat=',f5.1, + 8006 format(' open ocean max. check. lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxo fld(iwk(i)) = fldomx enddo @@ -5442,11 +5522,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over sea ice without snow ! - if (fldimn .ne. 999.0) then + if (fldimn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).le.0..and. - & fld(i).lt.fldimn-epsfld) then - kmini=kmini+1 + if(islimsk(i) == 2 .and. sno(i) <= 0.0 & + & .and. fld(i) < fldimn-epsfld) then + kmini = kmini + 1 iwk(kmini) = i endif enddo @@ -5455,11 +5535,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & do i=1,nprt ij = iwk(i) print 8007,rla(ij),rlo(ij),fld(ij),fldimn - 8007 format(' seaice no snow min. check lat=',f5.1, + 8007 format(' seaice no snow min. check lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmini fld(iwk(i)) = fldimn enddo @@ -5468,12 +5548,12 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over sea ice without snow ! - if (fldimx .ne. 999.0) then + if (fldimx /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).le.0..and. - & fld(i).gt.fldimx+epsfld .and. iceflg(i)) then + if(islimsk(i) == 2 .and. sno(i) <= 0.0 .and. & + & fld(i) > fldimx+epsfld .and. iceflg(i)) then ! & fld(i).gt.fldimx+epsfld) then - kmaxi=kmaxi+1 + kmaxi = kmaxi + 1 iwk(kmaxi) = i endif enddo @@ -5482,11 +5562,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & do i=1,nprt ij = iwk(i) print 8008,rla(ij),rlo(ij),fld(ij),fldimx - 8008 format(' seaice no snow max. check lat=',f5.1, + 8008 format(' seaice no snow max. check lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxi fld(iwk(i)) = fldimx enddo @@ -5495,11 +5575,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! lower bound check over sea ice with snow ! - if (fldjmn .ne. 999.0) then + if (fldjmn /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).gt.0..and. - & fld(i).lt.fldjmn-epsfld) then - kminj=kminj+1 + if(islimsk(i) == 2 .and. sno(i) > 0.0 .and. & + & fld(i) < fldjmn-epsfld) then + kminj = kminj + 1 iwk(kminj) = i endif enddo @@ -5508,11 +5588,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & do i=1,nprt ij = iwk(i) print 8009,rla(ij),rlo(ij),fld(ij),fldjmn - 8009 format(' sea ice snow min. check lat=',f5.1, + 8009 format(' sea ice snow min. check lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kminj fld(iwk(i)) = fldjmn enddo @@ -5521,12 +5601,12 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! upper bound check over sea ice with snow ! - if (fldjmx .ne. 999.0) then + if (fldjmx /= 999.0) then do i=i1_t,i2_t - if(slimsk(i).eq.2..and.sno(i).gt.0..and. - & fld(i).gt.fldjmx+epsfld .and. iceflg(i)) then + if(islimsk(i) == 2 .and.sno(i) > 0.0 .and. & + & fld(i)> fldjmx+epsfld .and. iceflg(i)) then ! & fld(i).gt.fldjmx+epsfld) then - kmaxj=kmaxj+1 + kmaxj = kmaxj+1 iwk(kmaxj) = i endif enddo @@ -5535,11 +5615,11 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & do i=1,nprt ij = iwk(i) print 8010,rla(ij),rlo(ij),fld(ij),fldjmx - 8010 format(' seaice snow max check lat=',f5.1, + 8010 format(' seaice snow max check lat=',f5.1, & & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) enddo endif - if (mode .eq. 1) then + if (mode == 1) then do i=1,kmaxj fld(iwk(i)) = fldjmx enddo @@ -5550,78 +5630,77 @@ subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & ! ! print results ! - if(me .eq. 0) then -! write(6,*) 'summary of qc' - permax=0. - if(kminl.gt.0) then - per=float(kminl)/float(len)*100. + if(me == 0) then + permax = 0.0 + if(kminl > 0) then + per = float(kminl)/float(len)*100. print 9001,fldlmn,kminl,per - 9001 format(' bare land min check. modified to ',f8.1, + 9001 format(' bare land min check. modified to ',f8.1, & & ' at ',i5,' points ',f8.1,'percent') - if(per.gt.permax) permax=per + if(per > permax) permax = per endif - if(kmaxl.gt.0) then - per=float(kmaxl)/float(len)*100. + if(kmaxl > 0) then + per = float(kmaxl)/float(len)*100. print 9002,fldlmx,kmaxl,per - 9002 format(' bare land max check. modified to ',f8.1, + 9002 format(' bare land max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmino.gt.0) then - per=float(kmino)/float(len)*100. + if(kmino > 0) then + per = float(kmino)/float(len)*100. print 9003,fldomn,kmino,per - 9003 format(' open ocean min check. modified to ',f8.1, + 9003 format(' open ocean min check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmaxo.gt.0) then - per=float(kmaxo)/float(len)*100. + if(kmaxo > 0) then + per = float(kmaxo)/float(len)*100. print 9004,fldomx,kmaxo,per - 9004 format(' open sea max check. modified to ',f8.1, + 9004 format(' open sea max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmins.gt.0) then - per=float(kmins)/float(len)*100. + if(kmins >.0) then + per = float(kmins)/float(len)*100. print 9009,fldsmn,kmins,per - 9009 format(' snow covered land min check. modified to ',f8.1, + 9009 format(' snow covered land min check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmaxs.gt.0) then - per=float(kmaxs)/float(len)*100. + if(kmaxs > 0) then + per = float(kmaxs)/float(len)*100. print 9010,fldsmx,kmaxs,per - 9010 format(' snow covered land max check. modified to ',f8.1, + 9010 format(' snow covered land max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmini.gt.0) then - per=float(kmini)/float(len)*100. + if(kmini > 0) then + per = float(kmini)/float(len)*100. print 9005,fldimn,kmini,per - 9005 format(' bare ice min check. modified to ',f8.1, + 9005 format(' bare ice min check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmaxi.gt.0) then - per=float(kmaxi)/float(len)*100. + if(kmaxi > 0) then + per = float(kmaxi)/float(len)*100. print 9006,fldimx,kmaxi,per - 9006 format(' bare ice max check. modified to ',f8.1, + 9006 format(' bare ice max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per + if(per > permax) permax=per endif - if(kminj.gt.0) then - per=float(kminj)/float(len)*100. + if(kminj > 0) then + per = float(kminj)/float(len)*100. print 9007,fldjmn,kminj,per - 9007 format(' snow covered ice min check. modified to ',f8.1, + 9007 format(' snow covered ice min check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') if(per.gt.permax) permax=per endif - if(kmaxj.gt.0) then - per=float(kmaxj)/float(len)*100. + if(kmaxj > 0) then + per = float(kmaxj)/float(len)*100. print 9008,fldjmx,kmaxj,per - 9008 format(' snow covered ice max check. modified to ',f8.1, + 9008 format(' snow covered ice max check. modified to ',f8.1, & & ' at ',i5,' points ',f4.1,'percent') - if(per.gt.permax) permax=per + if(per > permax) permax=per endif ! commented on 06/30/99 -- moorthi ! if(lgchek) then @@ -5879,21 +5958,19 @@ subroutine qcsli(slianl,slifcs,len,me) !>\ingroup mod_sfcsub subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, & & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, & - & zoranl,smcanl, & - & smcclm,tsfsmx,albomx,zoromx, me) + & zoranl,smcanl,smcclm,tsfsmx,albomx,zoromx, me) ! use machine , only : kind_io8,kind_io4 implicit none integer kount,me,k,i,lsoil,len real (kind=kind_io8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx real (kind=kind_io8) tsffcs(len), snofcs(len) - real (kind=kind_io8) snoanl(len), aisanl(len), - & slianl(len), zoranl(len), - & tsfanl(len), albanl(len,4), - & smcanl(len,lsoil) - real (kind=kind_io8) smcclm(len,lsoil) + real (kind=kind_io8) snoanl(len), aisanl(len), & + & slianl(len), zoranl(len), & + & tsfanl(len), albanl(len,4), & + & smcanl(len,lsoil), smcclm(len,lsoil) ! - if (me .eq. 0) write(6,*) 'qc of snow and sea-ice analysis' + if (me == 0) write(6,*) 'qc of snow and sea-ice analysis' ! ! qc of snow analysis ! @@ -5901,7 +5978,7 @@ subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, & ! kount = 0 do i=1,len - if(slianl(i).gt.0..and. + if(slianl(i).gt.0..and. & & tsffcs(i).gt.qctsfs.and.snoanl(i).gt.0.) then kount = kount + 1 snoanl(i) = 0. @@ -6462,6 +6539,7 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, & & wlon,rnlat,rlnout,rltout,gaus,blno, blto) use machine , only : kind_io8,kind_io4 + use sfccyc_module , only : num_threads implicit none integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, & & j,iret @@ -6487,15 +6565,12 @@ subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, & ! ! logical first - integer num_threads data first /.true./ - save num_threads, first + save first ! integer len_thread_m, j1_t, j2_t, it - integer num_parthds ! if (first) then - num_threads = num_parthds() first = .false. endif ! @@ -7137,8 +7212,7 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & kpd7=-1 if (ialb == 1) then -!cbosu still need facsf and facwf. read them from the production -!cbosu file +!cbosu still need facsf and facwf. read them from the production file if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask &, alf,len,iret @@ -7947,8 +8021,7 @@ end subroutine clima !>\ingroup mod_sfcsub subroutine fixrdc_tile(filename_raw, tile_num_ch, & - & i_index, j_index, kpds, & - & var, mon, npts, me) + & i_index, j_index, kpds, var, mon, npts, me) use netcdf use machine , only : kind_io8 implicit none @@ -7965,7 +8038,8 @@ subroutine fixrdc_tile(filename_raw, tile_num_ch, & integer :: nx, ny, num_times integer :: id_var real(kind=4), allocatable :: dummy(:,:,:) - ii=index(filename_raw,"tileX") + + ii = index(filename_raw,"tileX") do i = 1, len(filename) filename(i:i) = " " @@ -8619,5 +8693,4 @@ subroutine snodpth2(glacir,snwmax,snoanl, len, me) enddo return end - !>@} diff --git a/physics/shalcnv.meta b/physics/shalcnv.meta index d56e1da3b..3fe29f5ef 100644 --- a/physics/shalcnv.meta +++ b/physics/shalcnv.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = shalcnv + type = scheme + dependencies = funcphys.f90,machine.F + +######################################################################## [ccpp-arg-table] name = shalcnv_init type = scheme @@ -51,11 +57,6 @@ intent = out optional = F -######################################################################## -[ccpp-arg-table] - name = shalcnv_finalize - type = scheme - ######################################################################## [ccpp-arg-table] name = shalcnv_run diff --git a/physics/shinhongvdif.F90 b/physics/shinhongvdif.F90 index 83270a08d..4032f1828 100644 --- a/physics/shinhongvdif.F90 +++ b/physics/shinhongvdif.F90 @@ -34,7 +34,9 @@ subroutine shinhongvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & dusfc,dvsfc,dtsfc,dqsfc, & dt,kpbl1d, & u10,v10, & - dx,errmsg,errflg ) + dx,lssav,ldiag3d,qdiag3d, & + flag_for_pbl_generic_tend,ntoz,du3dt_PBL,dv3dt_PBL, & + dt3dt_PBL,dq3dt_PBL,do3dt_PBL,errmsg,errflg ) use machine , only : kind_phys ! @@ -104,8 +106,10 @@ subroutine shinhongvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & real(kind=kind_phys),parameter :: cpent = -0.4,rigsmax = 100. real(kind=kind_phys),parameter :: entfmin = 1.0, entfmax = 5.0 ! 1D in - integer, intent(in ) :: im,km,ntrac,ndiff,ntcw,ntiw + integer, intent(in ) :: im,km,ntrac,ndiff,ntcw,ntiw,ntoz real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt + logical, intent(in ) :: lssav, ldiag3d, qdiag3d, & + flag_for_pbl_generic_tend ! 3D in real(kind=kind_phys), dimension(im, km) , & intent(in ) :: phil, & @@ -127,6 +131,8 @@ subroutine shinhongvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & ttnp real(kind=kind_phys), dimension(im, km, ntrac ) , & intent(inout) :: qtnp + real(kind=kind_phys), dimension(im,km) , & + intent(inout) :: du3dt_PBL, dv3dt_PBL, dt3dt_PBL, dq3dt_PBL, do3dt_PBL ! 2D in integer, dimension(im) , & intent(in ) :: landmask @@ -956,6 +962,14 @@ subroutine shinhongvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & endif enddo enddo + if(lssav .and. ldiag3d .and. .not. flag_for_pbl_generic_tend) then + do k = kte,kts,-1 + do i = its,ite + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + ttend*dtstep + enddo + enddo + endif ! ! compute tridiagonal matrix elements for moisture, clouds, and gases ! @@ -1080,6 +1094,14 @@ subroutine shinhongvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & tvflux_e(i,k) = tflux_e(i,k) + qflux_e(i,k)*ep1*thx(i,k) enddo enddo + if(lssav .and. ldiag3d .and. qdiag3d .and. .not. flag_for_pbl_generic_tend) then + do k = kte,kts,-1 + do i = its,ite + qtend = (f3(i,k,1)-qx(i,k,1))*rdt + dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + qtend*dtstep + enddo + enddo + endif ! print*,"qtnp:",maxval(qtnp(:,:,1)),minval(qtnp(:,:,1)) ! do k = kts,kte @@ -1109,6 +1131,16 @@ subroutine shinhongvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & enddo endif enddo + if(lssav .and. ldiag3d .and. ntoz>0 .and. qdiag3d .and. & + & .not. flag_for_pbl_generic_tend) then + ic = ntoz + do k = kte,kts,-1 + do i = its,ite + qtend = f3(i,k,ic)-qx(i,k,ic) + do3dt_PBL(i,k) = do3dt_PBL(i,k)+qtend + enddo + enddo + endif endif ! ! compute tridiagonal matrix elements for momentum @@ -1200,6 +1232,16 @@ subroutine shinhongvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) enddo enddo + if(lssav .and. ldiag3d .and. .not. flag_for_pbl_generic_tend) then + do k = kte,kts,-1 + do i = its,ite + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + du3dt_PBL(i,k) = du3dt_PBL(i,k) + utend*dtstep + dv3dt_PBL(i,k) = dv3dt_PBL(i,k) + vtend*dtstep + enddo + enddo + endif ! do i = its,ite kpbl1d(i) = kpbl(i) diff --git a/physics/shinhongvdif.meta b/physics/shinhongvdif.meta index 08646d7b9..49782d4eb 100644 --- a/physics/shinhongvdif.meta +++ b/physics/shinhongvdif.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = shinhongvdif + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = shinhongvdif_run type = scheme @@ -407,6 +413,82 @@ kind = kind_phys intent = in optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[flag_for_pbl_generic_tend] + standard_name = flag_for_generic_planetary_boundary_layer_tendency + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[ntoz] + standard_name = index_for_ozone + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in + optional = F +[du3dt_PBL] + standard_name = cumulative_change_in_x_wind_due_to_PBL + long_name = cumulative change in x wind due to PBL + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dv3dt_PBL] + standard_name = cumulative_change_in_y_wind_due_to_PBL + long_name = cumulative change in y wind due to PBL + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dt3dt_PBL] + standard_name = cumulative_change_in_temperature_due_to_PBL + long_name = cumulative change in temperature due to PBL + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dq3dt_PBL] + standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL + long_name = cumulative change in water vapor specific humidity due to PBL + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[do3dt_PBL] + standard_name = cumulative_change_in_ozone_mixing_ratio_due_to_PBL + long_name = cumulative change in ozone mixing ratio due to PBL + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP diff --git a/physics/tracer_sanitizer.meta b/physics/tracer_sanitizer.meta index 582823fdb..0378911ed 100644 --- a/physics/tracer_sanitizer.meta +++ b/physics/tracer_sanitizer.meta @@ -1,3 +1,10 @@ +[ccpp-table-properties] + name = tracer_sanitizer + type = scheme + dependencies = machine.F + +######################################################################## + [ccpp-arg-table] name = tracer_sanitizer_run type = scheme diff --git a/physics/tridi.f b/physics/tridi.f index bd44bcc86..0103b388f 100644 --- a/physics/tridi.f +++ b/physics/tridi.f @@ -9,6 +9,7 @@ subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) ! use machine , only : kind_phys implicit none + integer, parameter :: one = 1.0_kind_phys integer k,n,l,i real(kind=kind_phys) fk ! @@ -16,19 +17,19 @@ subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) & au(l,n-1),a1(l,n) ! do i=1,l - fk = 1./cm(i,1) + fk = one / cm(i,1) au(i,1) = fk*cu(i,1) a1(i,1) = fk*r1(i,1) enddo do k=2,n-1 do i=1,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + fk = one / (cm(i,k)-cl(i,k)*au(i,k-1)) au(i,k) = fk*cu(i,k) a1(i,k) = fk*(r1(i,k)-cl(i,k)*a1(i,k-1)) enddo enddo do i=1,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + fk = one / (cm(i,n)-cl(i,n)*au(i,n-1)) a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(i,n-1)) enddo do k=n-1,1,-1 @@ -40,36 +41,37 @@ subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) return end subroutine tridi1 -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- !>\ingroup satmedmf !>\ingroup satmedmfvdifq !> This subroutine .. subroutine tridi2(l,n,cl,cm,cu,r1,r2,au,a1,a2) -cc +! use machine , only : kind_phys implicit none + integer, parameter :: one = 1.0_kind_phys integer k,n,l,i real(kind=kind_phys) fk -cc +! real(kind=kind_phys) cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n),r2(l,n), & & au(l,n-1),a1(l,n),a2(l,n) -c---------------------------------------------------------------------- +!---------------------------------------------------------------------- do i=1,l - fk = 1./cm(i,1) + fk = one / cm(i,1) au(i,1) = fk*cu(i,1) a1(i,1) = fk*r1(i,1) a2(i,1) = fk*r2(i,1) enddo do k=2,n-1 do i=1,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + fk = one / (cm(i,k)-cl(i,k)*au(i,k-1)) au(i,k) = fk*cu(i,k) a1(i,k) = fk*(r1(i,k)-cl(i,k)*a1(i,k-1)) a2(i,k) = fk*(r2(i,k)-cl(i,k)*a2(i,k-1)) enddo enddo do i=1,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + fk = one / (cm(i,n)-cl(i,n)*au(i,n-1)) a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(i,n-1)) a2(i,n) = fk*(r2(i,n)-cl(i,n)*a2(i,n-1)) enddo @@ -79,30 +81,31 @@ subroutine tridi2(l,n,cl,cm,cu,r1,r2,au,a1,a2) a2(i,k) = a2(i,k)-au(i,k)*a2(i,k+1) enddo enddo -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- return end subroutine tridi2 -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- !>\ingroup satmedmf !>\ingroup satmedmfvdifq !> Routine to solve the tridiagonal system to calculate u- and !! v-momentum at \f$ t + \Delta t \f$; part of two-part process to !! calculate time tendencies due to vertical diffusion. subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) -cc +! use machine , only : kind_phys implicit none + integer, parameter :: one = 1.0_kind_phys integer is,k,kk,n,nt,l,i real(kind=kind_phys) fk(l) -cc +! real(kind=kind_phys) cl(l,2:n), cm(l,n), cu(l,n-1), & & r1(l,n), r2(l,n*nt), & & au(l,n-1), a1(l,n), a2(l,n*nt), & & fkk(l,2:n-1) -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- do i=1,l - fk(i) = 1./cm(i,1) + fk(i) = one / cm(i,1) au(i,1) = fk(i)*cu(i,1) a1(i,1) = fk(i)*r1(i,1) enddo @@ -114,7 +117,7 @@ subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) enddo do k=2,n-1 do i=1,l - fkk(i,k) = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + fkk(i,k) = one / (cm(i,k)-cl(i,k)*au(i,k-1)) au(i,k) = fkk(i,k)*cu(i,k) a1(i,k) = fkk(i,k)*(r1(i,k)-cl(i,k)*a1(i,k-1)) enddo @@ -128,7 +131,7 @@ subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) enddo enddo do i=1,l - fk(i) = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + fk(i) = one / (cm(i,n)-cl(i,n)*au(i,n-1)) a1(i,n) = fk(i)*(r1(i,n)-cl(i,n)*a1(i,n-1)) enddo do k = 1, nt @@ -150,11 +153,11 @@ subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) enddo enddo enddo -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- return end subroutine tridin -c----------------------------------------------------------------------- +!----------------------------------------------------------------------- !>\ingroup satmedmf !>\ingroup satmedmfvdifq !! This subroutine solves tridiagonal problem for TKE. @@ -163,6 +166,7 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) !! use machine , only : kind_phys implicit none + integer, parameter :: one = 1.0_kind_phys integer is,k,kk,n,nt,l,i real(kind=kind_phys) fk(l) !! @@ -172,7 +176,7 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) & fkk(l,2:n-1) !----------------------------------------------------------------------- do i=1,l - fk(i) = 1./cm(i,1) + fk(i) = one / cm(i,1) au(i,1) = fk(i)*cu(i,1) enddo do k = 1, nt @@ -183,7 +187,7 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) enddo do k=2,n-1 do i=1,l - fkk(i,k) = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + fkk(i,k) = one / (cm(i,k)-cl(i,k)*au(i,k-1)) au(i,k) = fkk(i,k)*cu(i,k) enddo enddo @@ -196,7 +200,7 @@ subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) enddo enddo do i=1,l - fk(i) = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + fk(i) = one / (cm(i,n)-cl(i,n)*au(i,n-1)) enddo do k = 1, nt is = (k-1) * n diff --git a/physics/ugwp_driver_v0.F b/physics/ugwp_driver_v0.F index af19447dc..f573c8776 100644 --- a/physics/ugwp_driver_v0.F +++ b/physics/ugwp_driver_v0.F @@ -6,9 +6,9 @@ module sso_coorde ! pgd4=4 (4 timse taub, control pgwd=1) ! use machine, only: kind_phys - real(kind=kind_phys),parameter :: pgwd = 1._kind_phys - real(kind=kind_phys),parameter :: pgwd4 = 1._kind_phys - logical,parameter :: debugprint = .false. + real(kind=kind_phys),parameter :: pgwd = 1.0_kind_phys + real(kind=kind_phys),parameter :: pgwd4 = 1.0_kind_phys + logical, parameter :: debugprint = .false. end module sso_coorde ! ! @@ -38,6 +38,8 @@ subroutine cires_ugwp_driver_v0(me, master, implicit none !input + integer, parameter :: kp = kind_phys + integer, intent(in) :: me, master integer, intent(in) :: im, levs, kdt, imx, nmtvr, ntke, ipr @@ -87,8 +89,9 @@ subroutine cires_ugwp_driver_v0(me, master, ! ! switches that activate impact of OGWs and NGWs along with eddy diffusion ! - real(kind=kind_phys), parameter :: pogw=1.0, pngw=1.0, pked=1.0 - &, ompked=1.0-pked + real(kind=kind_phys), parameter :: pogw=1.0_kp, pngw=1.0_kp + &, pked=1.0_kp, zero=0.0_kp + &, ompked=1.0_kp-pked ! ! switches for GW-effects: pogw=1 (OGWs) pngw=1 (NGWs) pked=1 (eddy mixing) ! @@ -103,7 +106,7 @@ subroutine cires_ugwp_driver_v0(me, master, endif do i=1,im - zlwb(i) = 0. + zlwb(i) = zero enddo ! ! 1) ORO stationary GWs @@ -129,13 +132,13 @@ subroutine cires_ugwp_driver_v0(me, master, else ! calling old GFS gravity wave drag as is do k=1,levs do i=1,im - pdvdt(i,k) = 0.0 - pdudt(i,k) = 0.0 - pdtdt(i,k) = 0.0 - pkdis(i,k) = 0.0 + pdvdt(i,k) = zero + pdudt(i,k) = zero + pdtdt(i,k) = zero + pkdis(i,k) = zero enddo enddo - if (cdmbgwd(1) > 0.0 .or. cdmbgwd(2) > 0.0) then + if (cdmbgwd(1) > zero.or. cdmbgwd(2) > zero) then call gwdps(im, im, im, levs, Pdvdt, Pdudt, Pdtdt & &, ugrs, vgrs, tgrs, qgrs & &, kpbl, prsi, del, prsl, prslk, phii, phil, dtp, kdt& @@ -145,11 +148,11 @@ subroutine cires_ugwp_driver_v0(me, master, &, nmtvr, cdmbgwd(1:2), me, lprnt, ipr, rdxzb) endif - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero + du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero endif ! - if (cdmbgwd(3) > 0.0) then + if (cdmbgwd(3) > zero) then ! 2) non-stationary GWs with GEOS-5/MERRA GW-forcing ! ---------------------------------------------- !-------- @@ -159,11 +162,11 @@ subroutine cires_ugwp_driver_v0(me, master, ! call slat_geos5(im, xlatd, tau_ngw) ! - if (abs(1.0-cdmbgwd(3)) > 1.0e-6) then - if (cdmbgwd(4) > 0.0) then + if (abs(1.0_kp-cdmbgwd(3)) > 1.0e-6_kp) then + if (cdmbgwd(4) > zero) then do i=1,im - turb_fac(i) = 0.0 - tem(i) = 0.0 + turb_fac(i) = zero + tem(i) = zero enddo if (ntke > 0) then do k=1,(levs+levs)/3 @@ -179,7 +182,7 @@ subroutine cires_ugwp_driver_v0(me, master, rfac = 86400000 / dtp do i=1,im tx1 = cdmbgwd(4)*min(10.0, max(turb_fac(i),rain(i)*rfac)) - tau_ngw(i) = tau_ngw(i) * max(0.1, min(5.0, tx1)) + tau_ngw(i) = tau_ngw(i) * max(0.1_kp, min(5.0_kp, tx1)) enddo endif do i=1,im @@ -218,10 +221,10 @@ subroutine cires_ugwp_driver_v0(me, master, enddo endif - if (pogw == 0.0) then + if (pogw == zero) then ! zmtb = 0.; zogw =0. - tau_mtb = 0.0 ; tau_ogw = 0.0 ; tau_tofd = 0.0 - du3dt_mtb = 0.0 ; du3dt_ogw = 0.0 ; du3dt_tms= 0.0 + tau_mtb = zero ; tau_ogw = zero ; tau_tofd = zero + du3dt_mtb = zero ; du3dt_ogw = zero ; du3dt_tms= zero endif return @@ -235,7 +238,7 @@ subroutine cires_ugwp_driver_v0(me, master, !------------------------------------------------------------------------------ do k=1,levs do i=1,im - ed_dudt(i,k) = 0.0 ; ed_dvdt(i,k) = 0.0 ; ed_dtdt(i,k) = 0.0 + ed_dudt(i,k) = zero ; ed_dvdt(i,k) = zero ; ed_dtdt(i,k) = zero enddo enddo @@ -314,6 +317,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, use sso_coorde, only : pgwd, pgwd4, debugprint !---------------------------------------- implicit none + integer, parameter :: kp = kind_phys character(len=8) :: strsolver='PSS-1986' ! current operational solver or 'WAM-2017' integer, intent(in) :: im, km, imx, kdt integer, intent(in) :: me, master @@ -359,9 +363,9 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, ! cleff = 2.5*0.5e-5 * sqrt(192./768.) => Lh_eff = 1004. km ! 6*dx = 240 km 8*dx = 320. ~ 3-5 more effective !--------------------------------------------------------------------- - real(kind=kind_phys) :: gammin = 0.00999999 - real(kind=kind_phys), parameter :: nhilmax = 25. - real(kind=kind_phys), parameter :: sso_min = 3000. + real(kind=kind_phys) :: gammin = 0.00999999_kp + real(kind=kind_phys), parameter :: nhilmax = 25.0_kp + real(kind=kind_phys), parameter :: sso_min = 3000.0_kp logical, parameter :: do_adjoro = .true. ! real(kind=kind_phys) :: shilmin, sgrmax, sgrmin @@ -435,7 +439,7 @@ SUBROUTINE GWDPS_V0(IM, km, imx, do_tofd, dsmax = sqrt(sgrmax) ; dsmin = sqrt(sgrmin) dxres = pi2*arad/float(IMX) - hdxres = 0.5*dxres + hdxres = 0.5_kp*dxres ! shilmin = sgrmin/nhilmax ! not used - Moorthi ! gammin = min(sso_min/dsmax, 1.) ! Moorthi - with this results are not reproducible @@ -1286,6 +1290,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! nov 2017 nh/rotational gw-modes for nh-fv3gfs ! --------------------------------------------------------------------------------- ! + use machine, only : kind_phys use ugwp_common , only : rgrav, grav, cpd, rd, rv &, omega2, rcpd2, pi, pi2, fv @@ -1306,6 +1311,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, implicit none !23456 + integer, parameter :: kp = kind_phys integer, intent(in) :: klev ! vertical level integer, intent(in) :: klon ! horiz tiles @@ -1332,8 +1338,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, real, intent(out) :: pdvdt(klon,klev) ! meridional momentum tendency real, intent(out) :: pdtdt(klon,klev) ! gw-heating (u*ax+v*ay)/cp real, intent(out) :: dked(klon,klev) ! gw-eddy diffusion - real, parameter :: minvel = 0.5 ! - real, parameter :: epsln = 1.0d-12 ! + real, parameter :: minvel = 0.5_kp ! + real, parameter :: epsln = 1.0e-12_kp ! + real, parameter :: zero = 0.0_kp, one = 1.0_kp, half = 0.5_kp !vay-2018 @@ -1395,7 +1402,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! real :: rcpd, grav2cpd real, parameter :: rcpdl = cpd/grav ! 1/[g/cp] == cp/g &, grav2cpd = grav/rcpdl ! g*(g/cp)= g^2/cp - &, cpdi = 1.0d0/cpd + &, cpdi = one/cpd real :: expdis, fdis ! real :: fmode, expdis, fdis @@ -1407,10 +1414,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! do k=1,klev do j=1,klon - pdvdt(j,k) = 0.0 - pdudt(j,k) = 0.0 - pdtdt(j,k) = 0.0 - dked(j,k) = 0.0 + pdvdt(j,k) = zero + pdudt(j,k) = zero + pdtdt(j,k) = zero + dked(j,k) = zero phil(j,k) = philg(j,k) * rgrav enddo enddo @@ -1438,9 +1445,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, do iazi=1, nazd do jk=1,klev do jl=1,klon - zpu(jl,jk,iazi) = 0.0 -! zcrt(jl,jk,iazi) = 0.0 -! zdfl(jl,jk,iazi) = 0.0 + zpu(jl,jk,iazi) = zero +! zcrt(jl,jk,iazi) = zero +! zdfl(jl,jk,iazi) = zero enddo enddo enddo @@ -1456,23 +1463,23 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! --------------------------------------------- do jk=max(ilaunch,2),klev do jl=1,klon - tvc1 = tm1(jl,jk) * (1. +fv*qm1(jl,jk)) - tvm1 = tm1(jl,jk-1) * (1. +fv*qm1(jl,jk-1)) + tvc1 = tm1(jl,jk) * (one +fv*qm1(jl,jk)) + tvm1 = tm1(jl,jk-1) * (one +fv*qm1(jl,jk-1)) ! zthm1(jl,jk) = 0.5 *(tvc1+tvm1) - zthm1 = 2.0 / (tvc1+tvm1) - zuhm1(jl,jk) = 0.5 *(um1(jl,jk-1)+um1(jl,jk)) - zvhm1(jl,jk) = 0.5 *(vm1(jl,jk-1)+vm1(jl,jk)) + zthm1 = 2.0_kp / (tvc1+tvm1) + zuhm1(jl,jk) = half *(um1(jl,jk-1)+um1(jl,jk)) + zvhm1(jl,jk) = half *(vm1(jl,jk-1)+vm1(jl,jk)) ! zrhohm1(jl,jk) = prsi(jl,jk)*rdi/zthm1(jl,jk) ! rho = p/(RTv) zrhohm1(jl,jk) = prsi(jl,jk)*rdi*zthm1 ! rho = p/(RTv) zdelp = phil(jl,jk)-phil(jl,jk-1) !>0 ...... dz-meters v_zmet(jl,jk) = zdelp + zdelp delpi(jl,jk) = grav / (prsi(jl,jk-1) - prsi(jl,jk)) vueff(jl,jk) = - & 2.e-5*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min + & 2.e-5_kp*exp( (phil(jl,jk)+phil(jl,jk-1))*rhp2)+dked_min ! ! zbn2(jl,jk) = grav2cpd/zthm1(jl,jk) zbn2(jl,jk) = grav2cpd*zthm1 - & * (1.0+rcpdl*(tm1(jl,jk)-tm1(jl,jk-1))/zdelp) + & * (one+rcpdl*(tm1(jl,jk)-tm1(jl,jk-1))/zdelp) zbn2(jl,jk) = max(min(zbn2(jl,jk), gssec), bv2min) zbvfhm1(jl,jk) = sqrt(zbn2(jl,jk)) ! bn = sqrt(bn2) enddo @@ -1621,8 +1628,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! copy zflux into all other azimuths ! -------------------------------- -! zact(:,:,:) = 1.0 ; zacc(:,:,:) = 1.0 - zact(:,:,:) = 1.0 +! zact(:,:,:) = one ; zacc(:,:,:) = one + zact(:,:,:) = one do iazi=2, nazd do inc=1,nwav do jl=1,klon @@ -1690,9 +1697,9 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, do inc=1, nwav zcin = zci(inc) if (abs(zcin) > epsln) then - zcinc = 1.0 / zcin + zcinc = one / zcin else - zcinc = 1.0 + zcinc = one endif do jl=1,klon !======================================================================= @@ -1704,12 +1711,12 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, v_wdp = v_kxw*v_cdp wdop2 = v_wdp* v_wdp cdf2 = v_cdp*v_cdp - c2f2(jL) - if (cdf2 > 0) then + if (cdf2 > zero) then kzw2 = (zBn2(jL,jk)-wdop2)/Cdf2 - v_kxw2 else - kzw2 = 0.0 + kzw2 = zero endif - if ( kzw2 > 0 ) then + if ( kzw2 > zero ) then v_kzw = sqrt(kzw2) ! !linsatdis: kzw2, kzw3, kdsat, c2f2, cdf2, cdf1 @@ -1722,10 +1729,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, v_kzi = abs(v_kzw*v_kzw*vueff(jl,jk)/v_wdp*v_kzw) expdis = exp(-v_kzi*v_zmet(jl,jk)) else - v_kzi = 0. - expdis = 1.0 - v_kzw = 0. - v_cdp = 0. ! no effects of reflected waves + v_kzi = zero + expdis = one + v_kzw = zero + v_cdp = zero ! no effects of reflected waves endif ! fmode = zflux(jl,inc,iazi) @@ -1741,7 +1748,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! flux_tot - sat.flux ! zdep = zact(jl,inc,iazi)* (fdis-zfluxs) - if(zdep > 0.0 ) then + if(zdep > zero ) then ! subs on sat-limit zflux(jl,inc,iazi) = zfluxs zflux_z(jl,inc,jk) = zfluxs @@ -1755,7 +1762,7 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! ! integrate over spectral modes zpu(y, z, azimuth) zact(jl,inc,iazi)*zflux(jl,inc,iazi)*[d("zcinc")] ! - zdfdz_v(:,jk,iazi) = 0.0 + zdfdz_v(:,jk,iazi) = zero do inc=1, nwav zcinc = zdci(inc) ! dc-integration @@ -1795,8 +1802,8 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, ! do jk=1,klev+1 do jl=1,klon - taux(jl,jk) = 0.0 - tauy(jl,jk) = 0.0 + taux(jl,jk) = zero + tauy(jl,jk) = zero enddo enddo @@ -1858,10 +1865,10 @@ subroutine fv3_ugwp_solv2_v0(klon, klev, dtime, if (kdt == 1 .and. mpi_id == master .and. debugprint) then print *, 'vgw done ' ! - print *, maxval(pdudt)*86400., minval(pdudt)*86400, 'vgw ax' - print *, maxval(pdvdt)*86400., minval(pdvdt)*86400, 'vgw ay' + print *, maxval(pdudt)*86400, minval(pdudt)*86400, 'vgw ax' + print *, maxval(pdvdt)*86400, minval(pdvdt)*86400, 'vgw ay' print *, maxval(dked)*1., minval(dked)*1, 'vgw keddy m2/sec' - print *, maxval(pdtdt)*86400., minval(pdtdt)*86400,'vgw eps' + print *, maxval(pdtdt)*86400, minval(pdtdt)*86400,'vgw eps' ! ! print *, ' ugwp -heating rates ' endif @@ -2064,22 +2071,22 @@ subroutine diff_1d_wtend(levs, dt, F, F1, Km, rdp, rdpm, S, S1) S(K) = F(k) S1(K) = F1(k) do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) - S1(k) = cd*F1(k+1) + ad *F1(k-1) + bd *F1(k) + ad = cd + kp1 = .5*(Km(k)+Km(k+1)) + cd = rdp(k)*rdpm(k)*kp1*dt + bd = 1.-(ad +cd) + S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) + S1(k) = cd*F1(k+1) + ad *F1(k-1) + bd *F1(k) enddo - k = levs - S(k) = F(k) - S1(k) = F1(k) + k = levs + S(k) = F(k) + S1(k) = F1(k) end subroutine diff_1d_wtend subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) - use machine, only: kind_phys - implicit none - integer :: levs + use machine, only: kind_phys + implicit none + integer :: levs real(kind=kind_phys) :: dt real(kind=kind_phys) :: S(levs), S1(levs), F(levs), F1(levs) real(kind=kind_phys) :: Km(levs), rdp(levs), rdpm(levs-1) @@ -2096,15 +2103,15 @@ subroutine diff_1d_ptend(levs, dt, F, Km, rdp, rdpm, S) kp1 = .5*(Km(k)+Km(k+1)) cd = rdp(1)*rdpm(1)*kp1*dt bd = 1. -(cd +ad) -! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) +! S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) S(K) = F(k) do k=2, levs-1 - ad = cd - kp1 = .5*(Km(k)+Km(k+1)) - cd = rdp(k)*rdpm(k)*kp1*dt - bd = 1.-(ad +cd) - S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) + ad = cd + kp1 = .5*(Km(k)+Km(k+1)) + cd = rdp(k)*rdpm(k)*kp1*dt + bd = 1.-(ad +cd) + S(k) = cd*F(k+1) + ad *F(k-1) + bd *F(k) enddo - k = levs - S(k) = F(k) + k = levs + S(k) = F(k) end subroutine diff_1d_ptend diff --git a/physics/wv_saturation.F b/physics/wv_saturation.F index b19da7b5e..b12b76a91 100644 --- a/physics/wv_saturation.F +++ b/physics/wv_saturation.F @@ -9,13 +9,12 @@ !! This module contain some utility functions for saturation vapor pressure. module wv_saturation #ifdef GEOS5 - use MAPL_ConstantsMod, r8 => MAPL_R8 + use MAPL_ConstantsMod, kp => MAPL_R8 #endif #ifdef NEMS_GSM use funcphys, only : fpvsl, fpvsi, fpvs ! saturation vapor pressure for water & ice + use machine, only : kp => kind_phys #endif - use machine, only : r8 => kind_phys - !++jtb (comm out) @@ -61,37 +60,37 @@ module wv_saturation ! to tmax+1 degrees k in one degree increments. ttrice defines the ! transition region where es is a combination of ice & water values ! - real(r8) estbl(plenest) - real(r8) tmin - real(r8) tmax - real(r8) ttrice - real(r8) pcf(6) - real(r8) epsqs - real(r8) rgasv - real(r8) hlatf - real(r8) hlatv - real(r8) cp - real(r8) tmelt + real(kp) estbl(plenest) + real(kp) tmin + real(kp) tmax + real(kp) ttrice + real(kp) pcf(6) + real(kp) epsqs + real(kp) rgasv + real(kp) hlatf + real(kp) hlatv + real(kp) cp + real(kp) tmelt logical icephs integer, parameter :: iulog=6 contains - real(r8) function estblf( td ) + real(kp) function estblf( td ) ! ! Saturation vapor pressure table lookup ! - real(r8), intent(in) :: td + real(kp), intent(in) :: td ! - real(r8) :: e - real(r8) :: ai + real(kp) :: e + real(kp) :: ai integer :: i ! e = max(min(td,tmax),tmin) i = int(e-tmin)+1 ai = aint(e-tmin) - estblf = (tmin+ai-e+1._r8)* estbl(i)-(tmin+ai-e)* estbl(i+1) + estblf = (tmin+ai-e+1._kp)* estbl(i)-(tmin+ai-e)* estbl(i+1) end function estblf !>\ingroup wv_saturation_mod @@ -110,19 +109,19 @@ subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , latvap ,latice , & ! ! Input arguments ! - real(r8), intent(in) :: tmn - real(r8), intent(in) :: tmx - real(r8), intent(in) :: epsil - real(r8), intent(in) :: trice - real(r8), intent(in) :: latvap - real(r8), intent(in) :: latice - real(r8), intent(in) :: rh2o - real(r8), intent(in) :: cpair - real(r8), intent(in) :: tmeltx + real(kp), intent(in) :: tmn + real(kp), intent(in) :: tmx + real(kp), intent(in) :: epsil + real(kp), intent(in) :: trice + real(kp), intent(in) :: latvap + real(kp), intent(in) :: latice + real(kp), intent(in) :: rh2o + real(kp), intent(in) :: cpair + real(kp), intent(in) :: tmeltx ! !---------------------------Local variables----------------------------- ! - real(r8) t + real(kp) t integer n integer lentbl integer itype @@ -148,7 +147,7 @@ subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , latvap ,latice , & cp = cpair tmelt = tmeltx ! - lentbl = INT(tmax-tmin+2.000001_r8) + lentbl = INT(tmax-tmin+2.000001_kp) if (lentbl .gt. plenest) then @@ -162,7 +161,7 @@ subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , latvap ,latice , & ! If so, set appropriate transition range for temperature ! if (icephs) then - if (ttrice /= 0.0_r8) then + if (ttrice /= 0.0_kp) then itype = -ttrice else itype = 1 @@ -171,14 +170,14 @@ subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , latvap ,latice , & itype = 0 end if ! - t = tmin - 1.0_r8 + t = tmin - 1.0_kp do n=1,lentbl - t = t + 1.0_r8 + t = t + 1.0_kp call gffgch(t,estbl(n),tmelt,itype) end do ! do n=lentbl+1,plenest - estbl(n) = -99999.0_r8 + estbl(n) = -99999.0_kp end do ! ! Table complete -- Set coefficients for polynomial approximation of @@ -188,11 +187,11 @@ subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , latvap ,latice , & ! ! --- Degree 5 approximation --- ! - pcf(1) = 5.04469588506e-01_r8 - pcf(2) = -5.47288442819e+00_r8 - pcf(3) = -3.67471858735e-01_r8 - pcf(4) = -8.95963532403e-03_r8 - pcf(5) = -7.78053686625e-05_r8 + pcf(1) = 5.04469588506e-01_kp + pcf(2) = -5.47288442819e+00_kp + pcf(3) = -3.67471858735e-01_kp + pcf(4) = -8.95963532403e-03_kp + pcf(5) = -7.78053686625e-05_kp ! ! --- Degree 6 approximation --- ! @@ -235,35 +234,35 @@ subroutine aqsat(t ,p ,es ,qs ,ii , ilen ,kk ,kstart ,kend ) integer, intent(in) :: ilen integer, intent(in) :: kstart integer, intent(in) :: kend - real(r8), intent(in) :: t(ii,kk) - real(r8), intent(in) :: p(ii,kk) + real(kp), intent(in) :: t(ii,kk) + real(kp), intent(in) :: p(ii,kk) ! ! Output arguments ! - real(r8), intent(out) :: es(ii,kk) - real(r8), intent(out) :: qs(ii,kk) + real(kp), intent(out) :: es(ii,kk) + real(kp), intent(out) :: qs(ii,kk) ! !---------------------------Local workspace----------------------------- ! - real(r8) omeps + real(kp) omeps integer i, k ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs do k=kstart,kend do i=1,ilen es(i,k) = min(estblf(t(i,k)),p(i,k)) ! ! Saturation specific humidity ! - qs(i,k) = min(1.0_r8, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) + qs(i,k) = min(1.0_kp, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) ! ! The following check is to avoid the generation of negative values ! that can occur in the upper stratosphere and mesosphere ! -! if (qs(i,k) < 0.0_r8) then -! qs(i,k) = 1.0_r8 +! if (qs(i,k) < 0.0_kp) then +! qs(i,k) = 1.0_kp ! es(i,k) = p(i,k) ! end if @@ -291,22 +290,22 @@ subroutine aqsat_water(t, p, es, qs, ii, ilen, kk, kstart,kend) integer, intent(in) :: ilen integer, intent(in) :: kstart integer, intent(in) :: kend - real(r8), intent(in) :: t(ii,kk) - real(r8), intent(in) :: p(ii,kk) + real(kp), intent(in) :: t(ii,kk) + real(kp), intent(in) :: p(ii,kk) ! ! Output arguments ! - real(r8), intent(out) :: es(ii,kk) - real(r8), intent(out) :: qs(ii,kk) + real(kp), intent(out) :: es(ii,kk) + real(kp), intent(out) :: qs(ii,kk) ! !---------------------------Local workspace----------------------------- ! - real(r8) omeps + real(kp) omeps integer i, k ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs do k=kstart,kend do i=1,ilen ! es(i,k) = estblf(t(i,k)) @@ -319,13 +318,13 @@ subroutine aqsat_water(t, p, es, qs, ii, ilen, kk, kstart,kend) ! ! Saturation specific humidity ! - qs(i,k) = min(1.0_r8, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) + qs(i,k) = min(1.0_kp, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) ! ! The following check is to avoid the generation of negative values ! that can occur in the upper stratosphere and mesosphere ! -! if (qs(i,k) < 0.0_r8) then -! qs(i,k) = 1.0_r8 +! if (qs(i,k) < 0.0_kp) then +! qs(i,k) = 1.0_kp ! es(i,k) = p(i,k) ! end if end do @@ -357,48 +356,48 @@ subroutine aqsatd(t, p, es, qs, gam, ii, ilen, kk, kstart, kend) integer, intent(in) :: kstart integer, intent(in) :: kend - real(r8), intent(in) :: t(ii,kk) - real(r8), intent(in) :: p(ii,kk) + real(kp), intent(in) :: t(ii,kk) + real(kp), intent(in) :: p(ii,kk) ! ! Output arguments ! - real(r8), intent(out) :: es(ii,kk) - real(r8), intent(out) :: qs(ii,kk) - real(r8), intent(out) :: gam(ii,kk) + real(kp), intent(out) :: es(ii,kk) + real(kp), intent(out) :: qs(ii,kk) + real(kp), intent(out) :: gam(ii,kk) ! !---------------------------Local workspace----------------------------- ! logical lflg integer i integer k - real(r8) omeps - real(r8) trinv - real(r8) tc - real(r8) weight - real(r8) hltalt - real(r8) hlatsb - real(r8) hlatvp - real(r8) tterm - real(r8) desdt + real(kp) omeps + real(kp) trinv + real(kp) tc + real(kp) weight + real(kp) hltalt + real(kp) hlatsb + real(kp) hlatvp + real(kp) tterm + real(kp) desdt ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs do k=kstart,kend do i=1,ilen es(i,k) = min(p(i,k), estblf(t(i,k))) ! ! Saturation specific humidity ! - qs(i,k) = min(1.0_r8, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) + qs(i,k) = min(1.0_kp, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) ! ! The following check is to avoid the generation of negative qs ! values which can occur in the upper stratosphere and mesosphere ! ! -! if (qs(i,k) < 0.0_r8) then -! qs(i,k) = 1.0_r8 +! if (qs(i,k) < 0.0_kp) then +! qs(i,k) = 1.0_kp ! es(i,k) = p(i,k) ! end if end do @@ -407,9 +406,9 @@ subroutine aqsatd(t, p, es, qs, gam, ii, ilen, kk, kstart, kend) ! "generalized" analytic expression for t derivative of es ! accurate to within 1 percent for 173.16 < t < 373.16 ! - trinv = 0.0_r8 - if ((.not. icephs) .or. (ttrice == 0.0_r8)) go to 10 - trinv = 1.0_r8/ttrice + trinv = 0.0_kp + if ((.not. icephs) .or. (ttrice == 0.0_kp)) go to 10 + trinv = 1.0_kp/ttrice ! do k=kstart,kend do i=1,ilen @@ -422,10 +421,10 @@ subroutine aqsatd(t, p, es, qs, gam, ii, ilen, kk, kstart, kend) ! above freezing where constant slope is given by -2369 j/(kg c) =cpv - cw ! tc = t(i,k) - tmelt - lflg = (tc >= -ttrice .and. tc < 0.0_r8) - weight = min(-tc*trinv,1.0_r8) + lflg = (tc >= -ttrice .and. tc < 0.0_kp) + weight = min(-tc*trinv,1.0_kp) hlatsb = hlatv + weight*hlatf - hlatvp = hlatv - 2369.0_r8*tc + hlatvp = hlatv - 2369.0_kp*tc if (t(i,k) < tmelt) then hltalt = hlatsb else @@ -435,12 +434,12 @@ subroutine aqsatd(t, p, es, qs, gam, ii, ilen, kk, kstart, kend) tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) & & + tc*pcf(5)))) else - tterm = 0.0_r8 + tterm = 0.0_kp end if desdt = hltalt*es(i,k)/(rgasv*t(i,k)*t(i,k)) + tterm*trinv gam(i,k) = hltalt*qs(i,k)*p(i,k)*desdt/(cp*es(i,k)*(p(i,k) & & - omeps*es(i,k))) - if (qs(i,k) == 1.0_r8) gam(i,k) = 0.0_r8 + if (qs(i,k) == 1.0_kp) gam(i,k) = 0.0_kp end do end do ! @@ -454,7 +453,7 @@ subroutine aqsatd(t, p, es, qs, gam, ii, ilen, kk, kstart, kend) ! Account for change of hlatv with t above freezing where ! constant slope is given by -2369 j/(kg c) = cpv - cw ! - hlatvp = hlatv - 2369.0_r8*(t(i,k)-tmelt) + hlatvp = hlatv - 2369.0_kp*(t(i,k)-tmelt) if (icephs) then hlatsb = hlatv + hlatf else @@ -468,7 +467,7 @@ subroutine aqsatd(t, p, es, qs, gam, ii, ilen, kk, kstart, kend) desdt = hltalt*es(i,k)/(rgasv*t(i,k)*t(i,k)) gam(i,k) = hltalt*qs(i,k)*p(i,k)*desdt/(cp*es(i,k)*(p(i,k) & & - omeps*es(i,k))) - if (qs(i,k) == 1.0_r8) gam(i,k) = 0.0_r8 + if (qs(i,k) == 1.0_kp) gam(i,k) = 0.0_kp end do end do ! @@ -488,14 +487,14 @@ subroutine vqsatd(t ,p ,es ,qs ,gam , len ) ! Input arguments ! integer, intent(in) :: len - real(r8), intent(in) :: t(len) - real(r8), intent(in) :: p(len) + real(kp), intent(in) :: t(len) + real(kp), intent(in) :: p(len) ! ! Output arguments ! - real(r8), intent(out) :: es(len) - real(r8), intent(out) :: qs(len) - real(r8), intent(out) :: gam(len) + real(kp), intent(out) :: es(len) + real(kp), intent(out) :: qs(len) + real(kp), intent(out) :: gam(len) ! !--------------------------Local Variables------------------------------ ! @@ -503,20 +502,20 @@ subroutine vqsatd(t ,p ,es ,qs ,gam , len ) ! integer i ! - real(r8) omeps - real(r8) trinv - real(r8) tc - real(r8) weight - real(r8) hltalt + real(kp) omeps + real(kp) trinv + real(kp) tc + real(kp) weight + real(kp) hltalt ! - real(r8) hlatsb - real(r8) hlatvp - real(r8) tterm - real(r8) desdt + real(kp) hlatsb + real(kp) hlatvp + real(kp) tterm + real(kp) desdt ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs do i=1,len es(i) = min(estblf(t(i)), p(i)) ! @@ -527,10 +526,10 @@ subroutine vqsatd(t ,p ,es ,qs ,gam , len ) ! The following check is to avoid the generation of negative ! values that can occur in the upper stratosphere and mesosphere ! - qs(i) = min(1.0_r8,qs(i)) + qs(i) = min(1.0_kp,qs(i)) ! -! if (qs(i) < 0.0_r8) then -! qs(i) = 1.0_r8 +! if (qs(i) < 0.0_kp) then +! qs(i) = 1.0_kp ! es(i) = p(i) ! end if @@ -539,9 +538,9 @@ subroutine vqsatd(t ,p ,es ,qs ,gam , len ) ! "generalized" analytic expression for t derivative of es ! accurate to within 1 percent for 173.16 < t < 373.16 ! - trinv = 0.0_r8 - if ((.not. icephs) .or. (ttrice.eq.0.0_r8)) go to 10 - trinv = 1.0_r8/ttrice + trinv = 0.0_kp + if ((.not. icephs) .or. (ttrice.eq.0.0_kp)) go to 10 + trinv = 1.0_kp/ttrice do i=1,len ! ! Weighting of hlat accounts for transition from water to ice @@ -552,10 +551,10 @@ subroutine vqsatd(t ,p ,es ,qs ,gam , len ) ! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw ! tc = t(i) - tmelt - lflg = (tc >= -ttrice .and. tc < 0.0_r8) - weight = min(-tc*trinv,1.0_r8) + lflg = (tc >= -ttrice .and. tc < 0.0_kp) + weight = min(-tc*trinv,1.0_kp) hlatsb = hlatv + weight*hlatf - hlatvp = hlatv - 2369.0_r8*tc + hlatvp = hlatv - 2369.0_kp*tc if (t(i) < tmelt) then hltalt = hlatsb else @@ -565,11 +564,11 @@ subroutine vqsatd(t ,p ,es ,qs ,gam , len ) tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) & & + tc*pcf(5)))) else - tterm = 0.0_r8 + tterm = 0.0_kp end if desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + tterm*trinv gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) - if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + if (qs(i) == 1.0_kp) gam(i) = 0.0_kp end do return ! @@ -580,7 +579,7 @@ subroutine vqsatd(t ,p ,es ,qs ,gam , len ) ! Account for change of hlatv with t above freezing where ! constant slope is given by -2369 j/(kg c) = cpv - cw ! - hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) + hlatvp = hlatv - 2369.0_kp*(t(i)-tmelt) if (icephs) then hlatsb = hlatv + hlatf else @@ -593,7 +592,7 @@ subroutine vqsatd(t ,p ,es ,qs ,gam , len ) end if desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) - if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + if (qs(i) == 1.0_kp) gam(i) = 0.0_kp end do ! return @@ -610,15 +609,15 @@ subroutine vqsatd_water(t, p, es, qs, gam, len) ! Input arguments ! integer, intent(in) :: len - real(r8), intent(in) :: t(len) - real(r8), intent(in) :: p(len) + real(kp), intent(in) :: t(len) + real(kp), intent(in) :: p(len) ! ! Output arguments ! - real(r8), intent(out) :: es(len) - real(r8), intent(out) :: qs(len) - real(r8), intent(out) :: gam(len) + real(kp), intent(out) :: es(len) + real(kp), intent(out) :: qs(len) + real(kp), intent(out) :: gam(len) ! !--------------------------Local Variables------------------------------ @@ -626,16 +625,16 @@ subroutine vqsatd_water(t, p, es, qs, gam, len) ! integer i ! - real(r8) omeps - real(r8) hltalt + real(kp) omeps + real(kp) hltalt ! - real(r8) hlatsb - real(r8) hlatvp - real(r8) desdt + real(kp) hlatsb + real(kp) hlatvp + real(kp) desdt ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs do i=1,len #ifdef NEMS_GSM es(i) = min(fpvsl(t(i)), p(i)) @@ -645,15 +644,15 @@ subroutine vqsatd_water(t, p, es, qs, gam, len) ! ! Saturation specific humidity ! - qs(i) = min(1.0_r8, epsqs*es(i) / (p(i)-omeps*es(i))) + qs(i) = min(1.0_kp, epsqs*es(i) / (p(i)-omeps*es(i))) ! ! The following check is to avoid the generation of negative ! values that can occur in the upper stratosphere and mesosphere ! -! qs(i) = min(1.0_r8,qs(i)) +! qs(i) = min(1.0_kp,qs(i)) ! -! if (qs(i) < 0.0_r8) then -! qs(i) = 1.0_r8 +! if (qs(i) < 0.0_kp) then +! qs(i) = 1.0_kp ! es(i) = p(i) ! end if @@ -666,7 +665,7 @@ subroutine vqsatd_water(t, p, es, qs, gam, len) ! Account for change of hlatv with t above freezing where ! constant slope is given by -2369 j/(kg c) = cpv - cw ! - hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) + hlatvp = hlatv - 2369.0_kp*(t(i)-tmelt) hlatsb = hlatv if (t(i) < tmelt) then hltalt = hlatsb @@ -675,7 +674,7 @@ subroutine vqsatd_water(t, p, es, qs, gam, len) end if desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) - if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + if (qs(i) == 1.0_kp) gam(i) = 0.0_kp end do ! return @@ -693,9 +692,9 @@ function polysvp (T,typ) !!DONIFF Changed to Murphy and Koop (2005) (03/04/14) - real(r8) dum + real(kp) dum - real(r8) t,polysvp + real(kp) t,polysvp integer typ @@ -716,19 +715,19 @@ function polysvp (T,typ) - polysvp = 10._r8**(-9.09718_r8*(273.16_r8/t-1._r8)-3.56654_r8* & - & log10(273.16_r8/t)+0.876793_r8*(1._r8-t/273.16_r8)+ & - & log10(6.1071_r8))*100._r8 + polysvp = 10._kp**(-9.09718_kp*(273.16_kp/t-1._kp)-3.56654_kp* & + & log10(273.16_kp/t)+0.876793_kp*(1._kp-t/273.16_kp)+ & + & log10(6.1071_kp))*100._kp end if if (typ.eq.0) then - polysvp = 10._r8**(-7.90298_r8*(373.16_r8/t-1._r8)+ 5.02808_r8* & - &log10(373.16_r8/t)- 1.3816e-7_r8*(10._r8**(11.344_r8*(1._r8-t/ & - &373.16_r8))-1._r8)+ 8.1328e-3_r8*(10._r8**(-3.49149_r8*(373.16_r8/ & - &t-1._r8))-1._r8)+ log10(1013.246_r8))*100._r8 + polysvp = 10._kp**(-7.90298_kp*(373.16_kp/t-1._kp)+ 5.02808_kp* & + &log10(373.16_kp/t)- 1.3816e-7_kp*(10._kp**(11.344_kp*(1._kp-t/ & + &373.16_kp))-1._kp)+ 8.1328e-3_kp*(10._kp**(-3.49149_kp*(373.16_kp/ & + &t-1._kp))-1._kp)+ log10(1013.246_kp))*100._kp end if end if @@ -745,40 +744,40 @@ integer function fqsatd(t ,p ,es ,qs ,gam , len ) integer, intent(in) :: len - real(r8), intent(in) :: t(len) - real(r8), intent(in) :: p(len) + real(kp), intent(in) :: t(len) + real(kp), intent(in) :: p(len) - real(r8), intent(out) :: es(len) - real(r8), intent(out) :: qs(len) - real(r8), intent(out) :: gam(len) + real(kp), intent(out) :: es(len) + real(kp), intent(out) :: qs(len) + real(kp), intent(out) :: gam(len) call vqsatd(t ,p ,es ,qs ,gam , len ) fqsatd = 1 return end function fqsatd - real(r8) function qsat_water(t,p) + real(kp) function qsat_water(t,p) - real(r8) t - real(r8) p - real(r8) es - real(r8) ps, ts, e1, e2, f1, f2, f3, f4, f5, f + real(kp) t + real(kp) p + real(kp) es + real(kp) ps, ts, e1, e2, f1, f2, f3, f4, f5, f - ps = 1013.246_r8 - ts = 373.16_r8 - e1 = 11.344_r8*(1.0_r8 - t/ts) - e2 = -3.49149_r8*(ts/t - 1.0_r8) - f1 = -7.90298_r8*(ts/t - 1.0_r8) - f2 = 5.02808_r8*log10(ts/t) - f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8 - f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8 + ps = 1013.246_kp + ts = 373.16_kp + e1 = 11.344_kp*(1.0_kp - t/ts) + e2 = -3.49149_kp*(ts/t - 1.0_kp) + f1 = -7.90298_kp*(ts/t - 1.0_kp) + f2 = 5.02808_kp*log10(ts/t) + f3 = -1.3816_kp*(10.0_kp**e1 - 1.0_kp)/10000000.0_kp + f4 = 8.1328_kp*(10.0_kp**e2 - 1.0_kp)/1000.0_kp f5 = log10(ps) f = f1 + f2 + f3 + f4 + f5 - es = (10.0_r8**f)*100.0_r8 + es = (10.0_kp**f)*100.0_kp qsat_water = epsqs*es/(p-(1.-epsqs)*es) if(qsat_water < 0.) qsat_water = 1. @@ -790,17 +789,17 @@ end function qsat_water subroutine vqsat_water(t,p,qsat_water,len) integer, intent(in) :: len - real(r8) t(len) - real(r8) p(len) - real(r8) qsat_water(len) - real(r8) es - real(r8), parameter :: t0inv = 1._r8/273._r8 - real(r8) coef + real(kp) t(len) + real(kp) p(len) + real(kp) qsat_water(len) + real(kp) es + real(kp), parameter :: t0inv = 1._kp/273._kp + real(kp) coef integer :: i coef = hlatv/rgasv do i=1,len - es = 611._r8*exp(coef*(t0inv-1./t(i))) + es = 611._kp*exp(coef*(t0inv-1./t(i))) qsat_water(i) = epsqs*es/(p(i)-(1.-epsqs)*es) if(qsat_water(i) < 0.) qsat_water(i) = 1. enddo @@ -810,12 +809,12 @@ subroutine vqsat_water(t,p,qsat_water,len) end subroutine vqsat_water !>\ingroup wv_saturation_mod - real(r8) function qsat_ice(t,p) + real(kp) function qsat_ice(t,p) - real(r8) t - real(r8) p - real(r8) es - real(r8), parameter :: t0inv = 1._r8/273._r8 + real(kp) t + real(kp) p + real(kp) es + real(kp), parameter :: t0inv = 1._kp/273._kp es = 611.*exp((hlatv+hlatf)/rgasv*(t0inv-1./t)) qsat_ice = epsqs*es/(p-(1.-epsqs)*es) if(qsat_ice < 0.) qsat_ice = 1. @@ -826,12 +825,12 @@ end function qsat_ice subroutine vqsat_ice(t,p,qsat_ice,len) integer,intent(in) :: len - real(r8) t(len) - real(r8) p(len) - real(r8) qsat_ice(len) - real(r8) es - real(r8), parameter :: t0inv = 1._r8/273._r8 - real(r8) coef + real(kp) t(len) + real(kp) p(len) + real(kp) qsat_ice(len) + real(kp) es + real(kp), parameter :: t0inv = 1._kp/273._kp + real(kp) coef integer :: i coef = (hlatv+hlatf)/rgasv @@ -858,17 +857,17 @@ subroutine vqsatd2_water(t ,p ,es ,qs ,dqsdt , len ) ! Input arguments ! integer, intent(in) :: len - real(r8), intent(in) :: t(len) - real(r8), intent(in) :: p(len) + real(kp), intent(in) :: t(len) + real(kp), intent(in) :: p(len) ! ! Output arguments ! - real(r8), intent(out) :: es(len) - real(r8), intent(out) :: qs(len) + real(kp), intent(out) :: es(len) + real(kp), intent(out) :: qs(len) - real(r8), intent(out) :: dqsdt(len) + real(kp), intent(out) :: dqsdt(len) ! @@ -877,21 +876,21 @@ subroutine vqsatd2_water(t ,p ,es ,qs ,dqsdt , len ) ! integer i ! - real(r8) omeps - real(r8) hltalt + real(kp) omeps + real(kp) hltalt ! - real(r8) hlatsb - real(r8) hlatvp - real(r8) desdt + real(kp) hlatsb + real(kp) hlatvp + real(kp) desdt - real(r8) gam(len) + real(kp) gam(len) ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs do i=1,len #ifdef GEOS5 es(i) = min(polysvp(t(i),0), p(i)) @@ -907,10 +906,10 @@ subroutine vqsatd2_water(t ,p ,es ,qs ,dqsdt , len ) ! The following check is to avoid the generation of negative ! values that can occur in the upper stratosphere and mesosphere ! - qs(i) = min(1.0_r8,qs(i)) + qs(i) = min(1.0_kp,qs(i)) ! -! if (qs(i) < 0.0_r8) then -! qs(i) = 1.0_r8 +! if (qs(i) < 0.0_kp) then +! qs(i) = 1.0_kp ! es(i) = p(i) ! end if @@ -923,7 +922,7 @@ subroutine vqsatd2_water(t ,p ,es ,qs ,dqsdt , len ) ! Account for change of hlatv with t above freezing where ! constant slope is given by -2369 j/(kg c) = cpv - cw ! - hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) + hlatvp = hlatv - 2369.0_kp*(t(i)-tmelt) hlatsb = hlatv if (t(i) < tmelt) then hltalt = hlatsb @@ -932,7 +931,7 @@ subroutine vqsatd2_water(t ,p ,es ,qs ,dqsdt , len ) end if desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) - if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + if (qs(i) == 1.0_kp) gam(i) = 0.0_kp dqsdt(i) = (cp/hltalt)*gam(i) @@ -950,22 +949,22 @@ subroutine vqsatd2_water_single(t ,p ,es ,qs ,dqsdt) ! Input arguments ! - real(r8), intent(in) :: t, p + real(kp), intent(in) :: t, p ! ! Output arguments ! - real(r8), intent(out) :: es, qs, dqsdt + real(kp), intent(out) :: es, qs, dqsdt ! !--------------------------Local Variables------------------------------ ! ! integer i ! - real(r8) omeps, hltalt, hlatsb, hlatvp, desdt, gam + real(kp) omeps, hltalt, hlatsb, hlatvp, desdt, gam ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs ! do i=1,len #ifdef GEOS5 es = min(p, polysvp(t,0)) @@ -976,13 +975,13 @@ subroutine vqsatd2_water_single(t ,p ,es ,qs ,dqsdt) ! ! Saturation specific humidity ! - qs = min(1.0_r8, epsqs*es/(p-omeps*es)) + qs = min(1.0_kp, epsqs*es/(p-omeps*es)) ! ! The following check is to avoid the generation of negative ! values that can occur in the upper stratosphere and mesosphere ! -! if (qs < 0.0_r8) then -! qs = 1.0_r8 +! if (qs < 0.0_kp) then +! qs = 1.0_kp ! es = p ! end if ! end do @@ -994,7 +993,7 @@ subroutine vqsatd2_water_single(t ,p ,es ,qs ,dqsdt) ! Account for change of hlatv with t above freezing where ! constant slope is given by -2369 j/(kg c) = cpv - cw ! - hlatvp = hlatv - 2369.0_r8*(t-tmelt) + hlatvp = hlatv - 2369.0_kp*(t-tmelt) hlatsb = hlatv if (t < tmelt) then hltalt = hlatsb @@ -1003,7 +1002,7 @@ subroutine vqsatd2_water_single(t ,p ,es ,qs ,dqsdt) end if desdt = hltalt*es/(rgasv*t*t) gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es)) - if (qs >= 1.0_r8) gam = 0.0_r8 + if (qs >= 1.0_kp) gam = 0.0_kp dqsdt = (cp/hltalt)*gam @@ -1035,16 +1034,16 @@ subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) ! Input arguments ! integer, intent(in) :: len - real(r8), intent(in) :: t(len) - real(r8), intent(in) :: p(len) + real(kp), intent(in) :: t(len) + real(kp), intent(in) :: p(len) ! ! Output arguments ! - real(r8), intent(out) :: es(len) - real(r8), intent(out) :: qs(len) + real(kp), intent(out) :: es(len) + real(kp), intent(out) :: qs(len) - real(r8), intent(out) :: dqsdt(len) + real(kp), intent(out) :: dqsdt(len) ! @@ -1054,24 +1053,24 @@ subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) ! integer i ! - real(r8) omeps - real(r8) trinv - real(r8) tc - real(r8) weight - real(r8) hltalt + real(kp) omeps + real(kp) trinv + real(kp) tc + real(kp) weight + real(kp) hltalt ! - real(r8) hlatsb - real(r8) hlatvp - real(r8) tterm - real(r8) desdt + real(kp) hlatsb + real(kp) hlatvp + real(kp) tterm + real(kp) desdt - real(r8) gam(len) + real(kp) gam(len) ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs do i=1,len #ifdef GEOS5 es(i) = min(p(i), estblf(t(i))) @@ -1087,10 +1086,10 @@ subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) ! The following check is to avoid the generation of negative ! values that can occur in the upper stratosphere and mesosphere ! - qs(i) = min(1.0_r8,qs(i)) + qs(i) = min(1.0_kp,qs(i)) ! -! if (qs(i) < 0.0_r8) then -! qs(i) = 1.0_r8 +! if (qs(i) < 0.0_kp) then +! qs(i) = 1.0_kp ! es(i) = p(i) ! end if end do @@ -1098,9 +1097,9 @@ subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) ! "generalized" analytic expression for t derivative of es ! accurate to within 1 percent for 173.16 < t < 373.16 ! - trinv = 0.0_r8 - if ((.not. icephs) .or. (ttrice == 0.0_r8)) go to 10 - trinv = 1.0_r8/ttrice + trinv = 0.0_kp + if ((.not. icephs) .or. (ttrice == 0.0_kp)) go to 10 + trinv = 1.0_kp/ttrice do i=1,len ! ! Weighting of hlat accounts for transition from water to ice @@ -1111,10 +1110,10 @@ subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) ! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw ! tc = t(i) - tmelt - lflg = (tc >= -ttrice .and. tc < 0.0_r8) - weight = min(-tc*trinv,1.0_r8) + lflg = (tc >= -ttrice .and. tc < 0.0_kp) + weight = min(-tc*trinv,1.0_kp) hlatsb = hlatv + weight*hlatf - hlatvp = hlatv - 2369.0_r8*tc + hlatvp = hlatv - 2369.0_kp*tc if (t(i) < tmelt) then hltalt = hlatsb else @@ -1124,11 +1123,11 @@ subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) & & + tc*pcf(5)))) else - tterm = 0.0_r8 + tterm = 0.0_kp end if desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + tterm*trinv gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) - if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + if (qs(i) == 1.0_kp) gam(i) = 0.0_kp dqsdt(i) = (cp/hltalt)*gam(i) @@ -1142,7 +1141,7 @@ subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) ! Account for change of hlatv with t above freezing where ! constant slope is given by -2369 j/(kg c) = cpv - cw ! - hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) + hlatvp = hlatv - 2369.0_kp*(t(i)-tmelt) if (icephs) then hlatsb = hlatv + hlatf else @@ -1155,7 +1154,7 @@ subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) end if desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) - if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + if (qs(i) == 1.0_kp) gam(i) = 0.0_kp dqsdt(i) = (cp/hltalt)*gam(i) @@ -1189,11 +1188,11 @@ subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) ! ! Input arguments ! - real(r8), intent(in) :: t, p + real(kp), intent(in) :: t, p ! ! Output arguments ! - real(r8), intent(out) :: es, qs, dqsdt + real(kp), intent(out) :: es, qs, dqsdt ! !--------------------------Local Variables------------------------------ ! @@ -1201,23 +1200,23 @@ subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) ! ! integer i ! index for vector calculations ! - real(r8) omeps - real(r8) trinv - real(r8) tc - real(r8) weight - real(r8) hltalt + real(kp) omeps + real(kp) trinv + real(kp) tc + real(kp) weight + real(kp) hltalt ! - real(r8) hlatsb - real(r8) hlatvp - real(r8) tterm - real(r8) desdt + real(kp) hlatsb + real(kp) hlatvp + real(kp) tterm + real(kp) desdt - real(r8) gam + real(kp) gam ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs ! do i=1,len @@ -1235,10 +1234,10 @@ subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) ! The following check is to avoid the generation of negative ! values that can occur in the upper stratosphere and mesosphere ! - qs = min(1.0_r8,qs) + qs = min(1.0_kp,qs) ! -! if (qs < 0.0_r8) then -! qs = 1.0_r8 +! if (qs < 0.0_kp) then +! qs = 1.0_kp ! es = p ! end if @@ -1247,9 +1246,9 @@ subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) ! "generalized" analytic expression for t derivative of es ! accurate to within 1 percent for 173.16 < t < 373.16 ! - trinv = 0.0_r8 - if ((.not. icephs) .or. (ttrice == 0.0_r8)) go to 10 - trinv = 1.0_r8/ttrice + trinv = 0.0_kp + if ((.not. icephs) .or. (ttrice == 0.0_kp)) go to 10 + trinv = 1.0_kp/ttrice ! do i=1,len ! @@ -1261,10 +1260,10 @@ subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) ! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw ! tc = t - tmelt - lflg = (tc >= -ttrice .and. tc < 0.0_r8) - weight = min(-tc*trinv,1.0_r8) + lflg = (tc >= -ttrice .and. tc < 0.0_kp) + weight = min(-tc*trinv,1.0_kp) hlatsb = hlatv + weight*hlatf - hlatvp = hlatv - 2369.0_r8*tc + hlatvp = hlatv - 2369.0_kp*tc if (t < tmelt) then hltalt = hlatsb else @@ -1274,11 +1273,11 @@ subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) & & + tc*pcf(5)))) else - tterm = 0.0_r8 + tterm = 0.0_kp end if desdt = hltalt*es/(rgasv*t*t) + tterm*trinv gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es)) - if (qs == 1.0_r8) gam = 0.0_r8 + if (qs == 1.0_kp) gam = 0.0_kp dqsdt = (cp/hltalt)*gam @@ -1295,7 +1294,7 @@ subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) ! Account for change of hlatv with t above freezing where ! constant slope is given by -2369 j/(kg c) = cpv - cw ! - hlatvp = hlatv - 2369.0_r8*(t-tmelt) + hlatvp = hlatv - 2369.0_kp*(t-tmelt) if (icephs) then hlatsb = hlatv + hlatf else @@ -1308,7 +1307,7 @@ subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) end if desdt = hltalt*es/(rgasv*t*t) gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es)) - if (qs == 1.0_r8) gam = 0.0_r8 + if (qs == 1.0_kp) gam = 0.0_kp dqsdt = (cp/hltalt)*gam @@ -1360,33 +1359,33 @@ subroutine gffgch(t ,es ,tmelt ,itype ) ! ! Input arguments ! - real(r8), intent(in) :: t ,tmelt + real(kp), intent(in) :: t ,tmelt ! ! Output arguments ! integer, intent(inout) :: itype - real(r8), intent(out) :: es + real(kp), intent(out) :: es ! !---------------------------Local variables----------------------------- ! - real(r8) e1 - real(r8) e2 - real(r8) eswtr - real(r8) f - real(r8) f1 - real(r8) f2 - real(r8) f3 - real(r8) f4 - real(r8) f5 - real(r8) ps - real(r8) t0 - real(r8) term1 - real(r8) term2 - real(r8) term3 - real(r8) tr - real(r8) ts - real(r8) weight + real(kp) e1 + real(kp) e2 + real(kp) eswtr + real(kp) f + real(kp) f1 + real(kp) f2 + real(kp) f3 + real(kp) f4 + real(kp) f5 + real(kp) ps + real(kp) t0 + real(kp) term1 + real(kp) term2 + real(kp) term3 + real(kp) tr + real(kp) ts + real(kp) weight integer itypo ! !----------------------------------------------------------------------- @@ -1394,14 +1393,14 @@ subroutine gffgch(t ,es ,tmelt ,itype ) ! Check on whether there is to be a transition region for es ! if (itype < 0) then - tr = abs(real(itype,r8)) + tr = abs(real(itype,kp)) itypo = itype itype = 1 else - tr = 0.0_r8 + tr = 0.0_kp itypo = itype end if - if (tr > 40.0_r8) then + if (tr > 40.0_kp) then write(iulog,900) tr end if @@ -1410,17 +1409,17 @@ subroutine gffgch(t ,es ,tmelt ,itype ) ! ! Water ! - ps = 1013.246_r8 - ts = 373.16_r8 - e1 = 11.344_r8*(1.0_r8 - t/ts) - e2 = -3.49149_r8*(ts/t - 1.0_r8) - f1 = -7.90298_r8*(ts/t - 1.0_r8) - f2 = 5.02808_r8*log10(ts/t) - f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8 - f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8 + ps = 1013.246_kp + ts = 373.16_kp + e1 = 11.344_kp*(1.0_kp - t/ts) + e2 = -3.49149_kp*(ts/t - 1.0_kp) + f1 = -7.90298_kp*(ts/t - 1.0_kp) + f2 = 5.02808_kp*log10(ts/t) + f3 = -1.3816_kp*(10.0_kp**e1 - 1.0_kp)/10000000.0_kp + f4 = 8.1328_kp*(10.0_kp**e2 - 1.0_kp)/1000.0_kp f5 = log10(ps) f = f1 + f2 + f3 + f4 + f5 - es = (10.0_r8**f)*100.0_r8 + es = (10.0_kp**f)*100.0_kp eswtr = es ! if(t >= tmelt .or. itype == 0) go to 20 @@ -1429,17 +1428,17 @@ subroutine gffgch(t ,es ,tmelt ,itype ) ! 10 continue t0 = tmelt - term1 = 2.01889049_r8/(t0/t) - term2 = 3.56654_r8*log(t0/t) - term3 = 20.947031_r8*(t0/t) - es = 575.185606e10_r8*exp(-(term1 + term2 + term3)) + term1 = 2.01889049_kp/(t0/t) + term2 = 3.56654_kp*log(t0/t) + term3 = 20.947031_kp*(t0/t) + es = 575.185606e10_kp*exp(-(term1 + term2 + term3)) ! if (t < (tmelt - tr)) go to 20 ! ! Weighted transition between water and ice ! - weight = min((tmelt - t)/tr,1.0_r8) - es = weight*es + (1.0_r8 - weight)*eswtr + weight = min((tmelt - t)/tr,1.0_kp) + es = weight*es + (1.0_kp - weight)*eswtr ! 20 continue itype = itypo @@ -1455,31 +1454,31 @@ end subroutine gffgch !>\ingroup wv_saturation_mod !!DONIF USe Murphy and Koop (2005) (Written by Andrew Gettelman) function MurphyKoop_svp_water(tx) result(es) - real(r8), intent(in) :: tx - real(r8) :: es - real(r8):: t + real(kp), intent(in) :: tx + real(kp) :: es + real(kp):: t - t=min(tx, 332.0_r8) - t=max(123.0_r8, tx) + t=min(tx, 332.0_kp) + t=max(123.0_kp, tx) - es = exp(54.842763_r8 - (6763.22_r8 / t) - (4.210_r8 * log(t)) + & - & (0.000367_r8 * t) + (tanh(0.0415_r8 * (t - 218.8_r8)) * & - & (53.878_r8 - (1331.22_r8 / t) - (9.44523_r8 * log(t)) + & - & 0.014025_r8 * t))) + es = exp(54.842763_kp - (6763.22_kp / t) - (4.210_kp * log(t)) + & + & (0.000367_kp * t) + (tanh(0.0415_kp * (t - 218.8_kp)) * & + & (53.878_kp - (1331.22_kp / t) - (9.44523_kp * log(t)) + & + & 0.014025_kp * t))) end function MurphyKoop_svp_water function MurphyKoop_svp_ice(tx) result(es) - real(r8), intent(in) :: tx - real(r8) :: t - real(r8) :: es + real(kp), intent(in) :: tx + real(kp) :: t + real(kp) :: es - t=max(100.0_r8, tx) - t=min(274.0_r8, tx) + t=max(100.0_kp, tx) + t=min(274.0_kp, tx) - es = exp(9.550426_r8 - (5723.265_r8 / t) + (3.53068_r8 * & - & log(t)) - (0.00728332_r8 * t)) + es = exp(9.550426_kp - (5723.265_kp / t) + (3.53068_kp * & + & log(t)) - (0.00728332_kp * t)) end function MurphyKoop_svp_ice !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1490,22 +1489,22 @@ subroutine vqsatd2_ice_single(t ,p ,es ,qs ,dqsdt) ! ! Input arguments ! - real(r8), intent(in) :: t, p + real(kp), intent(in) :: t, p ! ! Output arguments ! - real(r8), intent(out) :: es, qs, dqsdt + real(kp), intent(out) :: es, qs, dqsdt ! !--------------------------Local Variables------------------------------ ! ! integer i ! - real(r8) omeps, hltalt, hlatsb, hlatvp, desdt, gam + real(kp) omeps, hltalt, hlatsb, hlatvp, desdt, gam ! !----------------------------------------------------------------------- ! - omeps = 1.0_r8 - epsqs + omeps = 1.0_kp - epsqs ! do i=1,len #ifdef GEOS5 es = min(polysvp(t,1),p) @@ -1516,13 +1515,13 @@ subroutine vqsatd2_ice_single(t ,p ,es ,qs ,dqsdt) ! ! Saturation specific humidity ! - qs = min(1.0_r8, epsqs*es/(p-omeps*es)) + qs = min(1.0_kp, epsqs*es/(p-omeps*es)) ! ! The following check is to avoid the generation of negative ! values that can occur in the upper stratosphere and mesosphere ! -! if (qs < 0.0_r8) then -! qs = 1.0_r8 +! if (qs < 0.0_kp) then +! qs = 1.0_kp ! es = p ! end if ! end do @@ -1536,10 +1535,10 @@ subroutine vqsatd2_ice_single(t ,p ,es ,qs ,dqsdt) ! hltalt = hlatv + hlatf desdt = hltalt*es/(rgasv*t*t) - if (qs < 1.0_r8) then + if (qs < 1.0_kp) then gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es)) else - gam = 0.0_r8 + gam = 0.0_kp endif dqsdt = (cp/hltalt)*gam diff --git a/physics/ysuvdif.F90 b/physics/ysuvdif.F90 index 51ed599f0..75c0b31d3 100644 --- a/physics/ysuvdif.F90 +++ b/physics/ysuvdif.F90 @@ -33,7 +33,9 @@ subroutine ysuvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & landmask,heat,evap,wspd,br, & g,rd,cp,rv,ep1,ep2,xlv, & dusfc,dvsfc,dtsfc,dqsfc, & - dt,kpbl1d,u10,v10,errmsg,errflg ) + dt,kpbl1d,u10,v10,lssav,ldiag3d,qdiag3d, & + flag_for_pbl_generic_tend,ntoz,du3dt_PBL,dv3dt_PBL, & + dt3dt_PBL,dq3dt_PBL,do3dt_PBL,errmsg,errflg ) use machine , only : kind_phys ! @@ -59,7 +61,7 @@ subroutine ysuvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & ! !------------------------------------------------------------------------------------- ! input variables - integer, intent(in ) :: im,km,ntrac,ndiff,ntcw,ntiw + integer, intent(in ) :: im,km,ntrac,ndiff,ntcw,ntiw,ntoz real(kind=kind_phys), intent(in ) :: g,cp,rd,rv,ep1,ep2,xlv,dt real(kind=kind_phys), dimension( im,km ), & @@ -76,6 +78,8 @@ subroutine ysuvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & u10,v10,xmu integer, dimension(im) ,& intent(in ) :: landmask + logical, intent(in ) :: lssav, ldiag3d, qdiag3d, & + flag_for_pbl_generic_tend ! !---------------------------------------------------------------------------------- ! input/output variables @@ -84,6 +88,8 @@ subroutine ysuvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & intent(inout) :: utnp,vtnp,ttnp real(kind=kind_phys), dimension( im,km,ntrac ) , & intent(inout) :: qtnp + real(kind=kind_phys), dimension(im,km) , & + intent(inout) :: du3dt_PBL, dv3dt_PBL, dt3dt_PBL, dq3dt_PBL, do3dt_PBL ! !--------------------------------------------------------------------------------- ! output variables @@ -847,6 +853,14 @@ subroutine ysuvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k) enddo enddo + if(lssav .and. ldiag3d .and. .not. flag_for_pbl_generic_tend) then + do k = km,1,-1 + do i = 1,im + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + dt3dt_PBL(i,k) = dt3dt_PBL(i,k) + ttend*dtstep + enddo + enddo + endif ! ! compute tridiagonal matrix elements for moisture, clouds, and gases ! @@ -955,6 +969,14 @@ subroutine ysuvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) enddo enddo + if(lssav .and. ldiag3d .and. qdiag3d .and. .not. flag_for_pbl_generic_tend) then + do k = km,1,-1 + do i = 1,im + qtend = (f3(i,k,1)-qx(i,k,1))*rdt + dq3dt_PBL(i,k) = dq3dt_PBL(i,k) + qtend*dtstep + enddo + enddo + endif ! if(ndiff.ge.2) then do ic = 2,ndiff @@ -965,6 +987,16 @@ subroutine ysuvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & enddo enddo enddo + if(lssav .and. ldiag3d .and. ntoz>0 .and. qdiag3d .and. & + & .not. flag_for_pbl_generic_tend) then + ic = ntoz + do k = km,1,-1 + do i = 1,im + qtend = f3(i,k,ic)-qx(i,k,ic) + do3dt_PBL(i,k) = do3dt_PBL(i,k)+qtend + enddo + enddo + endif endif ! ! compute tridiagonal matrix elements for momentum @@ -1046,6 +1078,16 @@ subroutine ysuvdif_run(im,km,ux,vx,tx,qx,p2d,p2di,pi2d, & dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) enddo enddo + if(lssav .and. ldiag3d .and. .not. flag_for_pbl_generic_tend) then + do k = km,1,-1 + do i = 1,im + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + du3dt_PBL(i,k) = du3dt_PBL(i,k) + utend*dtstep + dv3dt_PBL(i,k) = dv3dt_PBL(i,k) + vtend*dtstep + enddo + enddo + endif ! !---- end of vertical diffusion ! diff --git a/physics/ysuvdif.meta b/physics/ysuvdif.meta index c040233a7..79c7eae32 100644 --- a/physics/ysuvdif.meta +++ b/physics/ysuvdif.meta @@ -1,3 +1,9 @@ +[ccpp-table-properties] + name = ysuvdif + type = scheme + dependencies = machine.F + +######################################################################## [ccpp-arg-table] name = ysuvdif_run type = scheme @@ -425,6 +431,82 @@ kind = kind_phys intent = in optional = F +[lssav] + standard_name = flag_diagnostics + long_name = logical flag for storing diagnostics + units = flag + dimensions = () + type = logical + intent = in +[ldiag3d] + standard_name = flag_diagnostics_3D + long_name = flag for 3d diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[qdiag3d] + standard_name = flag_tracer_diagnostics_3D + long_name = flag for 3d tracer diagnostic fields + units = flag + dimensions = () + type = logical + intent = in +[flag_for_pbl_generic_tend] + standard_name = flag_for_generic_planetary_boundary_layer_tendency + long_name = true if GFS_PBL_generic should calculate tendencies + units = flag + dimensions = () + type = logical + intent = in +[ntoz] + standard_name = index_for_ozone + long_name = tracer index for ozone mixing ratio + units = index + dimensions = () + type = integer + intent = in + optional = F +[du3dt_PBL] + standard_name = cumulative_change_in_x_wind_due_to_PBL + long_name = cumulative change in x wind due to PBL + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dv3dt_PBL] + standard_name = cumulative_change_in_y_wind_due_to_PBL + long_name = cumulative change in y wind due to PBL + units = m s-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dt3dt_PBL] + standard_name = cumulative_change_in_temperature_due_to_PBL + long_name = cumulative change in temperature due to PBL + units = K + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[dq3dt_PBL] + standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL + long_name = cumulative change in water vapor specific humidity due to PBL + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout +[do3dt_PBL] + standard_name = cumulative_change_in_ozone_mixing_ratio_due_to_PBL + long_name = cumulative change in ozone mixing ratio due to PBL + units = kg kg-1 + dimensions = (horizontal_loop_extent,vertical_dimension) + type = real + kind = kind_phys + intent = inout [errmsg] standard_name = ccpp_error_message long_name = error message for error handling in CCPP