From 0e83a92c2e79e3f2fb5894e41efec12ff34be888 Mon Sep 17 00:00:00 2001 From: SMoorthi-emc <47667426+SMoorthi-emc@users.noreply.github.com> Date: Thu, 13 Aug 2020 19:56:05 -0400 Subject: [PATCH 01/13] Update to the two-way WW3 atmosphere coupling. Fractional grid updates (#155) Fixes several bugs in several physics schemes. Adds update to the two-way WW3 atmosphere coupling. Save surface roughness over water, ice and land in three separate variables so that restarts can be reproducible, even for the fractional grid case. Makes uncoupled standalone GFS work with fractional grid. Co-authored-by: Jessica.Meixner Co-authored-by: Dom Heinzeller Co-authored-by: Jun.Wang --- atmos_model.F90 | 139 +- ccpp/physics | 2 +- .../suite_FV3_GFS_cpld_rasmgshocnsst.xml | 90 + gfsphysics/GFS_layer/GFS_physics_driver.F90 | 635 +++--- gfsphysics/GFS_layer/GFS_radiation_driver.F90 | 230 +- gfsphysics/GFS_layer/GFS_typedefs.F90 | 40 +- gfsphysics/GFS_layer/GFS_typedefs.meta | 25 +- gfsphysics/physics/GFS_debug.F90 | 14 +- gfsphysics/physics/dcyc2.f | 2 + gfsphysics/physics/gcm_shoc.f90 | 47 +- gfsphysics/physics/gcycle.F90 | 62 +- gfsphysics/physics/get_prs.f | 102 +- gfsphysics/physics/m_micro_driver.F90 | 495 ++--- gfsphysics/physics/micro_mg3_0.F90 | 18 +- gfsphysics/physics/micro_mg_utils.F90 | 60 +- gfsphysics/physics/module_nst_model.f90 | 2 +- gfsphysics/physics/module_nst_water_prop.f90 | 112 +- gfsphysics/physics/moninshoc.f | 115 +- gfsphysics/physics/rad_initialize.f | 12 +- gfsphysics/physics/radiation_surface.f | 4 +- gfsphysics/physics/rascnvv2.f | 426 ++-- gfsphysics/physics/sfc_cice.f | 50 +- gfsphysics/physics/sfc_diag.f | 9 +- gfsphysics/physics/sfc_diff.f | 196 +- gfsphysics/physics/sfc_drv.f | 88 +- gfsphysics/physics/sfc_ocean.f | 46 +- gfsphysics/physics/sfc_sice.f | 95 +- gfsphysics/physics/sfcsub.F | 1862 +++++++++-------- io/FV3GFS_io.F90 | 407 ++-- 29 files changed, 2971 insertions(+), 2414 deletions(-) create mode 100644 ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml diff --git a/atmos_model.F90 b/atmos_model.F90 index ec8e8a9a4..9b2098c9c 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -220,9 +220,10 @@ module atmos_model_mod logical,parameter :: flip_vc = .true. #endif - real(kind=IPD_kind_phys), parameter :: zero = 0.0_IPD_kind_phys, & - one = 1.0_IPD_kind_phys, & - epsln = 1.0e-10_IPD_kind_phys + real(kind=IPD_kind_phys), parameter :: zero = 0.0_IPD_kind_phys, & + one = 1.0_IPD_kind_phys, & + epsln = 1.0e-10_IPD_kind_phys, & + zorlmin = 1.0e-7_IPD_kind_phys contains @@ -299,13 +300,18 @@ subroutine update_atmos_radiation_physics (Atmos) call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block) !--- if coupled, assign coupled fields + if( IPD_Control%cplflx .or. IPD_Control%cplwav ) then -! print *,'in atmos_model,nblks=',Atm_block%nblks -! print *,'in atmos_model,IPD_Data size=',size(IPD_Data) -! print *,'in atmos_model,tsfc(1)=',IPD_Data(1)%sfcprop%tsfc(1) -! print *,'in atmos_model, tsfc size=',size(IPD_Data(1)%sfcprop%tsfc) + +! if (mpp_pe() == mpp_root_pe() .and. debug) then +! print *,'in atmos_model,nblks=',Atm_block%nblks +! print *,'in atmos_model,IPD_Data size=',size(IPD_Data) +! print *,'in atmos_model,tsfc(1)=',IPD_Data(1)%sfcprop%tsfc(1) +! print *,'in atmos_model, tsfc size=',size(IPD_Data(1)%sfcprop%tsfc) +! endif + call assign_importdata(rc) -! print *,'in atmos_model, after assign_importdata, rc=',rc + endif ! Calculate total non-physics tendencies by substracting old IPD Stateout @@ -881,7 +887,7 @@ subroutine update_atmos_model_state (Atmos) if (mpp_pe() == mpp_root_pe()) write(6,*) ' gfs diags time since last bucket empty: ',time_int/3600.,'hrs' call atmosphere_nggps_diag(Atmos%Time) call FV3GFS_diag_output(Atmos%Time, IPD_DIag, Atm_block, IPD_Control%nx, IPD_Control%ny, & - IPD_Control%levs, 1, 1, 1.d0, time_int, time_intfull, & + IPD_Control%levs, 1, 1, 1.0_IPD_kind_phys, time_int, time_intfull, & IPD_Control%fhswr, IPD_Control%fhlwr) if (nint(IPD_Control%fhzero) > 0) then if (mod(isec,3600*nint(IPD_Control%fhzero)) == 0) diag_time = Atmos%Time @@ -1177,6 +1183,9 @@ subroutine update_atmos_chemistry(state, rc) ntb = size(IPD_Data(1)%IntDiag%duem, dim=2) nte = size(qu, dim=3) do it = 1, min(ntb, nte) +!$OMP parallel do default (none) & +!$OMP shared (it, nj, ni, Atm_block, IPD_Data, qu) & +!$OMP private (j, jb, i, ib, nb, ix) do j = 1, nj jb = j + Atm_block%jsc - 1 do i = 1, ni @@ -1189,17 +1198,22 @@ subroutine update_atmos_chemistry(state, rc) enddo nte = nte - ntb - do it = 1, min(size(IPD_Data(1)%IntDiag%ssem, dim=2), nte) - do j = 1, nj - jb = j + Atm_block%jsc - 1 - do i = 1, ni - ib = i + Atm_block%isc - 1 - nb = Atm_block%blkno(ib,jb) - ix = Atm_block%ixp(ib,jb) - IPD_Data(nb)%IntDiag%ssem(ix,it) = qu(i,j,it+ntb) + if (nte > 0) then + do it = 1, min(size(IPD_Data(1)%IntDiag%ssem, dim=2), nte) +!$OMP parallel do default (none) & +!$OMP shared (it, nj, ni, ntb, Atm_block, IPD_Data, qu) & +!$OMP private (j, jb, i, ib, nb, ix) + do j = 1, nj + jb = j + Atm_block%jsc - 1 + do i = 1, ni + ib = i + Atm_block%isc - 1 + nb = Atm_block%blkno(ib,jb) + ix = Atm_block%ixp(ib,jb) + IPD_Data(nb)%IntDiag%ssem(ix,it) = qu(i,j,it+ntb) + enddo enddo enddo - enddo + endif !--- (c) sedimentation and dry/wet deposition do it = 1, size(qd, dim=3) @@ -1583,8 +1597,9 @@ subroutine assign_importdata(rc) real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: datar42d real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d real(kind=IPD_kind_phys), dimension(:,:), pointer :: datar8 - real(kind=IPD_kind_phys) :: tem + real(kind=IPD_kind_phys) :: tem, ofrac logical found, isFieldCreated, lcpl_fice + real (kind=IPD_kind_phys), parameter :: z0ice=1.1 ! (in cm) ! !------------------------------------------------------------------------------ ! @@ -1607,6 +1622,7 @@ subroutine assign_importdata(rc) found = .false. + isFieldCreated = ESMF_FieldIsCreated(importFields(n), rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return @@ -1663,10 +1679,13 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - tem = 100.0 * max(zero, min(0.1, datar8(i,j))) - IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem + if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > zorlmin) then + tem = 100.0_IPD_kind_phys * min(0.1_IPD_kind_phys, datar8(i,j)) +! IPD_Data(nb)%Coupling%zorlwav_cpl(ix) = tem IPD_Data(nb)%Sfcprop%zorlo(ix) = tem + IPD_Data(nb)%Sfcprop%zorlw(ix) = tem + else + IPD_Data(nb)%Sfcprop%zorlw(ix) = -999.0_IPD_kind_phys endif enddo @@ -1685,8 +1704,9 @@ subroutine assign_importdata(rc) do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) + if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > 150.0) then +! IPD_Data(nb)%Coupling%tisfcin_cpl(ix) = datar8(i,j) + IPD_Data(nb)%Sfcprop%tisfc(ix) = datar8(i,j) endif enddo enddo @@ -1698,17 +1718,14 @@ subroutine assign_importdata(rc) fldname = 'sea_surface_temperature' if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) -! if (mpp_pe() == mpp_root_pe() .and. debug) print *,' for sst', & -! ' fldname=',fldname,' findex=',findex,' importFieldsValid=',importFieldsValid(findex) - if (importFieldsValid(findex)) then !$omp parallel do default(shared) private(i,j,nb,ix) do j=jsc,jec do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%tseain_cpl(ix) = datar8(i,j) + if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero .and. datar8(i,j) > 150.0) then +! IPD_Data(nb)%Coupling%tseain_cpl(ix) = datar8(i,j) IPD_Data(nb)%Sfcprop%tsfco(ix) = datar8(i,j) endif enddo @@ -1723,23 +1740,26 @@ subroutine assign_importdata(rc) if (trim(impfield_name) == trim(fldname)) then findex = QueryFieldList(ImportFieldsList,fldname) if (importFieldsValid(findex)) then - lcpl_fice = .true. -!$omp parallel do default(shared) private(i,j,nb,ix) + lcpl_fice = .true. +!$omp parallel do default(shared) private(i,j,nb,ix,ofrac) do j=jsc,jec do i=isc,iec nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) - IPD_Data(nb)%Coupling%ficein_cpl(ix) = zero + + IPD_Data(nb)%Sfcprop%fice(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = IPD_Data(nb)%Sfcprop%slmsk(ix) - if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%ficein_cpl(ix) = max(zero, min(one, datar8(i,j)/IPD_Data(nb)%Sfcprop%oceanfrac(ix))) !LHS: ice frac wrt water area - if (IPD_Data(nb)%Coupling%ficein_cpl(ix) > one-epsln) IPD_Data(nb)%Coupling%ficein_cpl(ix)=one - if (IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then - if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2. !slmsk=2 crashes in gcycle on partial land points - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4. + ofrac = IPD_Data(nb)%Sfcprop%oceanfrac(ix) + if (ofrac > zero) then + IPD_Data(nb)%Sfcprop%fice(ix) = max(zero, min(one, datar8(i,j)/ofrac)) !LHS: ice frac wrt water area + if (IPD_Data(nb)%Sfcprop%fice(ix) >= IPD_control%min_seaice) then + if (IPD_Data(nb)%Sfcprop%fice(ix) > one-epsln) IPD_Data(nb)%Sfcprop%fice(ix) = one + if (abs(one-ofrac) < epsln) IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys !slmsk=2 crashes in gcycle on partial land points +! IPD_Data(nb)%Sfcprop%slmsk(ix) = 2.0_IPD_kind_phys + IPD_Data(nb)%Coupling%slimskin_cpl(ix) = 4.0_IPD_kind_phys else - IPD_Data(nb)%Coupling%ficein_cpl(ix) = zero - if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) then + IPD_Data(nb)%Sfcprop%fice(ix) = zero + if (abs(one-ofrac) < epsln) then IPD_Data(nb)%Sfcprop%slmsk(ix) = zero IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero end if @@ -1870,7 +1890,8 @@ subroutine assign_importdata(rc) nb = Atm_block%blkno(i,j) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then - IPD_Data(nb)%Coupling%hicein_cpl(ix) = datar8(i,j) +! IPD_Data(nb)%Coupling%hicein_cpl(ix) = datar8(i,j) + IPD_Data(nb)%Sfcprop%hice(ix) = datar8(i,j) endif enddo enddo @@ -1913,16 +1934,25 @@ subroutine assign_importdata(rc) ix = Atm_block%ixp(i,j) if (IPD_Data(nb)%Sfcprop%oceanfrac(ix) > zero) then !if it is ocean or ice get surface temperature from mediator - if(IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then - IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tisfcin_cpl(ix) - IPD_Data(nb)%Sfcprop%fice(ix) = IPD_Data(nb)%Coupling%ficein_cpl(ix) - IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) - IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) + if (IPD_Data(nb)%Sfcprop%fice(ix) >= IPD_control%min_seaice) then + +! if(IPD_Data(nb)%Coupling%ficein_cpl(ix) >= IPD_control%min_seaice) then +! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tisfcin_cpl(ix) +! IPD_Data(nb)%Sfcprop%fice(ix) = IPD_Data(nb)%Coupling%ficein_cpl(ix) +! IPD_Data(nb)%Sfcprop%hice(ix) = IPD_Data(nb)%Coupling%hicein_cpl(ix) +! IPD_Data(nb)%Sfcprop%snowd(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) + + IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = IPD_Data(nb)%Coupling%hsnoin_cpl(ix) & + / max(0.01_IPD_kind_phys, IPD_Data(nb)%Sfcprop%fice(ix)) +! / max(0.01_IPD_kind_phys, IPD_Data(nb)%Coupling%ficein_cpl(ix)) + IPD_Data(nb)%Sfcprop%zorli(ix) = z0ice else - IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) - IPD_Data(nb)%Sfcprop%fice(ix) = zero - IPD_Data(nb)%Sfcprop%hice(ix) = zero - IPD_Data(nb)%Sfcprop%snowd(ix) = zero +! IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Coupling%tseain_cpl(ix) + IPD_Data(nb)%Sfcprop%tisfc(ix) = IPD_Data(nb)%Sfcprop%tsfco(ix) + IPD_Data(nb)%Sfcprop%fice(ix) = zero + IPD_Data(nb)%Sfcprop%hice(ix) = zero +! IPD_Data(nb)%Sfcprop%snowd(ix) = zero + IPD_Data(nb)%Coupling%hsnoin_cpl(ix) = zero ! IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! over open water - should not be used in ATM IPD_Data(nb)%Coupling%dqsfcin_cpl(ix) = -99999.0 ! ,, @@ -1930,8 +1960,10 @@ subroutine assign_importdata(rc) IPD_Data(nb)%Coupling%dvsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%dtsfcin_cpl(ix) = -99999.0 ! ,, IPD_Data(nb)%Coupling%ulwsfcin_cpl(ix) = -99999.0 ! ,, - if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) & - IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero ! 100% open water + if (abs(one-IPD_Data(nb)%Sfcprop%oceanfrac(ix)) < epsln) then ! 100% open water + IPD_Data(nb)%Coupling%slimskin_cpl(ix) = zero + IPD_Data(nb)%Sfcprop%slmsk(ix) = zero + endif endif endif enddo @@ -1947,7 +1979,8 @@ subroutine assign_importdata(rc) ! abs(IPD_Data(nb)%Grid%xlat_d(ix)+58.99) < 0.1) then ! write(0,*)' in assign tisfc=',IPD_Data(nb)%Sfcprop%tisfc(ix), & ! ' oceanfrac=',IPD_Data(nb)%Sfcprop%oceanfrac(ix),' i=',i,' j=',j,& -! ' tisfcin=',IPD_Data(nb)%Coupling%tisfcin_cpl(ix), & +!! ' tisfcin=',IPD_Data(nb)%Coupling%tisfcin_cpl(ix), & +! ' tisfcin=',IPD_Data(nb)%Sfcprop%tisfc(ix), & ! ' fice=',IPD_Data(nb)%Sfcprop%fice(ix) ! endif ! enddo diff --git a/ccpp/physics b/ccpp/physics index 2e3b1cf83..09c4ee333 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 2e3b1cf83dc0c693fb9f25d0805d516e7461fd25 +Subproject commit 09c4ee3335d7e1e1c5433f390db38658aac3525d diff --git a/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml new file mode 100644 index 000000000..5b3b63528 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml @@ -0,0 +1,90 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + lsm_noah + sfc_nst_pre + sfc_nst + sfc_nst_post + sfc_cice + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + moninshoc + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys_2015 + h2ophys + get_phi_fv3 + GFS_suite_interstitial_3 + shoc + GFS_DCNV_generic_pre + GFS_suite_interstitial_5 + rascnv + GFS_DCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + m_micro_pre + m_micro + m_micro_post + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 14911d13f..02eb00e00 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -17,6 +17,7 @@ module module_physics_driver GFS_sfcprop_type, GFS_coupling_type, & GFS_control_type, GFS_grid_type, & GFS_tbd_type, GFS_cldprop_type, & +! GFS_radtend_type, GFS_diag_type GFS_radtend_type, GFS_diag_type, huge use gfdl_cloud_microphys_mod, only: gfdl_cloud_microphys_driver, & cloud_diagnosis @@ -43,23 +44,23 @@ module module_physics_driver !--- CONSTANT PARAMETERS real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp - real(kind=kind_phys), parameter :: epsln = 1.0d-10 - real(kind=kind_phys), parameter :: qmin = 1.0d-10 - real(kind=kind_phys), parameter :: qsmall = 1.0d-20 - real(kind=kind_phys), parameter :: rainmin = 1.0d-13 - real(kind=kind_phys), parameter :: p850 = 85000.0d0 - real(kind=kind_phys), parameter :: epsq = 1.0d-20 + real(kind=kind_phys), parameter :: epsln = 1.0e-10_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-8_kind_phys + real(kind=kind_phys), parameter :: qsmall = 1.0e-20_kind_phys + real(kind=kind_phys), parameter :: rainmin = 1.0e-13_kind_phys + real(kind=kind_phys), parameter :: p850 = 85000.0_kind_phys + real(kind=kind_phys), parameter :: epsq = 1.0e-20_kind_phys real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus - real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0, & - half = 0.5d0, onebg = one/con_g - real(kind=kind_phys), parameter :: albdf = 0.06d0 - real(kind=kind_phys), parameter :: tf=258.16d0, tcr=273.16d0, tcrf=1.0/(tcr-tf) - real(kind=kind_phys), parameter :: con_p001= 0.001d0 - real(kind=kind_phys), parameter :: con_d00 = 0.0d0 - real(kind=kind_phys), parameter :: con_day = 86400.0d0 - real(kind=kind_phys), parameter :: rad2dg = 180.0d0/con_pi - real(kind=kind_phys), parameter :: omz1 = 10.0d0 + real(kind=kind_phys), parameter :: czmin = 0.0001_kind_phys ! cos(89.994) + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys, one = 1.0_kind_phys, & + half = 0.5_kind_phys, onebg = one/con_g + real(kind=kind_phys), parameter :: albdf = 0.06_kind_phys + real(kind=kind_phys), parameter :: tf=258.16_kind_phys, tcr=273.16_kind_phys, tcrf=one/(tcr-tf) + 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 :: rad2dg = 180.0_kind_phys/con_pi + real(kind=kind_phys), parameter :: omz1 = 2.0_kind_phys +! real(kind=kind_phys), parameter :: huge = 0.0_kind_phys !> GFS Physics Implementation Layer !> @brief Layer that invokes individual GFS physics routines @@ -463,7 +464,7 @@ subroutine GFS_physics_driver & ! --- local variables !--- INTEGER VARIABLES - integer :: me, lprint, ipr, ix, im, levs, ntrac, nvdiff, kdt, & + integer :: me, ipr, ix, im, levs, ntrac, nvdiff, kdt, & ntoz, ntcw, ntiw, ncld,ntke,ntkev, ntlnc, ntinc, lsoil,& ntrw, ntsw, ntrnc, ntsnc, ntot3d, ntgl, ntgnc, ntclamt,& ims, ime, kms, kme, its, ite, kts, kte, imp_physics, & @@ -648,6 +649,7 @@ subroutine GFS_physics_driver & hflxq, evapq, hffac, hefac real (kind=kind_phys), parameter :: z0min=0.2, z0max=1.0 real (kind=kind_phys), parameter :: u10min=2.5, u10max=7.5 + real (kind=kind_phys), parameter :: z0ice=1.1 ! !=============================================================================== @@ -809,8 +811,16 @@ subroutine GFS_physics_driver & ! lprnt = .false. ! do i=1,im -! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-97.50) < 0.101 & -! .and. abs(grid%xlat(i)*rad2dg-24.48) < 0.101 +! lprnt = Model%me == 23 .and. i == 25 +! lprnt = Model%me == 127 .and. i == 11 +! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-102.65) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-0.12) < 0.201 +! lprnt = kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-184.00) < 0.301 & +! .and. abs(grid%xlat(i)*rad2dg-83.23) < 0.301 +! lprnt = kdt >= 7 .and. abs(grid%xlon(i)*rad2dg-216.20) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-81.23) < 0.101 +! lprnt = kdt >= 7 .and. abs(grid%xlon(i)*rad2dg-28.800) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg+2.45) < 0.101 ! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-293.91) < 0.101 & ! .and. abs(grid%xlat(i)*rad2dg+72.02) < 0.101 ! lprnt = kdt >= 1 .and. abs(grid%xlon(i)*rad2dg-113.48) < 0.101 & @@ -826,17 +836,30 @@ subroutine GFS_physics_driver & ! exit ! endif ! enddo -! if (lprnt) write(0,*)' sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt, & -! ' fice=',Sfcprop%fice(ipr),' ulw=',Coupling%ulwsfcin_cpl(ipr), & +! if (lprnt) then +! if (Model%cplflx) then +! write(0,*)' sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt, & +! ' fice=',Sfcprop%fice(ipr),' ulw=',Coupling%ulwsfcin_cpl(ipr), & ! ' tsfc=',Sfcprop%tsfc(ipr) +! else +! write(0,*)' sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt, & +! ' fice=',Sfcprop%fice(ipr), ' tsfc=',Sfcprop%tsfc(ipr), & +! 'tsfcl=',Sfcprop%tsfcl(ipr),' tsfco=',Sfcprop%tsfco(ipr) +! endif +! if (Model%nstf_name(1) > 0) then +! write(0,*)' begin sfcprop%tref=',Sfcprop%tref(ipr),' kdt=',kdt, & +! ' landfrac=',Sfcprop%landfrac(ipr) +! endif +! endif !------------------------------------------------------------------------------------------- ! ! if (lprnt) then ! write(0,*)' in phydrv tgrs=',Statein%tgrs(ipr,:) ! write(0,*)' in phydrv ugrs=',Statein%ugrs(ipr,:) ! write(0,*)' in phydrv vgrs=',Statein%vgrs(ipr,:) -! write(0,*)' in phydrv qgrs=',Statein%qgrs(ipr,:,1) +! write(0,*)' in phydrv qgrs=',Statein%qgrs(ipr,:,1)*1000.0 ! write(0,*)' in phydrv tke=',Statein%qgrs(ipr,:,ntke) +! write(0,*)' in phydrv phii=',Statein%phii(ipr,:) ! endif ! ! --- ... frain=factor for centered difference scheme correction of rain amount. @@ -1010,15 +1033,20 @@ subroutine GFS_physics_driver & Statein%prsl, Statein%prslk, Statein%phii, Statein%phil, del) #else !GFDL Adjust the geopotential height hydrostatically in a way consistent with FV3 discretization +! if (lprnt) write(0,*)'bef get_prs_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt + call get_prs_fv3 (ix, levs, ntrac, Statein%phii, Statein%prsi, & Statein%tgrs, Statein%qgrs, del, del_gz) #endif +! if (lprnt) write(0,*)'aft get_prs_fv3 phii=',Statein%phii(ipr,:) +! if (lprnt) write(0,*)'aft get_prs_fv3 del_gz=',del_gz(ipr,:) !*## CCPP ## !## CCPP ##* GFS_surface_generic.F90/GFS_surface_generic_pre_run do i = 1, IM - sigmaf(i) = max( Sfcprop%vfrac(i),0.01 ) + sigmaf(i) = max( Sfcprop%vfrac(i),0.01_kind_phys ) islmsk(i) = nint(Sfcprop%slmsk(i)) + islmsk_cice(i) = islmsk(i) if (islmsk(i) == 2) then if (Model%isot == 1) then @@ -1033,9 +1061,9 @@ subroutine GFS_physics_driver & endif slopetyp(i) = 9 else - soiltyp(i) = int( Sfcprop%stype(i)+0.5 ) - vegtype(i) = int( Sfcprop%vtype(i)+0.5 ) - slopetyp(i) = int( Sfcprop%slope(i)+0.5 ) !! clu: slope -> slopetyp + soiltyp(i) = int( Sfcprop%stype(i)+half ) + vegtype(i) = int( Sfcprop%vtype(i)+half ) + slopetyp(i) = int( Sfcprop%slope(i)+half ) !! clu: slope -> slopetyp if (soiltyp(i) < 1) soiltyp(i) = 14 if (vegtype(i) < 1) vegtype(i) = 17 if (slopetyp(i) < 1) slopetyp(i) = 1 @@ -1101,45 +1129,66 @@ subroutine GFS_physics_driver & if (flag_cice(i)) then if (fice(i) >= Model%min_seaice) then icy(i) = .true. + if (fice(i) < one) wet(i) = .true. ! some open ocean/lake water exists else - fice(i) = zero + fice(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 (fice(i) >= Model%min_lakeice) then icy(i) = .true. + if (fice(i) < one) wet(i) = .true. ! some open ocean/lake water exists + islmsk(i) = 2 else - fice(i) = zero + fice(i) = zero +! islmsk(i) = 0 + wet(i) = .true. ! some open ocean/lake water exists + endif + endif + if (wet(i) .and. .not. Model%cplflx) then + if (Sfcprop%oceanfrac(i) > zero) then + Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) + elseif (icy(i)) then + Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) endif endif - if (fice(i) < one) then - wet(i)=.true. ! some open ocean/lake water exists - if (.not. Model%cplflx) Sfcprop%tsfco(i) = max(Sfcprop%tsfco(i), Sfcprop%tisfc(i), tgice) - end if else fice(i) = zero endif enddo else do i = 1, IM - frland(i) = zero - if (islmsk(i) == 0) then -! Sfcprop%tsfco(i) = Sfcprop%tsfc(i) - wet(i) = .true. - fice(i) = zero - elseif (islmsk(i) == 1) then + if (islmsk(i) == 1) then ! Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) dry(i) = .true. frland(i) = one fice(i) = zero else - fice(i) = Sfcprop%fice(i) - icy(i) = .true. + frland(i) = zero + if (flag_cice(i)) then + if (fice(i) > Model%min_seaice) then + icy(i) = .true. + else + fice(i) = zero + flag_cice(i) = .false. + islmsk_cice(i) = 0 + islmsk(i) = 0 + endif + else + if (fice(i) > Model%min_lakeice) then + icy(i) = .true. + else + fice(i) = zero + islmsk(i) = 0 + endif + endif if (fice(i) < one) then - wet(i) = .true. -! Sfcprop%tsfco(i) = tgice - if (.not. Model%cplflx) Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) -! Sfcprop%tsfco(i) = max((Sfcprop%tsfc(i) - fice(i)*sfcprop%tisfc(i)) & -! / (one - fice(i)), tgice) + wet(i)=.true. ! some open ocean/lake water exists + if (.not. Model%cplflx .and. icy(i)) & + Sfcprop%tsfco(i) = max(Sfcprop%tisfc(i), tgice) endif endif enddo @@ -1176,19 +1225,22 @@ subroutine GFS_physics_driver & gabsbdlw3(i,k) = zero enddo enddo + zorl3(:,2) = z0ice - if (.not. Model%cplflx .or. .not. Model%frac_grid) then - if (Model%cplwav2atm) then - do i=1,im - Sfcprop%zorll(i) = Sfcprop%zorl(i) - enddo - else - do i=1,im - Sfcprop%zorll(i) = Sfcprop%zorl(i) - Sfcprop%zorlo(i) = Sfcprop%zorl(i) - enddo - endif - endif +! if (.not. Model%cplflx .or. .not. Model%frac_grid) then +! if (Model%cplwav2atm) then +! do i=1,im +! Sfcprop%zorll(i) = Sfcprop%zorl(i) +! enddo +! else +! do i=1,im +! Sfcprop%zorll(i) = Sfcprop%zorl(i) +! Sfcprop%zorlo(i) = Sfcprop%zorl(i) +! enddo +! endif +! endif +! if (lprnt) write(0,*)' dry=',dry(ipr),' wet=',wet(ipr),' icy=',icy(ipr) ,& +! ' tsfco=',Sfcprop%tsfco(ipr) do i=1,im if(wet(i)) then ! Water zorl3(i,3) = Sfcprop%zorlo(i) @@ -1198,7 +1250,7 @@ subroutine GFS_physics_driver & ! snowd3(i,3) = Sfcprop%snowd(i) snowd3(i,3) = zero weasd3(i,3) = zero - semis3(i,3) = 0.984d0 + semis3(i,3) = 0.984_kind_phys endif ! if (dry(i)) then ! Land @@ -1214,13 +1266,13 @@ subroutine GFS_physics_driver & if (icy(i)) then ! Ice uustar3(i,2) = Sfcprop%uustar(i) weasd3(i,2) = Sfcprop%weasd(i) - zorl3(i,2) = Sfcprop%zorll(i) + zorl3(i,2) = Sfcprop%zorli(i) tsfc3(i,2) = Sfcprop%tisfc(i) tsurf3(i,2) = Sfcprop%tisfc(i) snowd3(i,2) = Sfcprop%snowd(i) ep1d3(i,2) = zero gflx3(i,2) = zero - semis3(i,2) = 0.95d0 + semis3(i,2) = 0.95_kind_phys endif enddo !*## CCPP ## @@ -1476,7 +1528,7 @@ subroutine GFS_physics_driver & 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 Diag%suntim(i) = Diag%suntim(i) + dtf endif endif @@ -1489,7 +1541,7 @@ subroutine GFS_physics_driver & tem = (one - frland(i)) * fice(i) ! tem = ice fraction wrt whole cell if (flag_cice(i)) then adjsfculw(i) = adjsfculw3(i,1) * frland(i) & - + Coupling%ulwsfcin_cpl(i) * tem & + + Coupling%ulwsfcin_cpl(i) * tem & + adjsfculw3(i,3) * (one - frland(i) - tem) else adjsfculw(i) = adjsfculw3(i,1) * frland(i) & @@ -1522,7 +1574,7 @@ subroutine GFS_physics_driver & enddo endif ! if (lprnt) write(0,*)' kdt=',kdt,' tsfc=',Sfcprop%tsfc(ipr),' adjsfculw=',adjsfculw(ipr),& -! ' adjsfculw3=',adjsfculw3(ipr,:),' icefr=',Sfcprop%fice(ipr),' tsfc3=',tsfc3(ipr,:) +! ' adjsfculw3=',adjsfculw3(ipr,:),' icefr=',fice(ipr),' tsfc3=',tsfc3(ipr,:) ! do i=1,im Diag%dlwsfc(i) = Diag%dlwsfc(i) + adjsfcdlw(i)*dtf @@ -1558,8 +1610,8 @@ subroutine GFS_physics_driver & kinver(i) = levs !## CCPP ## GFS_typedefs.F90/interstitial_phys_reset invrsn(i) = .false. tx1(i) = zero - tx2(i) = 10.0 - ctei_r(i) = 10.0 + tx2(i) = 10.0_kind_phys + ctei_r(i) = 10.0_kind_phys enddo ! Only used for old shallow convection with mstrat=.true. @@ -1569,12 +1621,12 @@ subroutine GFS_physics_driver & ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) do k=1,levs/2 do i=1,im - if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35*Statein%prsi(i,1) & + if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35_kind_phys*Statein%prsi(i,1) & .and. (.not. invrsn(i))) then tem = (Statein%tgrs(i,k+1) - Statein%tgrs(i,k)) & / (Statein%prsl(i,k) - Statein%prsl(i,k+1)) - if (((tem > 0.00010) .and. (tx1(i) < zero)) .or. & + if (((tem > 0.00010_kind_phys) .and. (tx1(i) < zero)) .or. & ((tem-abs(tx1(i)) > zero) .and. (tx2(i) < zero))) then invrsn(i) = .true. @@ -1588,7 +1640,7 @@ subroutine GFS_physics_driver & ctei_r(i) = (one/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & + Statein%qgrs(i,k+1,ntcw)-Statein%qgrs(i,k,ntcw)) else - ctei_r(i) = 10 + ctei_r(i) = 10.0_kind_phys endif if ( ctei_rml(i) > ctei_r(i) ) then @@ -1631,7 +1683,7 @@ subroutine GFS_physics_driver & Diag%smcref2(i) = zero 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) + + max(zero, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0_kind_phys)), one) !*## CCPP ## enddo !*## CCPP ## @@ -1643,8 +1695,9 @@ subroutine GFS_physics_driver & ! --- ... surface exchange coefficients ! -! if (lprnt) write(0,*)' tsfc=',Sfcprop%tsfc(ipr),' tsurf=',tsurf(ipr),'iter=', & -! iter ,'wet=',wet(ipr),'dry=',dry(ipr),' icy=',icy(ipr) +! if (lprnt) write(0,*)' tsfc=',Sfcprop%tsfc(ipr),'iter=', & +! iter ,'wet=',wet(ipr),'dry=',dry(ipr),' icy=',icy(ipr),& +! ' zorl3=',zorl3(ipr,:),' uustar3=',uustar3(ipr,:) !## CCPP ##* sfc_diff.f/sfc_diff_run call sfc_diff & @@ -1658,16 +1711,18 @@ subroutine GFS_physics_driver & Diag%u10m, Diag%v10m, Model%sfc_z0_type, & wet, dry, icy, tsfc3, tsurf3, snowd3, & ! --- input/output: - zorl3, uustar3, & + zorl3, Sfcprop%zorlw, uustar3, & ! --- outputs: cd3, cdq3, rb3, stress3, ffmm3, ffhh3, fm103, fh23) ! cd3, cdq3, rb3, stress3, ffmm3, ffhh3, fm103, fh23, wind, lprnt, ipr) ! +! if (lprnt) write(0,*)' aft sfc_diff cd3=',cd3(ipr,:),' cdq3=',cdq3(ipr,:),'iter=', iter, & +! ' zorl3=',zorl3(ipr,:),' uustar3=',uustar3(ipr,:) ! --- ... lu: update flag_guess !*## CCPP ## !## CCPP ##* GFS_surface_loop_control/GFS_surface_loop_control_part1_run do i=1,im - if (iter == 1 .and. wind(i) < 2.0) then + if (iter == 1 .and. wind(i) < 2.0_kind_phys) then flag_guess(i) = .true. endif enddo @@ -1684,26 +1739,30 @@ subroutine GFS_physics_driver & endif enddo if (Model%cplflx) then ! apply only at ocean points - tem1 = half / omz1 + call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & + Sfcprop%z_c, wet, zero, omz1, im, 1, dtzm) do i=1,im if (wet(i) .and. Sfcprop%oceanfrac(i) > zero) then - tem2 = one / Sfcprop%xz(i) - dt_warm = (Sfcprop%xt(i)+Sfcprop%xt(i)) * tem2 - if ( Sfcprop%xz(i) > omz1) then - Sfcprop%tref(i) = tseal(i) - (one-half*omz1*tem2) * dt_warm & - + Sfcprop%z_c(i)*Sfcprop%dt_cool(i)*tem1 + Sfcprop%tref(i) = Sfcprop%tsfco(i) - dtzm(i) ! update Tf with T1 and NSST T-Profile + if (abs(Sfcprop%xz(i)) > zero) then + tem2 = one / Sfcprop%xz(i) else - Sfcprop%tref(i) = tseal(i) - (Sfcprop%xz(i)*dt_warm & - - Sfcprop%z_c(i)*Sfcprop%dt_cool(i))*tem1 + tem2 = zero endif - TSEAl(i) = Sfcprop%tref(i) + dt_warm - Sfcprop%dt_cool(i) -! - (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse - tsurf3(i,3) = TSEAl(i) + tseal(i) = Sfcprop%tref(i) + (Sfcprop%xt(i)+Sfcprop%xt(i)) * tem2 & + - Sfcprop%dt_cool(i) + tsurf3(i,3) = tseal(i) endif enddo endif + ! if (lprnt) write(0,*)' bef nst tseal=',tseal(ipr) & -! ,' tsfc3=',tsfc3(ipr,3),' tsurf3=',tsurf3(ipr,3),' tem=',tem +! ,' tsfc3=',tsfc3(ipr,3),' tsurf3=',tsurf3(ipr,3), & +! iter ,'wet=',wet(ipr),'dry=',dry(ipr),' icy=',icy(ipr),& +! ' tref=',Sfcprop%tref(ipr),' tgrs=',Statein%tgrs(ipr,1),' qgrs=',Statein%qgrs(ipr,1,1), & +! ' prsl=',Statein%prsl(ipr,1),' cd3=',cd3(ipr,3),' cdq3=',cdq3(ipr,3),' work3=', & +! work3(ipr),' semis3=',semis3(ipr,3),' gabsbdlw3=',gabsbdlw3(ipr,3),' adjsfcnsw=', & +! adjsfcnsw(ipr),' wind=',wind(ipr),' tseal=',tseal(ipr),' xcosz=',xcosz(ipr) !*## CCPP ## !## CCPP ##* sfc_nst.f/sfc_nst_run call sfc_nst & @@ -1741,8 +1800,8 @@ subroutine GFS_physics_driver & ! --- ... run nsst model ... --- if (Model%nstf_name(1) > 1) then - zsea1 = 0.001*real(Model%nstf_name(4)) - zsea2 = 0.001*real(Model%nstf_name(5)) + zsea1 = 0.001_kind_phys*real(Model%nstf_name(4)) + zsea2 = 0.001_kind_phys*real(Model%nstf_name(5)) call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & Sfcprop%z_c, wet, zsea1, zsea2, im, 1, dtzm) do i=1,im @@ -1755,6 +1814,9 @@ subroutine GFS_physics_driver & endif enddo endif + +! if (lprnt) write(0,*)' aft nst tref=',Sfcprop%tref(ipr) & +! ,' tsfc3=',tsfc3(ipr,3),' dtzm=',dtzm(ipr),' hflx33=',hflx3(ipr,3) !*## CCPP ## ! if (lprnt) print *,' tseaz2=',Sfcprop%tsfc(ipr),' tref=',tref(ipr), & ! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt @@ -1817,10 +1879,10 @@ subroutine GFS_physics_driver & snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) !*## CCPP ## -! if (lprnt) write(0,*)' tseae=',tseal(ipr),' tsurf=',tsurf(ipr),iter& +! if (lprnt) write(0,*)' tseae=',tseal(ipr),' tsurf=',tsurf(ipr),iter ! ,' phy_f2d=',phy_f2d(ipr,num_p2d) -! if (lprnt) write(0,*)' hflx3=',hflx3(ipr,:),' evap3=',evap3(i,:) +! if (lprnt) write(0,*)' hflx3=',hflx3(ipr,:),' evap3=',evap3(ipr,:) !## CCPP ##* sfc_noahmp_drv.f/noahmpdrv_run ! Noah MP call @@ -1901,14 +1963,14 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)' tseabeficemodel =',Sfcprop%tsfc(ipr),' me=',me & ! &, ' kdt=',kdt,' tsfc32=',tsfc3(ipr,2),' fice=',fice(ipr) & -! &,' stsoil=',stsoil(ipr,:) +! &,' stsoil=',stsoil(ipr,:),' tsfc33=',tsfc3(ipr,3),' islmsk=',islmsk(ipr) ! --- ... surface energy balance over seaice !## CCPP ##* sfc_sice.f/sfc_sice_run (local adjustment to avoid resetting islmsk after call to sfc_sice_run) if (Model%cplflx) then do i=1,im if (flag_cice(i)) then - islmsk (i) = islmsk_cice(i) + islmsk(i) = islmsk_cice(i) endif enddo !*## CCPP ## @@ -1924,24 +1986,40 @@ subroutine GFS_physics_driver & flag_cice, flag_iter, & Coupling%dqsfcin_cpl, Coupling%dtsfcin_cpl, & Coupling%dusfcin_cpl, Coupling%dvsfcin_cpl, & + Coupling%hsnoin_cpl, & ! --- outputs: qss3(:,2), cmm3(:,2), chh3(:,2), evap3(:,2), hflx3(:,2), & - stress3(:,2)) + stress3(:,2), weasd3(:,2), snowd3(:,2), ep1d3(:,2)) endif !*## CCPP ## ! ! call sfc_sice for lake ice and for the uncoupled case, sea ice (i.e. islmsk=2) ! + if (Model%frac_grid) then + do i=1,im + if (icy(i) .and. islmsk(i) < 2) then + if (Sfcprop%oceanfrac(i) > zero) then + tem = Model%min_seaice + else + tem = Model%min_lakeice + endif + if (fice(i) > tem) then + islmsk(i) = 2 + tsfc3(i,2) = Sfcprop%tisfc(i) + endif + endif + enddo + endif !## CCPP ##* sfc_sice.f/sfc_sice_run call sfc_sice & ! --- inputs: - (im, lsoil, Statein%pgr, & + (im, lsoil, Statein%pgr, & Statein%tgrs(:,1), Statein%qgrs(:,1,1), dtf, semis3(:,2), & ! Statein%tgrs(:,1), Statein%qgrs(:,1,1), dtf, Radtend%semis, & gabsbdlw3(:,2), adjsfcnsw, adjsfcdsw, Sfcprop%srflag, & cd3(:,2), cdq3(:,2), & - Statein%prsl(:,1), work3, islmsk, wind, & + Statein%prsl(:,1), work3, islmsk, wind, & flag_iter, lprnt, ipr, Model%min_lakeice, & ! --- input/output: zice, fice, tice, weasd3(:,2), tsfc3(:,2), tprcp3(:,2), & @@ -1951,6 +2029,14 @@ subroutine GFS_physics_driver & evap3(:,2), hflx3(:,2)) !*## CCPP ## !## CCPP ##* This section is not needed for CCPP. + if (Model%frac_grid) then + do i = 1, im + if (islmsk(i) == 2 .and. fice(i) < one) then + wet(i) = .true. + tsfc3(i,3) = max(Sfcprop%tisfc(i), tgice) + endif + enddo + endif if (Model%cplflx) then do i = 1, im if (flag_cice(i)) then @@ -1960,8 +2046,9 @@ subroutine GFS_physics_driver & endif !*## CCPP ## -! if (lprnt) write(0,*)' tseaafticemodel =',tsfc3(ipr,2),' me=',me & -! &, ' kdt=',kdt,' iter=',iter,' fice=',fice(ipr) +! if (lprnt) write(0,*)' tseaafticemodel =',tsfc3(ipr,:),' me=',me & +! &, ' kdt=',kdt,' iter=',iter,' fice=',fice(ipr),' wet=',wet(ipr),' icy=',icy(ipr)& +! &,' dry=',dry(ipr) ! --- ... lu: update flag_iter and flag_guess !## CCPP ##* GFS_surface_loop_control.F90/GFS_surface_loop_control_part_2 @@ -1969,7 +2056,7 @@ subroutine GFS_physics_driver & flag_iter(i) = .false. flag_guess(i) = .false. - if (iter == 1 .and. wind(i) < 2.0) then + if (iter == 1 .and. wind(i) < 2.0_kind_phys) then ! if (dry(i) .or. (wet(i) .and. .not.icy(i) & if (dry(i) .or. (wet(i) .and. Model%nstf_name(1) > 0)) then flag_iter(i) = .true. @@ -1992,6 +2079,11 @@ subroutine GFS_physics_driver & txl = frland(i) txi = fice(i)*(one - frland(i)) ! txi = ice fraction wrt whole cell txo = max(zero, one - txl - txi) + +! if (i == ipr .and. lprnt) write(0,*)' txl=',txl,' fice=',fice(i),' txi=',txi,& +! ' txo=',txo,' dry=',dry(i),' wet=',wet(i),' icy=',icy(i),' oceanfrac=',& +! Sfcprop%oceanfrac(i),' frland=',frland(i) + Sfcprop%zorl(i) = txl*zorl3(i,1) + txi*zorl3(i,2) + txo*zorl3(i,3) cd(i) = txl*cd3(i,1) + txi*cd3(i,2) + txo*cd3(i,3) cdq(i) = txl*cdq3(i,1) + txi*cdq3(i,2) + txo*cdq3(i,3) @@ -2029,14 +2121,41 @@ subroutine GFS_physics_driver & Sfcprop%tsfc(i) = txl*tsfc3(i,1) + txi*tice(i) + txo*tsfc3(i,3) ! Sfcprop%tsfc(i) = txl*tsfc3(i,1) + txi*tsfc3(i,2) + txo*tsfc3(i,3) +! if (i == ipr .and. lprnt) then +! write(0,*)' tsfc=',Sfcprop%tsfc(i),' txl=',txl,' txi=',txi,' txo=',txo, & +! ' tsfc3=',tsfc3(i,:),' evap3=',evap3(i,:),' evap=',evap(i),' tice=',tice(i),& +! 'Sfcprop%zorl=',Sfcprop%zorl(ipr) +! endif + ! Diag%cmm(i) = txl*cmm3(i,1) + txi*cmm3(i,2) + txo*cmm3(i,3) ! Diag%chh(i) = txl*chh3(i,1) + txi*chh3(i,2) + txo*chh3(i,3) Sfcprop%zorll(i) = zorl3(i,1) + Sfcprop%zorli(i) = zorl3(i,2) Sfcprop%zorlo(i) = zorl3(i,3) - if (dry(i)) Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land - if (wet(i)) Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake or ocean when uncoupled + if (dry(i)) then + Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land + elseif (wet(i)) then + Sfcprop%tsfcl(i) = tsfc3(i,3) ! over land + else + Sfcprop%tsfcl(i) = tice(i) ! over land + endif + if (wet(i)) then + Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake or ocean when uncoupled + elseif (icy(i)) then + Sfcprop%tsfco(i) = tice(i) ! over lake or ocean when uncoupled + else + Sfcprop%tsfco(i) = tsfc3(i,1) ! over lake or ocean when uncoupled + endif + if (icy(i)) then + Sfcprop%tisfc(i) = tice(i) ! over lake or ocean when uncoupled +! if (Sfcprop%zorll(i) > 1000.0) Sfcprop%zorll(i) = zorl3(i,2) + elseif (wet(i)) then + Sfcprop%tisfc(i) = tsfc3(i,3) ! over lake or ocean when uncoupled + else + Sfcprop%tisfc(i) = tsfc3(i,1) ! over lake or ocean when uncoupled + endif ! for coupled model ocean will replace this ! if (icy(i)) Sfcprop%tisfc(i) = tsfc3(i,2) ! over ice when uncoupled ! if (icy(i)) Sfcprop%tisfc(i) = tice(i) ! over ice when uncoupled @@ -2047,11 +2166,12 @@ subroutine GFS_physics_driver & ! 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 + if (icy(i)) then ! return updated lake ice thickness & concentration to global array Sfcprop%hice(i) = zice(i) Sfcprop%fice(i) = fice(i) Sfcprop%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) Sfcprop%hice(i) = zero Sfcprop%fice(i) = zero Sfcprop%tisfc(i) = Sfcprop%tsfc(i) @@ -2060,25 +2180,28 @@ subroutine GFS_physics_driver & enddo else do i=1,im + if (flag_cice(i) .and. wet(i) .and. fice(i) < Model%min_seaice) then + islmsk(i) = 0 + fice(i) = zero + endif if (islmsk(i) == 1) then k = 1 Sfcprop%tsfcl(i) = tsfc3(i,1) ! over land stress(i) = stress3(i,1) ! Sfcprop%tprcp(i) = tprcp3(i,1) + Sfcprop%tsfco(i) = tsfc3(i,1) + Sfcprop%tisfc(i) = tsfc3(i,1) elseif (islmsk(i) == 0) then k = 3 Sfcprop%tsfco(i) = tsfc3(i,3) ! over lake (and ocean when uncoupled) stress(i) = stress3(i,3) ! Sfcprop%tprcp(i) = tprcp3(i,3) - if(Model%cplflx)Sfcprop%tsfcl(i) = tsfc3(i,3) ! for restart repro comparisons + Sfcprop%tisfc(i) = tsfc3(i,3) + Sfcprop%tsfcl(i) = tsfc3(i,3) else k = 2 - if (.not. flag_cice(i)) then - Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) - endif - stress(i) = fice(i)*stress3(i,2) + (one-fice(i))*stress3(i,3) + stress(i) = stress3(i,2) ! Sfcprop%tprcp(i) = fice(i)*tprcp3(i,2) + (one-fice(i))*tprcp3(i,3) - if(Model%cplflx)Sfcprop%tsfcl(i) = tsfc3(i,2) ! for restart repro comparisons endif Sfcprop%zorl(i) = zorl3(i,k) cd(i) = cd3(i,k) @@ -2102,25 +2225,41 @@ subroutine GFS_physics_driver & Sfcprop%tsfc(i) = tsfc3(i,k) Sfcprop%zorll(i) = zorl3(i,1) + Sfcprop%zorli(i) = zorl3(i,2) Sfcprop%zorlo(i) = zorl3(i,3) - if (flag_cice(i) .and. wet(i)) then ! this was already done for lake ice in sfc_sice - txi = fice(i) - txo = one - txi - evap(i) = txi * evap3(i,2) + txo * evap3(i,3) - hflx(i) = txi * hflx3(i,2) + txo * hflx3(i,3) - Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) - else ! return updated lake ice thickness & concentration to global array - if (islmsk(i) == 2) then - Sfcprop%hice(i) = zice(i) - Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen - Sfcprop%tisfc(i) = tice(i) - else ! this would be over open ocean or land (no ice fraction) - Sfcprop%hice(i) = zero - Sfcprop%fice(i) = zero - Sfcprop%tisfc(i) = Sfcprop%tsfc(i) + if (flag_cice(i)) then + if (wet(i) .and. fice(i) > Model%min_seaice) then ! this was already done for lake ice in sfc_sice + txi = fice(i) + txo = one - txi + evap(i) = txi * evap3(i,2) + txo * evap3(i,3) + hflx(i) = txi * hflx3(i,2) + txo * hflx3(i,3) + Sfcprop%tsfc(i) = txi * tsfc3(i,2) + txo * tsfc3(i,3) + stress(i) = txi *stress3(i,2) + txo * stress3(i,3) + qss(i) = txi * qss3(i,2) + txo * qss3(i,3) + ep1d(i) = txi * ep1d3(i,2) + txo * ep1d3(i,3) + Sfcprop%zorl(i) = txi*zorl3(i,2) + txo*zorl3(i,3) endif + elseif (islmsk(i) == 2) then ! return updated lake ice thickness & concentration to global array + Sfcprop%tisfc(i) = tice(i) ! over lake ice (and sea ice when uncoupled) + Sfcprop%hice(i) = zice(i) + Sfcprop%fice(i) = fice(i) ! fice is fraction of lake area that is frozen + Sfcprop%zorl(i) = fice(i)*zorl3(i,2) + (one-fice(i))*zorl3(i,3) + else ! this would be over open ocean or land (no ice fraction) + Sfcprop%hice(i) = zero + Sfcprop%fice(i) = zero + Sfcprop%tisfc(i) = Sfcprop%tsfc(i) + icy(i) = .false. endif + Sfcprop%tsfcl(i) = Sfcprop%tsfc(i) + if (wet(i)) then + Sfcprop%tsfco(i) = tsfc3(i,3) + else + Sfcprop%tsfco(i) =Sfcprop%tsfc(i) + endif + do k=1,Model%kice ! store tiice in stc to reduce output in the nonfrac grid case + Sfcprop%stc(i,k) = Sfcprop%tiice(i,k) + enddo enddo endif ! if (Model%frac_grid) !*## CCPP ## @@ -2212,9 +2351,9 @@ subroutine GFS_physics_driver & if (wet(i)) then ! some open water ! --- compute open water albedo xcosz_loc = max( zero, min( one, xcosz(i) )) - ocalnirdf_cpl(i) = 0.06 - ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & - & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & + ocalnirdf_cpl(i) = 0.06_kind_phys + ocalnirbm_cpl(i) = 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(i) = 0.06 ocalvisbm_cpl(i) = ocalnirbm_cpl(i) @@ -2267,7 +2406,7 @@ subroutine GFS_physics_driver & endif ! Compute dew point, first using vapor pressure - tem = max(Statein%pgr(i) * Sfcprop%q2m(i) / ( con_eps - con_epsm1 * Sfcprop%q2m(i)), 1.e-8) + tem = max(Statein%pgr(i) * Sfcprop%q2m(i) / ( con_eps - con_epsm1 * Sfcprop%q2m(i)), qmin) Diag%dpt2m(i) = 243.5 / ( ( 17.67 / log(tem/611.2) ) - one) + 273.14 enddo @@ -2295,20 +2434,20 @@ subroutine GFS_physics_driver & do i=1,im hflxq(i) = hflx(i) evapq(i) = evap(i) - hffac(i) = 1.0 - hefac(i) = 1.0 + hffac(i) = one + hefac(i) = one enddo if (Model%lheatstrg) then do i=1,im - tem = 0.01 * Sfcprop%zorl(i) ! change unit from cm to m + tem = 0.01_kind_phys * Sfcprop%zorl(i) ! change unit from cm to m tem1 = (tem - z0min) / (z0max - z0min) - hffac(i) = Model%z0fac * min(max(tem1, 0.0), 1.0) - tem = sqrt(Diag%u10m(i)**2+Diag%v10m(i)**2) + hffac(i) = Model%z0fac * min(max(tem1, zero), one) + tem = sqrt(Diag%u10m(i)*Diag%u10m(i)+Diag%v10m(i)*Diag%v10m(i)) tem1 = (tem - u10min) / (u10max - u10min) - tem2 = 1.0 - min(max(tem1, 0.0), 1.0) + tem2 = one - min(max(tem1, zero), one) hffac(i) = tem2 * hffac(i) - hefac(i) = 1. + Model%e0fac * hffac(i) - hffac(i) = 1. + hffac(i) + hefac(i) = one + Model%e0fac * hffac(i) + hffac(i) = one + hffac(i) hflxq(i) = hflx(i) / hffac(i) evapq(i) = evap(i) / hefac(i) enddo @@ -2328,6 +2467,7 @@ subroutine GFS_physics_driver & ! enddo ! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat +! if (lprnt) write(0,*)'befmonshoc phii=',Statein%phii(ipr,:) ! if (lprnt) write(0,*)'befmonshoc=',Statein%tgrs(ipr,:) ! if (lprnt) write(0,*)'befmonshocdtdt=',dtdt(ipr,1:10) ! if (lprnt) write(0,*)'befmonshoctkh=',Tbd%phy_f3d(ipr,1:10,ntot3d-1) @@ -2360,8 +2500,9 @@ subroutine GFS_physics_driver & Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, Model%xkzminv, & lprnt, ipr, me) ! if (lprnt) then +! write(0,*)' aftpbl phii=',Statein%phii(ipr,:) ! write(0,*)' aftpbl dtdt=',dtdt(ipr,:) -! write(0,*)' aftpbl dqdtv=',dqdt(ipr,:,1) +! write(0,*)' aftpbl dqdtv=',dqdt(ipr,:,1) ! write(0,*)'aftmonshoc=',Statein%tgrs(ipr,:) ! write(0,*)'aftmonshocq=',Statein%qgrs(ipr,:,1) ! write(0,*)'aftmonshoctke=',Statein%qgrs(ipr,:,ntke) @@ -2369,6 +2510,7 @@ subroutine GFS_physics_driver & ! write(0,*)'aftmonwat=',Statein%qgrs(ipr,:,ntcw) ! write(0,*)'aftmonshocdtdt=',dtdt(ipr,1:10) ! endif + else if (Model%satmedmf) then if (Model%isatmedmf == 0) then ! initial version of satmedmfvdif (Nov 2018) @@ -2835,7 +2977,7 @@ subroutine GFS_physics_driver & !## CCPP ##* GFS_PBL_generic.F90/GFS_PBL_generic_post_run if (Model%cplchm) then do i = 1, im - tem1 = max(Diag%q1(i), 1.e-8) + tem1 = max(Diag%q1(i), qmin) tem = Statein%prsl(i,1) / (con_rd*Diag%t1(i)*(one+con_fvirt*tem1)) Coupling%ushfsfci(i) = -con_cp * tem * hflx(i) ! upward sensible heat flux enddo @@ -2863,7 +3005,7 @@ subroutine GFS_physics_driver & Coupling%dtsfci_cpl(i) = Coupling%dtsfcin_cpl(i) Coupling%dqsfci_cpl(i) = Coupling%dqsfcin_cpl(i) elseif (icy(i) .or. dry(i)) then ! use stress_ocean from sfc_diff for opw component at mixed point - tem1 = max(Diag%q1(i), 1.e-8) + tem1 = max(Diag%q1(i), qmin) rho = Statein%prsl(i,1) / (con_rd*Diag%t1(i)*(one+con_fvirt*tem1)) if (wind(i) > zero) then tem = - rho * stress3(i,3) / wind(i) @@ -3083,7 +3225,7 @@ subroutine GFS_physics_driver & if (ntke > 0) then tke(1:im,:) = Statein%qgrs(1:im,:,ntke) + dqdt(1:im,:,ntke) * dtp else - tke(:,:) = -9999.0 + tke(:,:) = -9999.0_kind_phys endif ! ! tendency without PBL-accumulations @@ -3349,9 +3491,15 @@ subroutine GFS_physics_driver & Model%gen_coord_hybrid Statein%prsi, Statein%prsik, & Statein%prsl, Statein%prslk, Statein%phii, Statein%phil) #else +! if (lprnt) write(0,*)'bef get_phi_fv3 gt0=',Stateout%gt0(ipr,:),' kdt=',kdt +! if (lprnt) write(0,*)'bef get_phi_fv3 gq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)'bef get_phi_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt + !GFDL Adjust the height hydrostatically in a way consistent with FV3 discretization call get_phi_fv3 (ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & del_gz, Statein%phii, Statein%phil) + +! if (lprnt) write(0,*)'aft get_phi_fv3 phii=',Statein%phii(ipr,:),' kdt=',kdt #endif !*## CCPP ## @@ -3360,7 +3508,7 @@ subroutine GFS_physics_driver & do k=1,levs do i=1,im clw(i,k,1) = zero - clw(i,k,2) = -999.9 + clw(i,k,2) = -999.9_kind_phys enddo enddo @@ -3429,7 +3577,7 @@ subroutine GFS_physics_driver & !## CCPP ## GFS_suite_interstitial.F90/GFS_suite_interstitial_3_run if (ntcw > 0) then ! if (imp_physics == Model%imp_physics_mg .and. .not. Model%do_shoc) then ! compute rhc for GMAO macro physics cloud pdf - if (imp_physics == Model%imp_physics_mg .and. Model%crtrh(2) < 0.5) then ! compute rhc for GMAO macro physics cloud pdf + if (imp_physics == Model%imp_physics_mg .and. Model%crtrh(2) < half) then ! compute rhc for GMAO macro physics cloud pdf do i=1,im tx1(i) = one / Statein%prsi(i,1) tx2(i) = one - rhc_max*work1(i) - Model%crtrh(1)*work2(i) @@ -3440,20 +3588,20 @@ subroutine GFS_physics_driver & do k = 1, levs do i = 1, im tem = Statein%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 crtrh(2) and crtrh(3) from the namelist instead of 0.3 and 0.2 ! and crtrh(1) represents pbl top critical relative humidity - tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0), 20.0) + tem2 = min(max((tx4(i)-tem)*slope_upmg, -20.0_kind_phys), 20.0_kind_phys) if (islmsk(i) > 0) then tem1 = one / (one+exp(tem1+tem1)) else - tem1 = 2.0 / (one+exp(tem1+tem1)) + tem1 = 2.0_kind_phys / (one+exp(tem1+tem1)) endif tem2 = one / (one+exp(tem2)) - rhc(i,k) = min(rhc_max, max(0.7, one-tx2(i)*tem1*tem2)) + rhc(i,k) = min(rhc_max, max(0.7_kind_phys, one-tx2(i)*tem1*tem2)) enddo enddo else @@ -3467,7 +3615,7 @@ subroutine GFS_physics_driver & tem = Model%crtrh(2) - (Model%crtrh(2)-Model%crtrh(3)) & * (Statein%prslk(i,kk)-Statein%prslk(i,k)) / Statein%prslk(i,kk) endif - tem = rhc_max * work1(i) + tem * work2(i) + if (rhc_max > tem) tem = rhc_max * work1(i) + tem * work2(i) rhc(i,k) = max(zero, min(one, tem)) enddo enddo @@ -3594,6 +3742,7 @@ subroutine GFS_physics_driver & ! if (lprnt) write(0,*)'gt01=',Stateout%gt0(ipr,:) ! if (lprnt) write(0,*)'gq01=',Stateout%gq0(ipr,:,1) +! if (lprnt) write(0,*)'phii=',Statein%phii(ipr,:),' kdt=',kdt ! if (lprnt) write(0,*)'clwi=',clw(ipr,:,1) ! if (lprnt) write(0,*)'clwl=',clw(ipr,:,2) ! if (lprnt) write(0,*)'befncpi=',ncpi(ipr,:) @@ -3863,13 +4012,13 @@ subroutine GFS_physics_driver & ! &, ' cs_conv', grid%xlon(1:im), grid%xlat(1:im)) !## CCPP ##* Not in the CCPP. TODO: Does this need to be in cs_conv_post_run? - rain1(:) = rain1(:) * (dtp*0.001) + rain1(:) = rain1(:) * (dtp*con_p001) !## CCPP ##* cs_conv.F90/cs_conv_post_run if (Model%do_aw) then do k=1,levs kk = min(k+1,levs) ! assuming no cloud top reaches the model top do i=1,im !DD - sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + sigmafrac(i,k) = half * (sigmatot(i,k)+sigmatot(i,kk)) enddo enddo endif @@ -3895,7 +4044,7 @@ subroutine GFS_physics_driver & enddo else do i=1,im - ccwfac(i) = -999.0 + ccwfac(i) = -999.0_kind_phys dlqfac(i) = zero psaur_l(i) = Model%psauras(1)*work1(i) + Model%psauras(2)*work2(i) praur_l(i) = Model%prauras(1)*work1(i) + Model%prauras(2)*work2(i) @@ -3915,8 +4064,8 @@ subroutine GFS_physics_driver & revap = .true. ! if (ncld ==2) revap = .false. - trcmin(:) = -999999.0 - if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4 + trcmin(:) = -999999.0_kind_phys + if (ntk-2 > 0) trcmin(ntk-2) = 1.0e-4_kind_phys !*## CCPP ## ! if (lprnt) write(0,*)' gt04bras=',Stateout%gt0(ipr,:) ! if (lprnt) write(0,*)' gq04bras=',Stateout%gq0(ipr,:,1) @@ -4217,10 +4366,10 @@ subroutine GFS_physics_driver & do k=1,levs do i=1,im - eng0 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + eng0 = half*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp - eng1 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + eng1 = half*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) Stateout%gt0(i,k) = Stateout%gt0(i,k) + (eng0-eng1)/(dtp*con_cp) enddo ! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', @@ -4366,7 +4515,7 @@ subroutine GFS_physics_driver & levshc(:) = 0 do k=2,levs do i=1,im - dpshc = 0.3 * Statein%prsi(i,1) + dpshc = 0.3_kind_phys * Statein%prsi(i,1) if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k enddo enddo @@ -4418,7 +4567,7 @@ subroutine GFS_physics_driver & ! do k=1,levs do i=1,im - if (clw(i,k,2) <= -999.0) clw(i,k,2) = zero + if (clw(i,k,2) <= -999.0_kind_phys) clw(i,k,2) = zero enddo enddo !*## CCPP ## @@ -5101,10 +5250,10 @@ subroutine GFS_physics_driver & reset) tem = dtp * con_p001 / con_day do i = 1, im -! rain0(i,1) = max(con_d00, rain0(i,1)) -! snow0(i,1) = max(con_d00, snow0(i,1)) -! ice0(i,1) = max(con_d00, ice0(i,1)) -! graupel0(i,1) = max(con_d00, graupel0(i,1)) +! rain0(i,1) = max(zero, rain0(i,1)) +! snow0(i,1) = max(zero, snow0(i,1)) +! ice0(i,1) = max(zero, ice0(i,1)) +! graupel0(i,1) = max(zero, graupel0(i,1)) if (rain0(i,1)*tem < rainmin) then rain0(i,1) = zero endif @@ -5156,8 +5305,8 @@ subroutine GFS_physics_driver & if (Model%effr_in) then do i =1, im - den(i,k) = 0.622*Statein%prsl(i,k) / & - (con_rd*Stateout%gt0(i,k)*(Stateout%gq0(i,k,1)+0.622)) + den(i,k) = 0.622_kind_phys*Statein%prsl(i,k) / & + (con_rd*Stateout%gt0(i,k)*(Stateout%gq0(i,k,1)+0.622_kind_phys)) enddo endif enddo @@ -5172,8 +5321,8 @@ subroutine GFS_physics_driver & call max_fields(Statein%phil,Diag%refl_10cm,con_g,im,levs,refd,Stateout%gt0,refd263k) if (reset) then do i=1,im - Diag%refdmax(I) = -35. - Diag%refdmax263k(I) = -35. + Diag%refdmax(I) = -35.0_kind_phys + Diag%refdmax263k(I) = -35.0_kind_phys enddo endif do i=1,im @@ -5268,7 +5417,7 @@ subroutine GFS_physics_driver & enddo ! write(1000+me,*)' rain1=',rain1(4),' temrain1=',temrain1(i)*0.001 do i = 1,im - rain1(i) = max(rain1(i) - temrain1(i)*0.001, 0.0_kind_phys) + rain1(i) = max(rain1(i) - temrain1(i)*con_p001, zero) enddo endif @@ -5285,18 +5434,18 @@ subroutine GFS_physics_driver & ! It appears that Diag%rain and Diag%rainc are on the dynamics time step, ! but Diag%snow,graupel,ice are on the physics time step? This doesn't ! matter as long as dtp=dtf (frain=1). - tem = 1.0 / (dtp*con_p001) + tem = one / (dtp*con_p001) Sfcprop%draincprv(:) = tem * Diag%rainc(:) Sfcprop%drainncprv(:) = tem * (frain * rain1(:)) Sfcprop%dsnowprv(:) = tem * Diag%snow(:) Sfcprop%dgraupelprv(:) = tem * Diag%graupel(:) Sfcprop%diceprv(:) = tem * Diag%ice(:) else - Sfcprop%draincprv(:) = 0.0 - Sfcprop%drainncprv(:) = 0.0 - Sfcprop%dsnowprv(:) = 0.0 - Sfcprop%dgraupelprv(:) = 0.0 - Sfcprop%diceprv(:) = 0.0 + Sfcprop%draincprv(:) = zero + Sfcprop%drainncprv(:) = zero + Sfcprop%dsnowprv(:) = zero + Sfcprop%dgraupelprv(:) = zero + Sfcprop%diceprv(:) = zero endif end if ! if (Model%lsm == Model%lsm_noahmp) @@ -5339,33 +5488,6 @@ subroutine GFS_physics_driver & endif - if (Model%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 - Diag%cnvprcp(i) = Diag%cnvprcp(i) + Diag%rainc(i) - Diag%totprcp (i) = Diag%totprcp (i) + Diag%rain(i) - Diag%totice (i) = Diag%totice (i) + Diag%ice(i) - Diag%totsnw (i) = Diag%totsnw (i) + Diag%snow(i) - Diag%totgrp (i) = Diag%totgrp (i) + Diag%graupel(i) -! - Diag%cnvprcpb(i) = Diag%cnvprcpb(i) + Diag%rainc(i) - Diag%totprcpb(i) = Diag%totprcpb(i) + Diag%rain(i) - Diag%toticeb (i) = Diag%toticeb (i) + Diag%ice(i) - Diag%totsnwb (i) = Diag%totsnwb (i) + Diag%snow(i) - Diag%totgrpb (i) = Diag%totgrpb (i) + Diag%graupel(i) - enddo - - if (Model%ldiag3d) then - do k=1,levs - do i=1,im - Diag%dt3dt(i,k,6) = Diag%dt3dt(i,k,6) + (Stateout%gt0(i,k)-dtdt(i,k)) * frain -! Diag%dq3dt(i,k,4) = Diag%dq3dt(i,k,4) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain - enddo - enddo - endif - endif !*## CCPP ## !## CCPP ##* this block not yet in CCPP !-------------------------------- @@ -5394,14 +5516,15 @@ subroutine GFS_physics_driver & enddo enddo - if (Model%imp_physics == Model%imp_physics_gfdl) then + if (Model%imp_physics == Model%imp_physics_gfdl) then ! GFDL microphysics + ! ----------------- ! determine convective rain/snow by surface temperature ! determine large-scale rain/snow by rain/snow coming out directly from MP tem = dtp * con_p001 / con_day do i = 1, im Sfcprop%tprcp(i) = max(zero, Diag%rain(i) )! clu: rain -> tprcp Sfcprop%srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (Sfcprop%tsfc(i) >= 273.15) then + if (Sfcprop%tsfc(i) >= 273.15_kind_phys) then crain = Diag%rainc(i) csnow = zero else @@ -5429,34 +5552,67 @@ subroutine GFS_physics_driver & #endif enddo elseif( .not. Model%cal_pre) then - if (Model%imp_physics == Model%imp_physics_mg) then ! MG microphysics - tem = con_day / (dtp * con_p001) ! mm / day + if (Model%imp_physics == Model%imp_physics_mg) then ! MG microphysics + ! --------------- do i=1,im - Sfcprop%tprcp(i) = max(zero, Diag%rain(i) ) ! clu: rain -> tprcp - if (Diag%rain(i)*tem > rainmin) then - Sfcprop%srflag(i) = max(zero, min(one, (Diag%rain(i)-Diag%rainc(i))*Diag%sr(i)/Diag%rain(i))) + if (Diag%rain(i) > rainmin) then + tem1 = max(zero, (Diag%rain(i)-Diag%rainc(i))) * Diag%sr(i) + tem2 = one / Diag%rain(i) + if (t850(i) > 273.16_kind_phys) then + Sfcprop%srflag(i) = max(zero, min(one, tem1*tem2)) + else + Sfcprop%srflag(i) = max(zero, min(one, (tem1+Diag%rainc(i))*tem2)) + endif else Sfcprop%srflag(i) = zero + Diag%rain(i) = zero + Diag%rainc(i) = zero endif + Sfcprop%tprcp(i) = max(zero, Diag%rain(i)) enddo - else + else ! not GFDL or MG microphysics + ! --------------------------- do i = 1, im - Sfcprop%tprcp(i) = max(zero, Diag%rain(i) ) ! clu: rain -> tprcp - Sfcprop%srflag(i) = zero ! clu: default srflag as 'rain' (i.e. 0) - if (t850(i) <= 273.16) then - Sfcprop%srflag(i) = one ! clu: set srflag to 'snow' (i.e. 1) - endif + Sfcprop%tprcp(i) = max(zero, Diag%rain(i)) + Sfcprop%srflag(i) = Diag%sr(i) enddo endif endif + if (Model%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 + Diag%cnvprcp(i) = Diag%cnvprcp(i) + Diag%rainc(i) + Diag%totprcp (i) = Diag%totprcp (i) + Diag%rain(i) + Diag%totice (i) = Diag%totice (i) + Diag%ice(i) + Diag%totsnw (i) = Diag%totsnw (i) + Diag%snow(i) + Diag%totgrp (i) = Diag%totgrp (i) + Diag%graupel(i) +! + Diag%cnvprcpb(i) = Diag%cnvprcpb(i) + Diag%rainc(i) + Diag%totprcpb(i) = Diag%totprcpb(i) + Diag%rain(i) + Diag%toticeb (i) = Diag%toticeb (i) + Diag%ice(i) + Diag%totsnwb (i) = Diag%totsnwb (i) + Diag%snow(i) + Diag%totgrpb (i) = Diag%totgrpb (i) + Diag%graupel(i) + enddo + + if (Model%ldiag3d) then + do k=1,levs + do i=1,im + Diag%dt3dt(i,k,6) = Diag%dt3dt(i,k,6) + (Stateout%gt0(i,k)-dtdt(i,k)) * frain +! Diag%dq3dt(i,k,4) = Diag%dq3dt(i,k,4) + (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + enddo + enddo + endif + endif ! --- ... coupling insertion if (Model%cplflx .or. Model%cplchm) then do i = 1, im - Tbd%drain_cpl(i)= Diag%rain(i) * (one-Sfcprop%srflag(i)) - Tbd%dsnow_cpl(i)= Diag%rain(i) * Sfcprop%srflag(i) + Tbd%dsnow_cpl(i)= max(zero, Diag%rain(i) * Sfcprop%srflag(i)) + Tbd%drain_cpl(i)= max(zero, Diag%rain(i) - Tbd%dsnow_cpl(i)) Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Tbd%drain_cpl(i) Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Tbd%dsnow_cpl(i) enddo @@ -5544,6 +5700,7 @@ subroutine GFS_physics_driver & ! write(0,*) ' endgt0=',Stateout%gt0(ipr,:),' kdt=',kdt ! write(0,*) ' endgq0=',Stateout%gq0(ipr,:,1),' kdt=',kdt ! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat +! write(0,*) ' endzorl=',Sfcprop%zorl(ipr),' kdt=',kdt ! endif if (Model%do_sppt .or. Model%ca_global)then @@ -5611,13 +5768,13 @@ subroutine GFS_physics_driver & if (reset) then do i=1, im ! find max hourly wind speed then decompose - Diag%spd10max(i) = -999. - Diag%u10max(i) = -999. - Diag%v10max(i) = -999. - Diag%t02max(i) = -999. - Diag%t02min(i) = 999. - Diag%rh02max(i) = -999. - Diag%rh02min(i) = 999. + Diag%spd10max(i) = -999.0_kind_phys + Diag%u10max(i) = -999.0_kind_phys + Diag%v10max(i) = -999.0_kind_phys + Diag%t02max(i) = -999.0_kind_phys + Diag%t02min(i) = 999.0_kind_phys + Diag%rh02max(i) = -999.0_kind_phys + Diag%rh02min(i) = 999.0_kind_phys enddo endif do i=1, im @@ -5628,7 +5785,7 @@ subroutine GFS_physics_driver & Diag%u10max(i) = Diag%u10m(i) Diag%v10max(i) = Diag%v10m(i) endif - pshltr = Statein%pgr(i)*exp(-0.068283/Stateout%gt0(i,1)) + pshltr = Statein%pgr(i)*exp(-0.068283_kind_phys/Stateout%gt0(i,1)) QCQ = PQ0/pshltr*EXP(A2A*(Sfcprop%t2m(i)-A3)/(Sfcprop%t2m(i)-A4)) rh02 = Sfcprop%q2m(i) / QCQ IF (rh02 > one) THEN @@ -5644,6 +5801,16 @@ subroutine GFS_physics_driver & enddo !*## CCPP ## ! if (kdt > 2 ) stop + +! if (Model%nstf_name(1) > 0) then +! if (lprnt) write(0,*)' end driver sfcprop%tref=',Sfcprop%tref(ipr),' kdt=',kdt +! endif +! if (Model%frac_grid) then +! if (lprnt) write(0,*)' end driver sfcprop%tsfcl=',Sfcprop%tsfcl(ipr),' kdt=',kdt +! if (lprnt) write(0,*)' end driver sfcprop%tsfco=',Sfcprop%tsfco(ipr),' kdt=',kdt +! if (lprnt) write(0,*)' end driver sfcprop%tisfc=',Sfcprop%tisfc(ipr),' kdt=',kdt +! endif + return !................................... end subroutine GFS_physics_driver @@ -5748,10 +5915,10 @@ subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & integer :: i, k ! do i=1,im - sumqv(i) = 0.0 - sumql(i) = 0.0 - sumqi(i) = 0.0 - sumq (i) = 0.0 + sumqv(i) = 0.0_kind_phys + sumql(i) = 0.0_kind_phys + sumqi(i) = 0.0_kind_phys + sumq (i) = 0.0_kind_phys enddo do k=1,levs do i=1,im @@ -5761,9 +5928,9 @@ subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & enddo enddo do i=1,im - sumqv(i) = - sumqv(i) * (1.0/grav) - sumql(i) = - sumql(i) * (1.0/grav) - sumqi(i) = - sumqi(i) * (1.0/grav) + sumqv(i) = - sumqv(i) * (1.0_kind_phys/grav) + sumql(i) = - sumql(i) * (1.0_kind_phys/grav) + sumqi(i) = - sumqi(i) * (1.0_kind_phys/grav) sumq (i) = sumqv(i) + sumql(i) + sumqi(i) enddo do i=1,im @@ -5796,13 +5963,13 @@ subroutine moist_bud2(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & integer :: i, k ! do i=1,im - sumqv(i) = 0.0 - sumql(i) = 0.0 - sumqi(i) = 0.0 - sumqr(i) = 0.0 - sumqs(i) = 0.0 - sumqg(i) = 0.0 - sumq (i) = 0.0 + sumqv(i) = 0.0_kind_phys + sumql(i) = 0.0_kind_phys + sumqi(i) = 0.0_kind_phys + sumqr(i) = 0.0_kind_phys + sumqs(i) = 0.0_kind_phys + sumqg(i) = 0.0_kind_phys + sumq (i) = 0.0_kind_phys enddo do k=1,levs do i=1,im @@ -5814,7 +5981,7 @@ subroutine moist_bud2(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & sumqg(i) = sumqg(i) + (qg1(i,k) - qg0(i,k)) * delp(i,k) enddo enddo - oneog = 1.0 / grav + oneog = 1.0_kind_phys / grav do i=1,im sumqv(i) = - sumqv(i) * oneog sumql(i) = - sumql(i) * oneog diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 index b68d49861..ebec30c4d 100644 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 @@ -319,7 +319,7 @@ module module_radiation_driver ! & epsm1 => con_epsm1, & & fvirt => con_fvirt & &, rog => con_rog & - &, rocp => con_rocp + &, rocp => con_rocp, pi => con_pi use funcphys, only: fpvs use module_radiation_astronomy,only: sol_init, sol_update, coszmn @@ -377,11 +377,11 @@ module module_radiation_driver ! !> EPSQ=1.0e-12 real (kind=kind_phys) :: EPSQ ! parameter (QMIN=1.0e-10, QME5=1.0e-5, QME6=1.0e-6, EPSQ=1.0e-12) - parameter (QMIN=1.0e-10, QME5=1.0e-7, QME6=1.0e-7, EPSQ=1.0e-12) + parameter (QMIN=1.0d-10, QME5=1.0d-7, QME6=1.0d-7, EPSQ=1.0d-12) ! parameter (QMIN=1.0e-10, QME5=1.0e-20, QME6=1.0e-20, EPSQ=1.0e-12) !> lower limit of toa pressure value in mb - real, parameter :: prsmin = 1.0e-6 + real, parameter :: prsmin = 1.0d-6 !> control flag for LW surface temperature at air/ground interface !! (default=0, the value will be set in subroutine radinit) @@ -441,7 +441,7 @@ subroutine radinit( si, NLAY, imp_physics, me ) ! ! ! attributes: ! ! language: fortran 90 ! -! machine: wcoss ! +! machine: wcoss ! ! ! ! ==================== definition of variables ==================== ! ! ! @@ -453,7 +453,7 @@ subroutine radinit( si, NLAY, imp_physics, me ) ! ! ! outputs: (none) ! ! ! -! external module variables: (in module physparam) ! +! external module variables: (in module physparam) ! ! isolar : solar constant cntrol flag ! ! = 0: use the old fixed solar constant in "physcon" ! ! =10: use the new fixed solar constant in "physcon" ! @@ -501,13 +501,13 @@ subroutine radinit( si, NLAY, imp_physics, me ) ! icldflg : cloud optical property scheme control flag ! ! =0: use diagnostic cloud scheme (discontinued) ! ! =1: use prognostic cloud scheme (default) ! -! imp_physics : cloud microphysics scheme control flag ! -! =99 zhao/carr/sundqvist microphysics scheme ! +! imp_physics : cloud microphysics scheme control flag ! +! =99 zhao/carr/sundqvist microphysics scheme ! ! =98 zhao/carr/sundqvist microphysics+pdf cloud & cnvc,cnvw! -! =11 GFDL cloud microphysics ! +! =11 GFDL cloud microphysics ! ! =8 Thompson microphysics scheme ! ! =6 WSM6 microphysics scheme ! -! =10 MG microphysics scheme ! +! =10 MG microphysics scheme ! ! iovrsw : control flag for cloud overlap in sw radiation ! ! iovrlw : control flag for cloud overlap in lw radiation ! ! =0: random overlapping clouds ! @@ -1221,14 +1221,18 @@ subroutine GFS_radiation_driver & ! mg, sfc perts real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: alb1d - real(kind=kind_phys) :: cdfz real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtausw real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtaulw + real(kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 + !--- TYPED VARIABLES type (cmpfsw_type), dimension(size(Grid%xlon,1)) :: scmpsw + real(kind=kind_phys), parameter :: rad2dg = 180.0_kind_phys/pi +! logical :: lprnt +! integer :: ipt ! logical effr_in ! data effr_in/.false./ ! @@ -1294,6 +1298,25 @@ subroutine GFS_radiation_driver & raddt = min(Model%fhswr, Model%fhlwr) ! print *,' in grrad : raddt=',raddt + +! lprnt = .false. + +! do i=1,im +! lprnt = Model%kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-102.65) < 0.101 & +! .and. abs(grid%xlat(i)*rad2dg-0.12) < 0.201 +! lprnt = Model%kdt >= 20 .and. abs(grid%xlon(i)*rad2dg-184.00) < 0.301 & +! .and. abs(grid%xlat(i)*rad2dg-83.23) < 0.301 +! if (kdt == 1) & +! write(2000+me,*)' i=',i,' xlon=',grid%xlon(i)*rad2dg, +! & +! ' xlat=',grid%xlat(i)*rad2dg,' me=',me +! if (lprnt) then +! ipt = i +! write(0,*)' ipt=',ipt,'xlon=',grid%xlon(i)*rad2dg,' xlat=',grid%xlat(i)*rad2dg,' me=',me +! exit +! endif +! enddo + !> -# Setup surface ground temperature and ground/air skin temperature !! if required. @@ -1319,15 +1342,15 @@ subroutine GFS_radiation_driver & k1 = k + kd k2 = k + lsk do i = 1, IM - plvl(i,k1+kb) = Statein%prsi(i,k2+kb) * 0.01 ! pa to mb (hpa) - plyr(i,k1) = Statein%prsl(i,k2) * 0.01 ! pa to mb (hpa) + plvl(i,k1+kb) = Statein%prsi(i,k2+kb) * 0.01d0 ! pa to mb (hpa) + plyr(i,k1) = Statein%prsl(i,k2) * 0.01d0 ! pa to mb (hpa) tlyr(i,k1) = Statein%tgrs(i,k2) prslk1(i,k1) = Statein%prslk(i,k2) !> - Compute relative humidity. es = min( Statein%prsl(i,k2), fpvs( Statein%tgrs(i,k2) ) ) ! fpvs and prsl in pa qs = max( QMIN, eps * es / (Statein%prsl(i,k2) + epsm1*es) ) - rhly(i,k1) = max( 0.0, min( 1.0, max(QMIN, Statein%qgrs(i,k2,1))/qs ) ) + rhly(i,k1) = max( zero, min( one, max(QMIN, Statein%qgrs(i,k2,1))/qs ) ) qstl(i,k1) = qs enddo enddo @@ -1337,37 +1360,43 @@ subroutine GFS_radiation_driver & do k = 1, LM k1 = k + kd k2 = k + lsk - tracer1(:,k1,j) = max(0.0, Statein%qgrs(:,k2,j)) + tracer1(:,k1,j) = max(zero, Statein%qgrs(:,k2,j)) enddo 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,1+kd) = 0.5 * (plvl(i,2+kd) + plvl(i,1+kd)) + plvl(i,k2) = 0.01d0 * Statein%prsi(i,1+kb) ! pa to mb (hpa) + plyr(i,k1) = 0.5d0 * (plvl(i,k2+1) + plvl(i,k2)) + prslk1(i,k1) = (plyr(i,k1)*0.001d0) ** rocp 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.01d0 * Statein%prsi(i,Model%levs+1) ! pa to mb (hpa) + plyr(i,k1) = 0.5d0 * (plvl(i,k1+1) + plvl(i,k1)) + prslk1(i,k1) = (plyr(i,k1)*0.001d0) ** rocp + enddo + else + k1 = lm + kd + do i = 1, IM + plvl(i,k1+1) = 0.01d0 * Statein%prsi(i,Model%levs+1) ! 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) + if ( plvl(i,lla) <= prsmin ) plvl(i,lla) = 2.0d0*prsmin + plyr(i,lyb) = 0.5d0 * 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.001d0) ** rocp ! plyr in Pa rhly(i,lyb) = rhly(i,lya) qstl(i,lyb) = qstl(i,lya) enddo @@ -1439,7 +1468,7 @@ subroutine GFS_radiation_driver & do i = 1, IM qlyr(i,k1) = max( tem1d(i), Statein%qgrs(i,k,1) ) tem1d(i) = min( QME5, qlyr(i,k1) ) - tvly(i,k1) = Statein%tgrs(i,k) * (1.0 + fvirt*qlyr(i,k1)) ! virtual T (K) + tvly(i,k1) = Statein%tgrs(i,k) * (one + fvirt*qlyr(i,k1)) ! virtual T (K) delp(i,k1) = plvl(i,k1+1) - plvl(i,k1) enddo enddo @@ -1462,7 +1491,7 @@ subroutine GFS_radiation_driver & ! --- ... level height and layer thickness (km) - tem0d = 0.001 * rog + tem0d = 0.001d0 * rog do i = 1, IM do k = 1, LMK dz(i,k) = tem0d * (tem2db(i,k+1) - tem2db(i,k)) * tvly(i,k) @@ -1490,7 +1519,7 @@ subroutine GFS_radiation_driver & do i = 1, IM qlyr(i,k) = max( tem1d(i), Statein%qgrs(i,k,1) ) tem1d(i) = min( QME5, qlyr(i,k) ) - tvly(i,k) = Statein%tgrs(i,k) * (1.0 + fvirt*qlyr(i,k)) ! virtual T (K) + tvly(i,k) = Statein%tgrs(i,k) * (one + fvirt*qlyr(i,k)) ! virtual T (K) delp(i,k) = plvl(i,k) - plvl(i,k+1) enddo enddo @@ -1513,7 +1542,7 @@ subroutine GFS_radiation_driver & ! --- ... level height and layer thickness (km) - tem0d = 0.001 * rog + tem0d = 0.001d0 * rog do i = 1, IM do k = LMK, 1, -1 dz(i,k) = tem0d * (tem2db(i,k) - tem2db(i,k+1)) * tvly(i,k) @@ -1531,7 +1560,7 @@ subroutine GFS_radiation_driver & !## CCPP ##* rrtmg_sw_pre.F90/rrtmg_sw_pre_run nday = 0 do i = 1, IM - if (Radtend%coszen(i) >= 0.0001) then + if (Radtend%coszen(i) >= 0.0001d0) then nday = nday + 1 idxday(nday) = i endif @@ -1561,7 +1590,7 @@ subroutine GFS_radiation_driver & ! --- ... obtain cloud information for radiation calculations ! if (ntcw > 0) then ! prognostic cloud schemes - ccnd = 0.0_kind_phys + ccnd = zero if (Model%ncnd == 1) then ! Zhao_Carr_Sundqvist do k=1,LMK do i=1,IM @@ -1597,7 +1626,7 @@ subroutine GFS_radiation_driver & do n=1,ncndl do k=1,LMK do i=1,IM - if (ccnd(i,k,n) < epsq) ccnd(i,k,n) = 0.0 + if (ccnd(i,k,n) < epsq) ccnd(i,k,n) = zero enddo enddo enddo @@ -1607,11 +1636,11 @@ subroutine GFS_radiation_driver & ! rsun the summation methods and order make the difference in calculation -! clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw) & -! + tracer1(:,1:LMK,Model%ntiw) & -! + tracer1(:,1:LMK,Model%ntrw) & -! + tracer1(:,1:LMK,Model%ntsw) & -! + tracer1(:,1:LMK,Model%ntgl) +! clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw) & +! + tracer1(:,1:LMK,Model%ntiw) & +! + tracer1(:,1:LMK,Model%ntrw) & +! + tracer1(:,1:LMK,Model%ntsw) & +! + tracer1(:,1:LMK,Model%ntgl) ccnd(:,:,1) = tracer1(:,1:LMK,ntcw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntrw) ccnd(:,:,1) = ccnd(:,:,1) + tracer1(:,1:LMK,ntiw) @@ -1625,7 +1654,7 @@ subroutine GFS_radiation_driver & endif do k=1,LMK do i=1,IM - if (ccnd(i,k,1) < EPSQ ) ccnd(i,k,1) = 0.0 + if (ccnd(i,k,1) < EPSQ ) ccnd(i,k,1) = zero enddo enddo endif @@ -1666,7 +1695,7 @@ subroutine GFS_radiation_driver & ! effrl(i,k1) ! endif ! if(effrs(i,k1)==0.0) then -! write(6,*) 'rad driver:snow mixing ratio:',Model%kdt, i,k1, & +! write(6,*) 'rad driver:snow mixing ratio:',Model%kdt, i,k1, & ! tracer1(i,k,ntsw) ! endif ! endif @@ -1675,7 +1704,7 @@ subroutine GFS_radiation_driver & endif else ! neither of the other two cases - cldcov = 0.0 + cldcov = zero endif ! @@ -1698,17 +1727,17 @@ subroutine GFS_radiation_driver & do k=1,lm k1 = k + kd do i=1,im - deltaq(i,k1) = 0.0 + deltaq(i,k1) = zero cnvw (i,k1) = Tbd%phy_f3d(i,k,Model%num_p3d+1) - cnvc (i,k1) = 0.0 + cnvc (i,k1) = zero enddo enddo else ! all the rest do k=1,lmk do i=1,im - deltaq(i,k) = 0.0 - cnvw (i,k) = 0.0 - cnvc (i,k) = 0.0 + deltaq(i,k) = zero + cnvw (i,k) = zero + cnvc (i,k) = zero enddo enddo endif @@ -1739,71 +1768,71 @@ subroutine GFS_radiation_driver & ! or unified cloud and/or with MG microphysics if (Model%uni_cld .and. ncld >= 2) then - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, &! --- inputs + 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 + clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs else - call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs + 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 + clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs endif elseif(Model%imp_physics == 98) then ! zhao/moorthi's prognostic cloud+pdfcld - call progcld3 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs + call progcld3 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs ccnd(1:IM,1:LMK,1), & 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 + clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs elseif (Model%imp_physics == 11) then ! GFDL cloud scheme if (.not.Model%lgfdlmprad) then - call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, &! --- inputs + call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs 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 + clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs else - call progclduni (plyr, plvl, tlyr, tvly, ccnd, ncndl, &! --- inputs + 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 progcld4o (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly, & ! --- inputs + clouds, cldsa, mtopa, mbota, de_lgth) ! --- 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 +! clouds, cldsa, mtopa, mbota, de_lgth) ! --- outputs endif - elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6) then ! Thompson / WSM6 cloud micrphysics scheme + elseif(Model%imp_physics == 8 .or. Model%imp_physics == 6) then ! Thompson / WSM6 cloud micrphysics scheme if (Model%kdt == 1) then - Tbd%phy_f3d(:,:,1) = 10. - Tbd%phy_f3d(:,:,2) = 50. - Tbd%phy_f3d(:,:,3) = 250. + Tbd%phy_f3d(:,:,1) = 10.0d0 + Tbd%phy_f3d(:,:,2) = 50.0d0 + Tbd%phy_f3d(:,:,3) = 250.0d0 endif - call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs + call progcld5 (plyr,plvl,tlyr,qlyr,qstl,rhly,tracer1, & ! --- inputs Grid%xlat,Grid%xlon,Sfcprop%slmsk,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 + 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 endif ! end if_imp_physics @@ -1817,12 +1846,11 @@ subroutine GFS_radiation_driver & ! --- scale random patterns for surface perturbations with ! perturbation size ! --- turn vegetation fraction pattern into percentile pattern - alb1d(:) = 0. + alb1d(:) = zero if (Model%do_sfcperts) then - if (Model%pertalb(1) > 0.) then + if (Model%pertalb(1) > zero) then do i=1,im - call cdfnor(Coupling%sfc_wts(i,5),cdfz) - alb1d(i) = cdfz + call cdfnor(Coupling%sfc_wts(i,5),alb1d(i)) enddo endif endif @@ -1846,17 +1874,17 @@ subroutine GFS_radiation_driver & sfcalb) ! --- outputs !> -# Approximate mean surface albedo from vis- and nir- diffuse values. - Radtend%sfalb(:) = max(0.01, 0.5 * (sfcalb(:,2) + sfcalb(:,4))) + Radtend%sfalb(:) = max(0.01d0, 0.5d0 * (sfcalb(:,2) + sfcalb(:,4))) !*## CCPP ## -!## CCPP ##* radsw_main.f/rrtmg_sw_run; Note: The checks for nday and lsswr are included in the scheme (returns if +!## CCPP ##* radsw_main.f/rrtmg_sw_run; Note: The checks for nday and lsswr are included in the scheme (returns if ! nday <= 0 or lsswr == F). Optional arguments are used to handle the different calls below. if (nday > 0) then !> - Call module_radsw_main::swrad(), to compute SW heating rates and !! fluxes. ! print *,' in grrad : calling swrad' - + if (Model%swhtr) then call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs gasvmr, clouds, Tbd%icsdsw, faersw, & @@ -1886,7 +1914,7 @@ subroutine GFS_radiation_driver & ! We are assuming that radiative tendencies are from bottom to top ! --- repopulate the points above levr i.e. LM if (lm < levs) then - do k = lm,levs + do k = lp1,levs Radtend%htrsw (1:im,k) = Radtend%htrsw (1:im,LM) enddo endif @@ -1898,7 +1926,7 @@ subroutine GFS_radiation_driver & enddo ! --- repopulate the points above levr i.e. LM if (lm < levs) then - do k = lm,levs + do k = lp1,levs Radtend%swhc(1:im,k) = Radtend%swhc(1:im,LM) enddo endif @@ -1922,26 +1950,26 @@ subroutine GFS_radiation_driver & else ! if_nday_block - Radtend%htrsw(:,:) = 0.0 + Radtend%htrsw(:,:) = zero Radtend%sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) Diag%topfsw = topfsw_type( 0.0, 0.0, 0.0 ) scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) do i=1,im - Coupling%nirbmdi(i) = 0.0 - Coupling%nirdfdi(i) = 0.0 - Coupling%visbmdi(i) = 0.0 - Coupling%visdfdi(i) = 0.0 - - Coupling%nirbmui(i) = 0.0 - Coupling%nirdfui(i) = 0.0 - Coupling%visbmui(i) = 0.0 - Coupling%visdfui(i) = 0.0 + Coupling%nirbmdi(i) = zero + Coupling%nirdfdi(i) = zero + Coupling%visbmdi(i) = zero + Coupling%visdfdi(i) = zero + + Coupling%nirbmui(i) = zero + Coupling%nirdfui(i) = zero + Coupling%visbmui(i) = zero + Coupling%visdfui(i) = zero enddo if (Model%swhtr) then - Radtend%swhc(:,:) = 0 + Radtend%swhc(:,:) = zero endif endif ! end_if_nday @@ -1965,14 +1993,14 @@ subroutine GFS_radiation_driver & 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 !*## CCPP ## !> - Call module_radlw_main::lwrad(), to compute LW heating rates and !! fluxes. ! print *,' in grrad : calling lwrad' -!## CCPP ##* radlw_main.f/rrtmg_lw_run; Note: The check lslwr is included in the scheme (returns if +!## CCPP ##* radlw_main.f/rrtmg_lw_run; Note: The check lslwr is included in the scheme (returns if ! lslwr == F). Optional arguments are used to handle the different calls below. if (Model%lwhtr) then call lwrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, gasvmr, & ! --- inputs @@ -2001,7 +2029,7 @@ subroutine GFS_radiation_driver & enddo ! --- repopulate the points above levr if (lm < levs) then - do k = lm,levs + do k = lm+1,levs Radtend%htrlw (1:im,k) = Radtend%htrlw (1:im,LM) enddo endif @@ -2013,8 +2041,8 @@ subroutine GFS_radiation_driver & enddo ! --- repopulate the points above levr if (lm < levs) then - do k = lm,levs - Radtend%lwhc(1:im,k) = Radtend%lwhc(1:im,LM) + do k = lm+1,levs + Radtend%lwhc(1:im,k) = Radtend%lwhc(1:im,LM) enddo endif endif @@ -2070,7 +2098,7 @@ subroutine GFS_radiation_driver & ! part of sw calling interval, while coszdg= mean cosz over entire interval if (Model%lsswr) then do i = 1, IM - if (Radtend%coszen(i) > 0.) then + if (Radtend%coszen(i) > zero) then ! --- sw total-sky fluxes ! ------------------- tem0d = Model%fhswr * Radtend%coszdg(i) / Radtend%coszen(i) @@ -2130,7 +2158,7 @@ subroutine GFS_radiation_driver & tem0d = raddt * cldsa(i,j) itop = mtopa(i,j) - kd ibtc = mbota(i,j) - kd - tem1 = 0. + tem1 = zero do k=ibtc,itop tem1 = tem1 + cldtausw(i,k) ! approx .55 um channel enddo @@ -2145,11 +2173,11 @@ subroutine GFS_radiation_driver & tem0d = raddt * cldsa(i,j) itop = mtopa(i,j) - kd ibtc = mbota(i,j) - kd - tem2 = 0. + tem2 = zero do k=ibtc,itop tem2 = tem2 + cldtaulw(i,k) ! approx 10. um channel enddo - Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (1.0-exp(-tem2)) + Diag%fluxr(i,46-j) = Diag%fluxr(i,46-j) + tem0d * (one-exp(-tem2)) enddo enddo endif diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 84e345633..c5c16ed4e 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -245,6 +245,8 @@ module GFS_typedefs real (kind=kind_phys), pointer :: zorl (:) => null() !< composite surface roughness in cm real (kind=kind_phys), pointer :: zorlo (:) => null() !< ocean surface roughness in cm real (kind=kind_phys), pointer :: zorll (:) => null() !< land surface roughness in cm + real (kind=kind_phys), pointer :: zorli (:) => null() !< ice surface roughness in cm + real (kind=kind_phys), pointer :: zorlw (:) => null() !< wave surface roughness in cm real (kind=kind_phys), pointer :: fice (:) => null() !< ice fraction over open water grid ! real (kind=kind_phys), pointer :: hprim (:) => null() !< topographic standard deviation in m real (kind=kind_phys), pointer :: hprime (:,:) => null() !< orographic metrics @@ -439,13 +441,13 @@ module GFS_typedefs real (kind=kind_phys), pointer :: dtsfcin_cpl(:) => null() !< aoi_fld%dtsfcin(item,lan) real (kind=kind_phys), pointer :: dqsfcin_cpl(:) => null() !< aoi_fld%dqsfcin(item,lan) real (kind=kind_phys), pointer :: ulwsfcin_cpl(:)=> null() !< aoi_fld%ulwsfcin(item,lan) - real (kind=kind_phys), pointer :: tseain_cpl(:) => null() !< aoi_fld%tseain(item,lan) - real (kind=kind_phys), pointer :: tisfcin_cpl(:) => null() !< aoi_fld%tisfcin(item,lan) - real (kind=kind_phys), pointer :: ficein_cpl(:) => null() !< aoi_fld%ficein(item,lan) - real (kind=kind_phys), pointer :: hicein_cpl(:) => null() !< aoi_fld%hicein(item,lan) +! real (kind=kind_phys), pointer :: tseain_cpl(:) => null() !< aoi_fld%tseain(item,lan) +! real (kind=kind_phys), pointer :: tisfcin_cpl(:) => null() !< aoi_fld%tisfcin(item,lan) +! real (kind=kind_phys), pointer :: ficein_cpl(:) => null() !< aoi_fld%ficein(item,lan) +! real (kind=kind_phys), pointer :: hicein_cpl(:) => null() !< aoi_fld%hicein(item,lan) real (kind=kind_phys), pointer :: hsnoin_cpl(:) => null() !< aoi_fld%hsnoin(item,lan) !--- only variable needed for cplwav2atm=.TRUE. - real (kind=kind_phys), pointer :: zorlwav_cpl(:) => null() !< roughness length from wave model +! real (kind=kind_phys), pointer :: zorlwav_cpl(:) => null() !< roughness length from wave model !--- also needed for ice/ocn coupling - Xingren real (kind=kind_phys), pointer :: slimskin_cpl(:)=> null() !< aoi_fld%slimskin(item,lan) @@ -2227,6 +2229,8 @@ subroutine sfcprop_create (Sfcprop, IM, Model) allocate (Sfcprop%zorl (IM)) allocate (Sfcprop%zorlo (IM)) allocate (Sfcprop%zorll (IM)) + allocate (Sfcprop%zorli (IM)) + allocate (Sfcprop%zorlw (IM)) allocate (Sfcprop%fice (IM)) ! allocate (Sfcprop%hprim (IM)) allocate (Sfcprop%hprime (IM,Model%nmtvr)) @@ -2245,6 +2249,8 @@ subroutine sfcprop_create (Sfcprop, IM, Model) Sfcprop%zorl = clear_val Sfcprop%zorlo = clear_val Sfcprop%zorll = clear_val + Sfcprop%zorli = clear_val + Sfcprop%zorlw = clear_val Sfcprop%fice = clear_val ! Sfcprop%hprim = clear_val Sfcprop%hprime = clear_val @@ -2616,12 +2622,12 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%v10mi_cpl = clear_val endif - if (Model%cplwav2atm) then +! if (Model%cplwav2atm) then !--- incoming quantities - allocate (Coupling%zorlwav_cpl (IM)) +! allocate (Coupling%zorlwav_cpl (IM)) - Coupling%zorlwav_cpl = clear_val - end if +! Coupling%zorlwav_cpl = clear_val +! end if if (Model%cplflx) then !--- incoming quantities @@ -2631,10 +2637,10 @@ subroutine coupling_create (Coupling, IM, Model) allocate (Coupling%dtsfcin_cpl (IM)) allocate (Coupling%dqsfcin_cpl (IM)) allocate (Coupling%ulwsfcin_cpl (IM)) - allocate (Coupling%tseain_cpl (IM)) - allocate (Coupling%tisfcin_cpl (IM)) - allocate (Coupling%ficein_cpl (IM)) - allocate (Coupling%hicein_cpl (IM)) +! allocate (Coupling%tseain_cpl (IM)) +! allocate (Coupling%tisfcin_cpl (IM)) +! allocate (Coupling%ficein_cpl (IM)) +! allocate (Coupling%hicein_cpl (IM)) allocate (Coupling%hsnoin_cpl (IM)) Coupling%slimskin_cpl = clear_val @@ -2643,10 +2649,10 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%dtsfcin_cpl = clear_val Coupling%dqsfcin_cpl = clear_val Coupling%ulwsfcin_cpl = clear_val - Coupling%tseain_cpl = clear_val - Coupling%tisfcin_cpl = clear_val - Coupling%ficein_cpl = clear_val - Coupling%hicein_cpl = clear_val +! Coupling%tseain_cpl = clear_val +! Coupling%tisfcin_cpl = clear_val +! Coupling%ficein_cpl = clear_val +! Coupling%hicein_cpl = clear_val Coupling%hsnoin_cpl = clear_val !--- accumulated quantities diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 1c1ecc0c7..0c04b6baf 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -540,6 +540,20 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys +[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 +[zorlw] + 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 [fice] standard_name = sea_ice_concentration long_name = ice fraction over open water @@ -1812,6 +1826,13 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys +[hsnoin_cpl] + 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 [slimskin_cpl] standard_name = sea_land_ice_mask_in long_name = sea/land/ice mask input (=0/1/2) @@ -3504,14 +3525,14 @@ [min_lakeice] standard_name = lake_ice_minimum long_name = minimum lake ice value - units = ??? + units = frac dimensions = () type = real kind = kind_phys [min_seaice] standard_name = sea_ice_minimum long_name = minimum sea ice value - units = ??? + units = frac dimensions = () type = real kind = kind_phys diff --git a/gfsphysics/physics/GFS_debug.F90 b/gfsphysics/physics/GFS_debug.F90 index 57bcc0f45..2887d6e64 100644 --- a/gfsphysics/physics/GFS_debug.F90 +++ b/gfsphysics/physics/GFS_debug.F90 @@ -396,9 +396,9 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, 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 ) - end if +! if (Model%cplwav2atm) then +! call print_var(mpirank,omprank, blkno, '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 ) @@ -408,10 +408,10 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, 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%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 ) diff --git a/gfsphysics/physics/dcyc2.f b/gfsphysics/physics/dcyc2.f index a97b428b5..196148d2b 100644 --- a/gfsphysics/physics/dcyc2.f +++ b/gfsphysics/physics/dcyc2.f @@ -276,6 +276,8 @@ subroutine dcyc2t3 & else xmu(i) = 0.0 endif +! if (lprnt .and. i == ipr) write(0,*)' in dcyc3: sfcnsw=',sfcnsw(i) +! &,' sfcdsw=',sfcdsw(i),' xmu=',xmu(i) ! --- ... adjust sfc net and downward sw fluxes for zenith angle changes ! note: sfc emiss effect will not be appied here diff --git a/gfsphysics/physics/gcm_shoc.f90 b/gfsphysics/physics/gcm_shoc.f90 index f5791a049..6916dd96a 100644 --- a/gfsphysics/physics/gcm_shoc.f90 +++ b/gfsphysics/physics/gcm_shoc.f90 @@ -484,7 +484,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 @@ -528,7 +528,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.0001d0) ! tkh is eddy thermal diffussivity !Compute $c_k$ (variable Cee) for the TKE dissipation term following Deardorff (1980) @@ -732,7 +732,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.0d-20) ! 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 @@ -877,7 +877,7 @@ subroutine eddy_length() 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) @@ -937,7 +937,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.5d0*adzi(i,k)*bet(i,k)*wthv_sec(i,k) enddo enddo @@ -968,7 +968,7 @@ subroutine check_eddy() do i=1,nx - wrk = 0.1*adzl(i,k) + wrk = 0.1d0*adzl(i,k) ! Minimum 0.1 of local dz smixt(i,k) = max(wrk, min(max_eddy_length_scale,smixt(i,k))) @@ -976,7 +976,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.0d-4) then !If just above the cloud top and atmosphere is stable, set to 0.1 of local dz smixt(i,k) = wrk endif @@ -1096,7 +1096,7 @@ subroutine canuto() omega0 = a4 / (one-a5*buoy_sgs2) omega1 = omega0 / (c+c) - omega2 = omega1*f3+(5./4.)*omega0*f4 + omega2 = omega1*f3+(5.0d0/4.0d0)*omega0*f4 ! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) @@ -1119,7 +1119,7 @@ subroutine canuto() !aab ! Implemetation of the C01 approach in this subroutine is nearly complete @@ -1249,21 +1249,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.4d0 + w2_2 = 0.4d0 ! 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.0d0*wrk*wrk*wrk+Skew_w*Skew_w))),atmax)) onema = one - aterm sqrtw2t = sqrt(wrk) @@ -1347,12 +1347,12 @@ subroutine assumed_pdf() ! Skew_qw = skew_facw*Skew_w - IF (tsign > 0.4) THEN + IF (tsign > 0.4d0) THEN Skew_qw = skew_facw*Skew_w - ELSEIF (tsign <= 0.2) THEN + ELSEIF (tsign <= 0.2d0) THEN Skew_qw = zero ELSE - Skew_qw = (skew_facw/0.2) * Skew_w * (tsign-0.2) + Skew_qw = (skew_facw/0.2d0) * Skew_w * (tsign-0.2d0) ENDIF wrk1 = qw1_1 * qw1_1 @@ -1386,7 +1386,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) & @@ -1560,7 +1560,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 @@ -1574,16 +1574,10 @@ subroutine assumed_pdf() ! ,' hl=',hl(i,k),' gamaz=',gamaz(i,k),' diag_ql=',diag_ql,' qpl=',qpl(i,k)& ! ,' diag_qi=',diag_qi,' qpi=',qpi(i,k),' diag_qn =',diag_qn ,' aterm=',aterm,' onema=',onema& ! ,' qn1=',qn1 ,' qn2=',qn2,' ql1=',ql1,' ql2=',ql2 -! 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 (imp_phys > 0) then if (ncpl(i,k) > nmin) then @@ -1598,6 +1592,11 @@ subroutine assumed_pdf() 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) diff --git a/gfsphysics/physics/gcycle.F90 b/gfsphysics/physics/gcycle.F90 index b410aaa9f..64d234091 100644 --- a/gfsphysics/physics/gcycle.F90 +++ b/gfsphysics/physics/gcycle.F90 @@ -55,10 +55,12 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) STCFC1 (Model%nx*Model%ny*Model%lsoil), & SLCFC1 (Model%nx*Model%ny*Model%lsoil) + 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 ! !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ @@ -75,22 +77,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) @@ -100,7 +102,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) @@ -133,17 +140,22 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) 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) @@ -178,6 +190,7 @@ SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) CVBFCS, CVTFCS, Model%me, 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 @@ -202,7 +215,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) @@ -229,11 +247,13 @@ 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,Model%lsoil - 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) + ll = 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) + 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/gfsphysics/physics/get_prs.f b/gfsphysics/physics/get_prs.f index 5994d0e63..9ce05c904 100644 --- a/gfsphysics/physics/get_prs.f +++ b/gfsphysics/physics/get_prs.f @@ -22,8 +22,10 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, &, q(ix,levs,ntrac) real(kind=kind_phys) xcp(ix,levs), xr(ix,levs), kappa(ix,levs) real(kind=kind_phys) tem, dphib, dphit, dphi - real (kind=kind_phys), parameter :: zero=0.0, p00i=1.0e-5 - &, rkapi=1.0/rkap, rkapp1=1.0+rkap + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 + &, half=0.5d0, p00i=1.0d-5 + &, rkapi=one/rkap + &, rkapp1=one+rkap integer i, k, n ! do k=1,levs @@ -33,7 +35,7 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, enddo ! if( gen_coord_hybrid ) then ! hmhj - if( thermodyn_id.eq.3 ) then ! Enthalpy case + if( thermodyn_id == 3 ) then ! Enthalpy case ! ! hmhj : This is for generalized hybrid (Henry) with finite difference ! in the vertical and enthalpy as the prognostic (thermodynamic) @@ -47,13 +49,13 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, do k=1,levs do i=1,im kappa(i,k) = xr(i,k)/xcp(i,k) - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half prkl(i,k) = (prsl(i,k)*p00i) ** kappa(i,k) enddo enddo do k=2,levs do i=1,im - tem = 0.5 * (kappa(i,k) + kappa(i,k-1)) + tem = half * (kappa(i,k) + kappa(i,k-1)) prki(i,k-1) = (prsi(i,k)*p00i) ** tem enddo enddo @@ -61,14 +63,14 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, prki(i,1) = (prsi(i,1)*p00i) ** kappa(i,1) enddo k = levs + 1 - if (prsi(1,k) .gt. 0.0) then + if (prsi(1,k) > zero) then do i=1,im prki(i,k) = (prsi(i,k)*p00i) ** kappa(i,levs) enddo endif ! do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + phii(i,1) = zero ! Ignoring topography height here enddo DO k=1,levs do i=1,im @@ -82,16 +84,16 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, ENDDO ENDDO endif - if (prsl(1,1) <= 0.0) then + if (prsl(1,1) <= zero) then do k=1,levs do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half enddo enddo endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + phii(i,1) = zero ! Ignoring topography height here enddo call GET_R(im,ix,levs,ntrac,q,xr) DO k=1,levs @@ -110,44 +112,44 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, if (prki(1,1) <= zero .or. prkl(1,1) <= zero) then do k=1,levs do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half prkl(i,k) = (prsl(i,k)*p00i) ** rkap - enddo - enddo - do k=1,levs+1 - do i=1,im - prki(i,k) = (prsi(i,k)*p00i) ** rkap - enddo enddo + enddo + do k=1,levs+1 do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + prki(i,k) = (prsi(i,k)*p00i) ** rkap enddo - DO k=1,levs - do i=1,im - TEM = rd * T(i,k)*(1.0+NU*max(Q(i,k,1),zero)) - DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM - & / (PRSI(i,k) + PRSI(i,k+1)) - phil(i,k) = phii(i,k) + DPHI - phii(i,k+1) = phil(i,k) + DPHI + enddo + do i=1,im + phii(i,1) = zero ! Ignoring topography height here + enddo + DO k=1,levs + do i=1,im + TEM = rd * T(i,k) * (one+NU*max(Q(i,k,1),zero)) + DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM + & / (PRSI(i,k) + PRSI(i,k+1)) + phil(i,k) = phii(i,k) + DPHI + phii(i,k+1) = phil(i,k) + DPHI ! if (k == 1 .and. phil(i,k) < 0.0) write(0,*)' phil=',phil(i,k) ! &,' dphi=',dphi,' prsi=',prsi(i,k),prsi(i,k+1),' tem=',tem - ENDDO ENDDO + ENDDO endif - if (prsl(1,1) <= 0.0) then + if (prsl(1,1) <= zero) then do k=1,levs do i=1,im - prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*half enddo enddo endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + phii(i,1) = zero ! Ignoring topography height here enddo DO k=1,levs do i=1,im - TEM = rd * T(i,k)*(1.0+NU*max(Q(i,k,1),zero)) + TEM = rd * T(i,k)*(one+NU*max(Q(i,k,1),zero)) DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM & / (PRSI(i,k) + PRSI(i,k+1)) phil(i,k) = phii(i,k) + DPHI @@ -183,20 +185,20 @@ subroutine GET_PRS(im,ix,levs,ntrac,t,q, enddo enddo endif - if (prsl(1,1) <= 0.0) then + if (prsl(1,1) <= zero) then do k=1,levs do i=1,im - PRSL(i,k) = 100.0 * PRKL(i,k) ** rkapi + PRSL(i,k) = 100.0d0 * PRKL(i,k) ** rkapi enddo enddo endif - if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + if (phil(1,levs) <= zero) then ! If geopotential is not given, calculate do i=1,im - phii(i,1) = 0.0 ! Ignoring topography height here + phii(i,1) = zero ! Ignoring topography height here enddo DO k=1,levs do i=1,im - TEM = CP * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + TEM = CP * T(i,k) * (one + NU*max(Q(i,k,1),zero)) & / PRKL(i,k) DPHIB = (PRKI(i,k) - PRKL(i,k)) * TEM DPHIT = (PRKL(i,k ) - PRKI(i,k+1)) * TEM @@ -232,14 +234,14 @@ subroutine GET_PHI(im,ix,levs,ntrac,t,q, &, T(ix,levs), q(ix,levs,ntrac) real(kind=kind_phys) xr(ix,levs) real(kind=kind_phys) tem, dphib, dphit, dphi - real (kind=kind_phys), parameter :: zero=0.0 + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 integer i, k, n ! do i=1,im phii(i,1) = zero ! Ignoring topography height here enddo if( gen_coord_hybrid ) then ! hmhj - if( thermodyn_id.eq.3 ) then ! Enthalpy case + if( thermodyn_id == 3 ) then ! Enthalpy case call GET_R(im,ix,levs,ntrac,q,xr) DO k=1,levs do i=1,im @@ -256,7 +258,7 @@ subroutine GET_PHI(im,ix,levs,ntrac,t,q, else ! gc Virtual Temp DO k=1,levs do i=1,im - TEM = RD * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + TEM = RD * T(i,k) * (one + NU*max(Q(i,k,1),zero)) DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM & /(PRSI(i,k) + PRSI(i,k+1)) phil(i,k) = phii(i,k) + DPHI @@ -267,7 +269,7 @@ subroutine GET_PHI(im,ix,levs,ntrac,t,q, else ! Not gc Virt Temp (Orig Joe) DO k=1,levs do i=1,im - TEM = CP * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + TEM = CP * T(i,k) * (one + NU*max(Q(i,k,1),zero)) & / PRKL(i,k) DPHIB = (PRKI(i,k) - PRKL(i,k)) * TEM DPHIT = (PRKL(i,k ) - PRKI(i,k+1)) * TEM @@ -285,7 +287,7 @@ subroutine GET_CPR(im,ix,levs,ntrac,q,xcp,xr) USE tracer_const implicit none ! - real (kind=kind_phys), parameter :: zero=0.0 + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 integer im, ix, levs, ntrac real(kind=kind_phys) q(ix,levs,ntrac) real(kind=kind_phys) xcp(ix,levs),xr(ix,levs),sumq(ix,levs) @@ -307,8 +309,8 @@ subroutine GET_CPR(im,ix,levs,ntrac,q,xcp,xr) enddo do k=1,levs do i=1,im - xr(i,k) = (1.-sumq(i,k))*ri(0) + xr(i,k) - xcp(i,k) = (1.-sumq(i,k))*cpi(0) + xcp(i,k) + xr(i,k) = (one-sumq(i,k))*ri(0) + xr(i,k) + xcp(i,k) = (one-sumq(i,k))*cpi(0) + xcp(i,k) enddo enddo ! @@ -320,7 +322,7 @@ subroutine GET_R(im,ix,levs,ntrac,q,xr) USE tracer_const implicit none ! - real (kind=kind_phys), parameter :: zero=0.0 + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 integer im, ix, levs, ntrac real(kind=kind_phys) q(ix,levs,ntrac) real(kind=kind_phys) xr(ix,levs),sumq(ix,levs) @@ -329,7 +331,7 @@ subroutine GET_R(im,ix,levs,ntrac,q,xr) sumq = zero xr = zero do n=1,ntrac - if( ri(n) > 0.0 ) then + if( ri(n) > zero ) then do k=1,levs do i=1,im xr(i,k) = xr(i,k) + q(i,k,n) * ri(n) @@ -340,7 +342,7 @@ subroutine GET_R(im,ix,levs,ntrac,q,xr) enddo do k=1,levs do i=1,im - xr(i,k) = (1.-sumq(i,k))*ri(0) + xr(i,k) + xr(i,k) = (one-sumq(i,k))*ri(0) + xr(i,k) enddo enddo ! @@ -352,7 +354,7 @@ subroutine GET_CP(im,ix,levs,ntrac,q,xcp) USE tracer_const implicit none ! - real (kind=kind_phys), parameter :: zero=0.0 + real (kind=kind_phys), parameter :: zero=0.0d0, one=1.0d0 integer im, ix, levs, ntrac real(kind=kind_phys) q(ix,levs,ntrac) real(kind=kind_phys) xcp(ix,levs),sumq(ix,levs) @@ -361,7 +363,7 @@ subroutine GET_CP(im,ix,levs,ntrac,q,xcp) sumq = zero xcp = zero do n=1,ntrac - if( cpi(n) > 0.0 ) then + if( cpi(n) > zero ) then do k=1,levs do i=1,im xcp(i,k) = xcp(i,k) + q(i,k,n) * cpi(n) @@ -372,7 +374,7 @@ subroutine GET_CP(im,ix,levs,ntrac,q,xcp) enddo do k=1,levs do i=1,im - xcp(i,k) = (1.-sumq(i,k))*cpi(0) + xcp(i,k) + xcp(i,k) = (one-sumq(i,k))*cpi(0) + xcp(i,k) enddo enddo ! diff --git a/gfsphysics/physics/m_micro_driver.F90 b/gfsphysics/physics/m_micro_driver.F90 index 8801a05c2..276a2f3bc 100644 --- a/gfsphysics/physics/m_micro_driver.F90 +++ b/gfsphysics/physics/m_micro_driver.F90 @@ -52,11 +52,12 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & !------------------------------------ ! input ! real, parameter :: r_air = 3.47d-3 - real, parameter :: one=1.0, oneb3=one/3.0, onebcp=one/cp, & + real, parameter :: one=1.0d0, oneb3=one/3.0d0, onebcp=one/cp, & + zero=0.0d0, half=0.5d0, onebg=one/grav, & & 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 + & qsmall=1.0d-14, rainmin = 1.0d-13, & + & fourb3=4.0d0/3.0d0, RL_cub=1.0d-15, nmin=1.0d0 integer, parameter :: ncolmicro = 1 integer,intent(in) :: im, ix,lm, ipr, kdt, fprcp, pdfflag @@ -218,27 +219,28 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! 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 & + real (kind=kind_phys), parameter :: disp_liu=1.0d0 & + &, ui_scale=1.0d0 & + &, dcrit=1.0d-6 & ! &, ts_autice=1800.0 & ! &, ts_autice=3600.0 & !time scale - &, ninstr8 = 0.1e6 & - &, ncnstr8 = 100.0e6 + &, ninstr8 = 0.1d6 & + &, ncnstr8 = 100.0d6 real(kind=kind_phys):: k_gw, maxkh, tausurf_gw, overscale, tx1, rh1_r8 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.05d0 ! 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.0d0, fsoot_drop=0.1d0 & + &, sigma_nuc_r8=0.28d0,SCLMFDFR=0.03d0 +! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1d0 type (AerProps), dimension (IM,LM) :: AeroProps type (AerProps) :: AeroAux, AeroAux_b @@ -295,9 +297,9 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CNV_UPDF(i,k) = cf_upi(i,ll) CNV_DQLDT(I,K) = CNV_DQLDT_i(I,ll) CLCN(I,k) = CLCN_i(I,ll) - CLLS(I,k) = 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.01d0 + 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) @@ -311,8 +313,8 @@ subroutine m_micro_driver(im, ix, 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.01d0 ! interface pressure in hPa + zet(i,k+1) = phii(i,ll) * onebg END DO END DO if (.not. skip_macro) then @@ -340,7 +342,6 @@ subroutine m_micro_driver(im, ix, 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) @@ -356,9 +357,9 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & CNV_UPDF(i,k) = cf_upi(i,k) CNV_DQLDT(I,K) = CNV_DQLDT_i(I,k) CLCN(I,k) = CLCN_i(I,k) - CLLS(I,k) = 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.01d0 + 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) @@ -371,8 +372,8 @@ subroutine m_micro_driver(im, ix, 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.01d0 ! interface pressure in hPa + zet(i,k+1) = phii(i,k) * onebg END DO END DO if (.not. skip_macro) then @@ -409,19 +410,19 @@ subroutine m_micro_driver(im, ix, 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.0d0), 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.0d0), 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.0d0), nmin) endif enddo @@ -434,8 +435,8 @@ subroutine m_micro_driver(im, ix, 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.0d-9) .and. & + & (CNV_DQLDT(I,K+1) > 1.0d-9)) then KCT(I) = K+1 exit end if @@ -515,8 +516,8 @@ subroutine m_micro_driver(im, ix, 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.55d-7*tx1**2.5d0*(rgas*0.01d0) / ple(i,l) !kh molecule diff only needing refinement enddo end do do i=1,im @@ -525,38 +526,38 @@ subroutine m_micro_driver(im, ix, 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.15d0*ZPBL(i),0.4d0*zlo(i,lm-1))& + & + one/(zlo(i,l)*0.4d0) ) + + 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.d-8 + rhu00r8(l) = 0.95d0 - 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.0d-7 enddo enddo @@ -590,14 +591,14 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & if (iccn == 2) then AERMASSMIX(:,:,1:ntrcaer) = aerfld_i(:,:,1:ntrcaer) else - AERMASSMIX(:,:,1:5) = 1.e-6 - AERMASSMIX(:,:,6:15) = 2.e-14 - end if + AERMASSMIX(:,:,1:5) = 1.0d-6 + AERMASSMIX(:,:,6:15) = 2.0d-14 + endif 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 @@ -608,58 +609,58 @@ subroutine m_micro_driver(im, ix, 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.0d0) 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.0d0) ! 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.0d0*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.0d0*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.01d0 .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.0d0) ! 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.0d0*npre8(k)*900.0d0*PI))**(one/3.0d0) else - dpre8(k) = 1.0e-9 + dpre8(k) = 1.0d-9 endif wparc_ls(k) = -omegr8(k) / (rho_gw(k)*GRAV) & & + cpbg * radheat(i,k) ! & + cpbg * rad_cooling(k) enddo do k=0,lm - pi_gw(k) = 100.0*PLE(I,k) - rhoi_gw(k) = 0.0 - ni_gw(k) = 0.0 - ti_gw(k) = 0.0 + pi_gw(k) = 100.0d0*PLE(I,k) + rhoi_gw(k) = zero + ni_gw(k) = zero + ti_gw(k) = zero enddo @@ -672,37 +673,37 @@ subroutine m_micro_driver(im, ix, 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.005d0) 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.0d0*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.133d0 - wparc_cgw(k) = 0.0 + wparc_cgw(k) = zero end do !!!======== Subgrid variability from Convective Sources According to Barahona et al. 2014 in prep 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.56d0* & + & 1.806d0*c2_gw*c2_gw)*Wct*0.133d0 enddo end if do k=1,lm - dummyW(k) = 0.133*k_gw*uwind_gw(k)/nm_gw(k) + dummyW(k) = 0.133d0*k_gw*uwind_gw(k)/nm_gw(k) enddo do K=1, LM-5, 1 @@ -712,8 +713,8 @@ subroutine m_micro_driver(im, ix, 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 @@ -722,25 +723,25 @@ subroutine m_micro_driver(im, ix, 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.0d0 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.1d0 .and. ZPBL(I) < 800.0d0 .and. & + & TEMP(I,LM) < 298.0d0 .and. TEMP(I,LM) > 274.0d0 ) 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.01d0,10.0d0),-10.0d0) + 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.17d0), 0.3d0) do K = 1, LM - wparc_turb(k) = (1.0-dummyW(k))*wparc_turb(k) & - & + dummyW(k)*maxkh + 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.2d0) @@ -758,11 +759,11 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & do K = 1, LM - if (plevr8(K) > 70.0) then + if (plevr8(K) > 70.0d0) then - ccn_diag(1) = 0.001 - ccn_diag(2) = 0.004 - ccn_diag(3) = 0.01 + ccn_diag(1) = 0.001d0 + ccn_diag(2) = 0.004d0 + ccn_diag(3) = 0.01d0 if (K > 2 .and. K <= LM-2) then tauxr8 = (ter8(K-1) + ter8(K+1) + ter8(K)) * oneb3 @@ -772,8 +773,8 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & AeroAux = AeroProps(I, K) - pfrz_inc_r8(k) = 0.0 - rh1_r8 = 0.0 !related to cnv_dql_dt, needed to changed soon + pfrz_inc_r8(k) = zero + rh1_r8 = 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 & @@ -793,7 +794,7 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! & 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.0d-12) 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) @@ -802,31 +803,31 @@ subroutine m_micro_driver(im, ix, 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.0d0 +! 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.0d-6 + NLIM_NUC(I,k) = nlimicer8(k) * 1.0d-6 + SC_ICE(I,k) = min(max(sc_icer8(k),one),2.0d0) ! 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) @@ -836,13 +837,13 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & 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.5d0) 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.5d0) SC_ICE(i,k) = ((tice-temp(i,k))*tx1 + & (temp(i,k)-t_ice_all)*rhc(i,k))* t_ice_denom endif @@ -851,14 +852,14 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & 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.0d-6 + NHET_DHF(I,k) = nhet_dhfr8(k) * 1.0d-6 + DUST_IMM(I,k) = max(dust_immr8(k), zero)*1.0d-6 + DUST_DEP(I,k) = max(dust_depr8(k), zero)*1.0d-6 + DUST_DHF(I,k) = max(dust_dhfr8(k), zero)*1.0d-6 + WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8d0 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) @@ -971,24 +972,24 @@ subroutine m_micro_driver(im, ix, 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.0d-6) 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 (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 @@ -1044,21 +1045,21 @@ subroutine m_micro_driver(im, ix, 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 @@ -1069,35 +1070,35 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & !============================================================================================= 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.0d-7 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.00001d0), 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) @@ -1111,23 +1112,23 @@ subroutine m_micro_driver(im, ix, 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.001d0) then nimmr8(k) = min(DNHET_IMM(I,k),ncr8(k)/(cldfr8(k)*DT_MOIST)) else - nimmr8(k) = 0.0 + nimmr8(k) = zero endif @@ -1138,7 +1139,7 @@ subroutine m_micro_driver(im, ix, 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 @@ -1147,11 +1148,11 @@ subroutine m_micro_driver(im, ix, 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.0d0 + rpdelr8(k) = one / pdelr8(k) + plevr8(k) = 100.0d0 * 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.0d-10) omegr8(k) = WSUB(I,k) ! alphar8(k) = max(alpht_x(i,k)/maxval(alpht_x(i,:))*8.,0.5) ! alphar8(k) = qcvar2 @@ -1159,12 +1160,12 @@ subroutine m_micro_driver(im, ix, 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.0d0 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 @@ -1244,8 +1245,8 @@ subroutine m_micro_driver(im, ix, 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.0d0*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0d0*precir8(1), zero) do k=1,lm @@ -1256,17 +1257,17 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & ! &,' qvlatr8=',qvlatr8(k) TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp - NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, 0.0) - NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, 0.0) + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, 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.0d0), 150.0d0) + CLDREFFI(I,k) = min(max(effir8(k), 20.0d0), 150.0d0) + CLDREFFR(I,k) = max(droutr8(k)*0.5d0*1.0d6, 150.0d0) + CLDREFFS(I,k) = max(0.192d0*dsoutr8(k)*0.5d0*1.0d6, 250.0d0) enddo ! K loop @@ -1348,8 +1349,8 @@ subroutine m_micro_driver(im, ix, 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.0d0*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0d0*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 @@ -1358,15 +1359,15 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & 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) + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, zero) + NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, zero) + NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, zero) - 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.) + CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0),150.0d0) + CLDREFFI(I,k) = min(max(effir8(k), 20.0d0),150.0d0) + CLDREFFR(I,k) = max(reff_rain(k),150.0d0) + CLDREFFS(I,k) = max(reff_snow(k),250.0d0) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1374,13 +1375,13 @@ subroutine m_micro_driver(im, ix, 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.0d0 + CLDREFFI(I,k) = 50.0d0 + CLDREFFR(I,k) = 1000.0d0 + CLDREFFS(I,k) = 250.0d0 enddo ! K loop endif ! @@ -1484,8 +1485,8 @@ subroutine m_micro_driver(im, ix, 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.0d0*(prectr8(1)-precir8(1)), zero) + LS_SNR(I) = max(1000.0d0*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 @@ -1495,17 +1496,17 @@ subroutine m_micro_driver(im, ix, lm, flipv, dt_i & 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.) + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k)*DT_R8, zero) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k)*DT_R8, zero) + NCPR(I,k) = max(NCPR(I,k) + nrtend(k)*dt_r8, zero) + NCPS(I,k) = max(NCPS(I,k) + nstend(k)*dt_r8, zero) + NCGL(I,k) = max(NCGL(I,k) + ngtend(k)*dt_r8, zero) + + CLDREFFL(I,k) = min(max(effcr8(k), 10.0d0),150.0d0) + CLDREFFI(I,k) = min(max(effir8(k), 20.0d0),150.0d0) + CLDREFFR(I,k) = max(reff_rain(k),150.0d0) + CLDREFFS(I,k) = max(reff_snow(k),250.0d0) + CLDREFFG(I,k) = max(reff_grau(k),250.0d0) enddo ! K loop ! if (lprint) then ! write(0,*)' aft micro_mg_tend temp= ', temp(i,:) @@ -1513,14 +1514,14 @@ subroutine m_micro_driver(im, ix, 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.0d0 + CLDREFFI(I,k) = 50.0d0 + CLDREFFR(I,k) = 1000.0d0 + CLDREFFS(I,k) = 250.0d0 + CLDREFFG(I,k) = 250.0d0 enddo ! K loop endif endif @@ -1547,19 +1548,19 @@ subroutine m_micro_driver(im, ix, 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.0d0), 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.0d0), 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.0d0), nmin) endif enddo enddo @@ -1586,19 +1587,19 @@ subroutine m_micro_driver(im, ix, 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.0d0), 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.0d0), 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.0d0), nmin) endif enddo enddo @@ -1612,8 +1613,8 @@ subroutine m_micro_driver(im, ix, 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 @@ -1645,7 +1646,7 @@ subroutine m_micro_driver(im, ix, 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 @@ -1676,7 +1677,7 @@ subroutine m_micro_driver(im, ix, 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 @@ -1690,12 +1691,12 @@ subroutine m_micro_driver(im, ix, 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.001d0 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 @@ -1759,7 +1760,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.0d0/cp, n2min=1.0d-8 !---------------------------Local storage------------------------------- integer :: ix,kx @@ -1775,15 +1776,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.0d0+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.5d0 * (t(ix,kx) + t(ix,kx+1)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)*(1.0d0+0.5d0*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)) @@ -1795,7 +1796,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.0d0+fv*sph(ix,kx))) ni(ix,kx) = ni(ix,kx-1) end do @@ -1804,7 +1805,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.5d0 * (ni(ix,kx-1) + ni(ix,kx)) end do end do @@ -1827,7 +1828,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/gfsphysics/physics/micro_mg3_0.F90 b/gfsphysics/physics/micro_mg3_0.F90 index a9df06c6c..b170ccd70 100644 --- a/gfsphysics/physics/micro_mg3_0.F90 +++ b/gfsphysics/physics/micro_mg3_0.F90 @@ -316,7 +316,7 @@ subroutine micro_mg_init( & !----------------------------------------------------------------------- - dcs = micro_mg_dcs * 1.0e-6 + dcs = micro_mg_dcs * 1.0d-6 ts_au_min = ts_auto(1) ts_au = ts_auto(2) qcvar = mg_qcvar @@ -1073,7 +1073,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 @@ -3175,9 +3175,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 @@ -3779,9 +3779,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 @@ -4030,7 +4030,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/gfsphysics/physics/micro_mg_utils.F90 b/gfsphysics/physics/micro_mg_utils.F90 index ab20ec7cf..ffd13c2d5 100644 --- a/gfsphysics/physics/micro_mg_utils.F90 +++ b/gfsphysics/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 @@ -1101,12 +1101,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))) @@ -2156,7 +2156,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)* & @@ -2208,7 +2208,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) @@ -2353,8 +2353,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) @@ -2717,10 +2717,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/gfsphysics/physics/module_nst_model.f90 b/gfsphysics/physics/module_nst_model.f90 index f2b05c110..7154489f6 100644 --- a/gfsphysics/physics/module_nst_model.f90 +++ b/gfsphysics/physics/module_nst_model.f90 @@ -846,7 +846,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/gfsphysics/physics/module_nst_water_prop.f90 b/gfsphysics/physics/module_nst_water_prop.f90 index 36a699ede..ffc7f4896 100644 --- a/gfsphysics/physics/module_nst_water_prop.f90 +++ b/gfsphysics/physics/module_nst_water_prop.f90 @@ -5,7 +5,7 @@ module module_nst_water_prop private public :: rhocoef,density,sw_rad,sw_rad_aw,sw_rad_sum,sw_rad_upper,sw_rad_upper_aw,sw_rad_skin,grv,solar_time_from_julian,compjd, & sw_ps_9b,sw_ps_9b_aw,get_dtzm_point,get_dtzm_2d - + ! interface sw_ps_9b module procedure sw_ps_9b @@ -37,7 +37,7 @@ module module_nst_water_prop subroutine rhocoef(t, s, rhoref, alpha, beta) ! ------------------------------------------------------ - ! compute thermal expansion coefficient (alpha) + ! compute thermal expansion coefficient (alpha) ! and saline contraction coefficient (beta) using ! the international equation of state of sea water ! (1980). ref: pond and pickard, introduction to @@ -45,26 +45,26 @@ subroutine rhocoef(t, s, rhoref, alpha, beta) ! note: compression effects are not included implicit none - real(kind=kind_phys), intent(in) :: t, s, rhoref - real(kind=kind_phys), intent(out) :: alpha, beta + real(kind=kind_phys), intent(in) :: t, s, rhoref + real(kind=kind_phys), intent(out) :: alpha, beta real(kind=kind_phys) :: tc tc = t - t0k - 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 & - + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & - + 4.0 * 5.3875e-9 * tc**3 * s & + 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 & + + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & + + 4.0 * 5.3875e-9 * tc**3 * s & + 1.0227e-4 * s**1.5 - 2.0 * 1.6546e-6 * tc * s**1.5 ! note: rhoref - specify ! 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 & @@ -84,13 +84,13 @@ subroutine density(t, s, rho) real(kind=kind_phys), intent(in) :: t !unit, k real(kind=kind_phys), intent(in) :: s !unit, 1/1000 ! output - real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 + real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 ! local real(kind=kind_phys) :: tc - ! compute density using the international equation - ! of state of sea water 1980, (pond and pickard, - ! introduction to dynamical oceanography, pp310). + ! compute density using the international equation + ! of state of sea water 1980, (pond and pickard, + ! introduction to dynamical oceanography, pp310). ! compression effects are not included rho = 0.0 @@ -114,7 +114,7 @@ end subroutine density ! elemental subroutine sw_ps_9b(z,fxp) ! - ! fraction of the solar radiation absorbed by the ocean at the depth z + ! fraction of the solar radiation absorbed by the ocean at the depth z ! following paulson and simpson, 1981 ! ! input: @@ -146,7 +146,7 @@ end subroutine sw_ps_9b ! elemental subroutine sw_ps_9b_aw(z,aw) ! - ! d(fw)/d(z) for 9-band + ! d(fw)/d(z) for 9-band ! ! input: ! z: depth (m) @@ -297,8 +297,8 @@ end subroutine sw_fairall_simple_v1 elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z) ! ! solar radiation absorbed by the ocean at the depth z (zeng and beljaars, 2005, p.5) - ! - ! input: + ! + ! input: ! f_sol_0: solar radiation at the ocean surface (w/m^2) ! z: depth (m) ! @@ -324,7 +324,7 @@ elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z) ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) ! following soloviev, 1982 ! - ! input: + ! input: ! f_sol_0: solar radiation at the ocean surface (w/m^2) ! z: depth (m) ! @@ -353,8 +353,8 @@ elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) ! ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) ! following soloviev, 1982 - ! - ! input: + ! + ! input: ! f_sol_0: solar radiation at the ocean surface (w/m^2) ! z: depth (m) ! @@ -367,8 +367,8 @@ elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,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)) & + -(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 @@ -440,7 +440,7 @@ function grv(lat) c3=0.0000001262 c4=0.0000000007 pi=3.141593 - + phi=lat*pi/180 x=sin(phi) grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) @@ -490,7 +490,7 @@ subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) ! jmnth - month ! jday - day ! jhr - hour -! jmn - minutes +! jmn - minutes ! output argument list: ! jd - julian day. ! fjd - fraction of the julian day. @@ -642,66 +642,56 @@ 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 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 - -!$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 diff --git a/gfsphysics/physics/moninshoc.f b/gfsphysics/physics/moninshoc.f index d68c001b5..c0926631a 100644 --- a/gfsphysics/physics/moninshoc.f +++ b/gfsphysics/physics/moninshoc.f @@ -65,16 +65,17 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, &, ttend, utend, vtend, qtend &, spdk2, rbint, ri, zol1, robn, bvf2 ! - real(kind=kind_phys), parameter :: gravi=1.0/grav, zolcr=0.2, - & zolcru=-0.5, rimin=-100., sfcfrac=0.1, - & crbcon=0.25, crbmin=0.15, crbmax=0.35, - & qmin=1.e-8, zfmin=1.e-8, qlmin=1.e-12, - & aphi5=5., aphi16=16., f0=1.e-4 - &, cont=cp/grav, conq=hvap/grav, conw=1.0/grav - &, dkmin=0.0, dkmax=1000. -! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 - &, gocp=grav/cp, prmin=0.25, prmax=4.0 - &, vk=0.4, cfac=6.5 + real(kind=kind_phys), parameter :: one=1.0d0, zero=0.0d0 + &, gravi=one/grav, zolcr=0.2d0 + &, zolcru=-0.5d0, rimin=-100.0d0, sfcfrac=0.1d0 + &, crbcon=0.25d0, crbmin=0.15d0, crbmax=0.35d0 + &, qmin=1.0d-8, zfmin=1.0d-8, qlmin=1.0d-12 + &, aphi5=5.0d0, aphi16=16.0d0, f0=1.0d-4 + &, cont=cp/grav, conq=hvap/grav, conw=one/grav + &, dkmin=zero, dkmax=1000.0d0 +! &, dkmin=0.0, dkmax=1000., xkzminv=0.3 + &, gocp=grav/cp, prmin=0.25d0, prmax=4.0d0 + &, vk=0.4d0, cfac=6.5d0 ! !----------------------------------------------------------------------- ! @@ -108,24 +109,24 @@ subroutine moninshoc(ix,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.0d0)) xkzo(i,k) = xkzm_h * tem1 xkzmo(i,k) = xkzm_m * tem1 endif @@ -141,9 +142,9 @@ subroutine moninshoc(ix,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.0d0) then tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) - if(tem1 > 1.e-5) then + if(tem1 > 1.0d-5) then xkzo(i,k) = min(xkzo(i,k),xkzminv) endif endif @@ -152,21 +153,21 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! ! do i = 1,im - z0(i) = 0.01 * zorl(i) + z0(i) = 0.01d0 * 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 @@ -182,7 +183,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! if (lprnt) write(0,*)' heat=',heat(ipr),' evap=',evap(ipr) do i = 1,im sflux(i) = heat(i) + evap(i)*fv*theta(i,1) - if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + if(.not.sfcflg(i) .or. sflux(i) <= zero) pblflg(i)=.false. beta(i) = dt2 / (zi(i,2)-zi(i,1)) enddo ! @@ -197,11 +198,11 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, 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.0d-7 * robn + crb(i) = max(min(0.16d0 * (tem1**(-0.18d0)), crbmax), crbmin) endif enddo do k = 1, kmpbl @@ -220,9 +221,9 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, if(kpbl(i) > 1) 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 @@ -245,13 +246,13 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, endif zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) 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) +! phim(i) = (1.-aphi16*zol1)**(-one/4.0d0) +! phih(i) = (1.-aphi16*zol1)**(-one/2.0d0) + tem = one / max(one - aphi16*zol1, 1.0d-8) 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 @@ -269,7 +270,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, do i = 1, im 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 @@ -281,9 +282,9 @@ subroutine moninshoc(ix,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 @@ -321,13 +322,13 @@ subroutine moninshoc(ix,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 + bvf2 = (0.5d0*grav)*(thvx(i,kp1)-thvx(i,k))*rdz & / (t1(i,k)+t1(i,kp1)) ri = max(bvf2/tem,rimin) - if(ri < 0.) then ! unstable regime - prnum(i,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.1d0*ri, prmax) endif elseif (k > 1) then prnum(i,kp1) = prnum(i,1) @@ -346,7 +347,7 @@ subroutine moninshoc(ix,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 @@ -380,7 +381,7 @@ subroutine moninshoc(ix,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 @@ -437,7 +438,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! 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 @@ -455,7 +456,7 @@ subroutine moninshoc(ix,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) ! @@ -482,7 +483,7 @@ subroutine moninshoc(ix,im,km,ntrac,ntcw,ncnd,dv,du,tau,rtg, ! 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 ! @@ -499,7 +500,7 @@ subroutine moninshoc(ix,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 @@ -522,26 +523,28 @@ subroutine tridi1(l,n,cl,cm,cu,r1,au,a1) ! use machine , only : kind_phys implicit none - integer k,n,l,i - real(kind=kind_phys) fk + real(kind=kind_phys), parameter :: one=1.0d0 ! real(kind=kind_phys) cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n), & & au(l,n-1),a1(l,n) +! + real(kind=kind_phys) fk + integer k,n,l,i ! 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 diff --git a/gfsphysics/physics/rad_initialize.f b/gfsphysics/physics/rad_initialize.f index 0a3d307c1..23a97e7c4 100644 --- a/gfsphysics/physics/rad_initialize.f +++ b/gfsphysics/physics/rad_initialize.f @@ -4,7 +4,7 @@ subroutine rad_initialize & ! --- inputs: & ( si,levr,ictm,isol,ico2,iaer,ialb,iems,ntcw, num_p2d, & & num_p3d,npdf3d,ntoz,iovr_sw,iovr_lw,isubc_sw,isubc_lw, & - & icliq_sw,crick_proof,ccnorm, & + & icliq_sw,crick_proof,ccnorm, & & imp_physics,norad_precip,idate,iflip,me ) ! --- outputs: ( none ) @@ -23,7 +23,7 @@ subroutine rad_initialize & ! subroutine is called at the start of model run. ! ! nov 2012 - yu-tai hou modified control parameter through ! ! module 'physparam'. ! -! mar 2014 - sarah lu iaermdl is determined from iaer ! +! mar 2014 - sarah lu iaermdl is determined from iaer ! ! jul 2014 - s moorthi add npdf3d for pdf clouds ! ! ! ! ==================== defination of variables ==================== ! @@ -54,9 +54,9 @@ subroutine rad_initialize & ! =1: use observed co2 annual mean value only ! ! =2: use obs co2 monthly data with 2-d variation ! ! iaer : 4-digit aerosol flag (dabc for aermdl,volc,lw,sw)! -! d: =0 or none, opac-climatology aerosol scheme ! -! =1 use gocart climatology aerosol scheme ! -! =2 use gocart progostic aerosol scheme ! +! d: =0 or none, opac-climatology aerosol scheme ! +! =1 use gocart climatology aerosol scheme ! +! =2 use gocart progostic aerosol scheme ! ! a: =0 use background stratospheric aerosol ! ! =1 incl stratospheric vocanic aeros ! ! b: =0 no topospheric aerosol in lw radiation ! @@ -152,7 +152,7 @@ subroutine rad_initialize & else iaerflg = mod(iaer, 1000) endif - iaermdl = iaer/1000 ! control flag for aerosol scheme selection + iaermdl = iaer/1000 ! control flag for aerosol scheme selection if ( iaermdl < 0 .or. (iaermdl>2 .and. iaermdl/=5) ) then print *, ' Error -- IAER flag is incorrect, Abort' stop 7777 diff --git a/gfsphysics/physics/radiation_surface.f b/gfsphysics/physics/radiation_surface.f index e02ea32b9..99f0ebc2f 100644 --- a/gfsphysics/physics/radiation_surface.f +++ b/gfsphysics/physics/radiation_surface.f @@ -609,7 +609,7 @@ subroutine setalb & ab1bm = min(0.99, alnsf(i)*rfcs) ab2bm = min(0.99, alvsf(i)*rfcs) sfcalb(i,1) = ab1bm *flnd + asenb*fsea + asnnb*fsno - sfcalb(i,2) = alnwf(i) *flnd + asend*fsea + asnnd*fsno + sfcalb(i,2) = alnwf(i)*flnd + asend*fsea + asnnd*fsno sfcalb(i,3) = ab2bm *flnd + asevb*fsea + asnvb*fsno sfcalb(i,4) = alvwf(i) *flnd + asevd*fsea + asnvd*fsno @@ -620,7 +620,7 @@ subroutine setalb & ! sfc-perts, mgehne *** ! perturb all 4 kinds of surface albedo, sfcalb(:,1:4) - if (pertalb(1)>0.0) then + if (pertalb(1) > 0.0) then do i = 1, imax do kk=1, 4 ! compute beta distribution parameters for all 4 albedos diff --git a/gfsphysics/physics/rascnvv2.f b/gfsphysics/physics/rascnvv2.f index 4d49889de..4ad7882ef 100644 --- a/gfsphysics/physics/rascnvv2.f +++ b/gfsphysics/physics/rascnvv2.f @@ -9,25 +9,25 @@ module module_ras 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.0d0/3600.0d0 & ! 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.0d0, adjts_s=0.5d0 ! 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) & - &, cfmax=0.1 & + real (kind=kind_phys), parameter :: ZERO=0.0d0, HALF=0.5d0 & + &, pt25=0.25d0, ONE=1.0d0 & + &, TWO=2.0d0, FOUR=4.0d0 & + &, twoo3=two/3.0d0 & + &, FOUR_P2=4.d2, ONE_M10=1.0d-10& + &, ONE_M6=1.0d-6, ONE_M5=1.0d-5 & + &, ONE_M2=1.0d-2, ONE_M1=1.0d-1 & + &, oneolog10=one/log(10.0d0) & + &, cfmax=0.1d0 & &, deg2rad=pi/180.d0 & ! conversion factor from degree to radians - &, cmb2pa = 100.0 ! Conversion from hPa to Pa + &, cmb2pa = 100.0d0 ! Conversion from hPa to Pa ! real(kind=kind_phys), parameter :: & & ONEBG = ONE / GRAV, GRAVCON = cmb2pa * ONEBG & @@ -36,15 +36,15 @@ module module_ras &, ELFOCP = (ALHL+ALHF) * onebcp & &, oneoalhl = one/alhl & &, CMPOR = CMB2PA / RGAS & - &, picon = half*pi*onebg, VTPEXP = -0.3636 & - &, dpnegcr = 150.0 & + &, picon = half*pi*onebg, VTPEXP = -0.3636d0 & + &, dpnegcr = 150.0d0 & ! &, dpnegcr = 100.0 & ! &, dpnegcr = 200.0 & ! &, ddunc1 = 0.4, ddunc2=one-ddunc1 & uncentering for vvel in dd - &, ddunc1 = 0.25, ddunc2=one-ddunc1 & uncentering for vvel in dd + &, ddunc1 = 0.25d0, ddunc2=one-ddunc1 & uncentering for vvel in dd ! &, ddunc1 = 0.3, ddunc2=one-ddunc1 & uncentering for vvel in dd - &, zfac = 0.28888889E-4 * ONEBG - &, c0ifac = 0.07 ! following Han et al, 2016 MWR + &, zfac = 0.28888889d-4 * ONEBG + &, c0ifac = 0.07d0 ! following Han et al, 2016 MWR ! ! logical, parameter :: advcld=.true., advups=.true., advtvd=.false. logical, parameter :: advcld=.true., advups=.false., advtvd=.true. @@ -56,16 +56,16 @@ module module_ras &, testmboalhl, testmbi ! PARAMETER (DD_DP=0.0, RKNOB=1.0, EKNOB=1.0) ! No downdraft! - PARAMETER (DD_DP=0.5, RKNOB=1.0, EKNOB=1.0) + PARAMETER (DD_DP=0.5d0, RKNOB=1.0d0, EKNOB=1.0d0) ! PARAMETER (DD_DP=0.5, RKNOB=2.0, EKNOB=1.0) ! - PARAMETER (RHMAX=1.0 ) ! MAX RELATIVE HUMIDITY - PARAMETER (QUAD_LAM=1.0) ! MASK FOR QUADRATIC LAMBDA -! PARAMETER (RHRAM=0.15) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (RHRAM=0.05) ! PBL RELATIVE HUMIDITY RAMP - PARAMETER (HCRITD=4000.0) ! Critical Moist Static Energy for Deep clouds - PARAMETER (HCRITS=2000.0) ! Critical Moist Static Energy for Shallow Clouds - PARAMETER (pcrit_lcl=250.0)! Critical pressure difference between boundary layer top + PARAMETER (RHMAX=1.0d0 ) ! MAX RELATIVE HUMIDITY + PARAMETER (QUAD_LAM=1.0d0) ! MASK FOR QUADRATIC LAMBDA +! PARAMETER (RHRAM=0.15) ! PBL RELATIVE HUMIDITY RAMP + PARAMETER (RHRAM=0.05d0) ! PBL RELATIVE HUMIDITY RAMP + PARAMETER (HCRITD=4000.0d0) ! Critical Moist Static Energy for Deep clouds + PARAMETER (HCRITS=2000.0d0) ! Critical Moist Static Energy for Shallow Clouds + PARAMETER (pcrit_lcl=250.0d0)! Critical pressure difference between boundary layer top ! and lifting condensation level (hPa) ! parameter (hpert_fac=1.01) ! Perturbation on hbl when ctei=.true. @@ -73,15 +73,15 @@ module module_ras ! parameter (hpert_fac=1.00) ! Perturbation on hbl when ctei=.true. ! parameter (qudfac=quad_lam*half, shalfac=1.0) ! parameter (qudfac=quad_lam*half, shalfac=2.0) - parameter (qudfac=quad_lam*half, shalfac=3.0) + parameter (qudfac=quad_lam*half, shalfac=3.0d0) ! parameter (qudfac=quad_lam*pt25) ! Yogesh's - parameter (testmb=0.1, testmbi=one/testmb) + parameter (testmb=0.1d0, testmbi=one/testmb) parameter (testmboalhl=testmb/alhl) ! real(kind=kind_phys) facdt - real(kind=kind_phys), parameter :: almax=1.0e-2 - &, almin1=0.0, almin2=0.0 + real(kind=kind_phys), parameter :: almax=1.0d-2 + &, almin1=0.0d0, almin2=0.0d0 ! real(kind=kind_phys) ALMIN1, ALMIN2, ALMAX ! @@ -91,7 +91,7 @@ module module_ras !cnt PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=5.0E-3) ! ! real(kind=kind_phys), parameter :: BLDMAX = 200.0 - real(kind=kind_phys), parameter :: BLDMAX = 300.0, bldmin=25.0 + real(kind=kind_phys), parameter :: BLDMAX = 300.0d0, bldmin=25.0d0 !! real(kind=kind_phys), parameter :: BLDMAX = 350.0 ! ! @@ -100,7 +100,7 @@ module module_ras ! parameter (TF=230.16, TCR=260.16, TCRF=1.0/(TCR-TF)) ! parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF),TCL=2.0) ! parameter (TF=258.16, TCR=273.16, TCRF=1.0/(TCR-TF),TCL=2.0) - parameter (TF=233.16, TCR=273.16, TCRF=1.0/(TCR-TF),TCL=2.0) + parameter (TF=233.16d0, TCR=273.16d0, TCRF=one/(TCR-TF),TCL=2.0d0) ! ! For Tilting Angle Specification ! @@ -127,7 +127,7 @@ subroutine set_ras_afc(dt) implicit none real(kind=kind_phys) DT ! AFC = -(1.04E-4*DT)*(3600./DT)**0.578 - AFC = -(1.01097E-4*DT)*(3600./DT)**0.57777778 + AFC = -(1.01097d-4*DT)*(3600.0d0/DT)**0.57777778d0 end subroutine set_ras_afc subroutine ras_init(levs, me) @@ -178,7 +178,7 @@ subroutine ras_init(levs, me) drdp(i) = (REFR(i+1)-REFR(i)) / (REFP(i+1)-REFP(i)) enddo ! - VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 + VTP = 36.34d0*SQRT(1.2d0)* (0.001d0)**0.1364d0 ! if (me == 0) write(0,*) ' NO DOWNDRAFT FOR CLOUD TYPES' & &, ' DETRAINING AT NORMALIZED PRESSURE ABOVE ',DD_DP @@ -198,11 +198,12 @@ module module_rascnv LOGICAL WRKFUN, CALKBL, CRTFUN, UPDRET, BOTOP, vsmooth, do_aw & &, CUMFRC - 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 + real(kind=kind_phys), parameter :: frac=0.5d0, crtmsf=0.0d0 & + &, rhfacs=0.75d0, rhfacl=0.75d0 & +! &, rhfacs=0.70, rhfacl=0.70 & + &, face=5.0d0, delx=10000.0d0 & + &, ddfac=face*delx*0.001d0 & + &, max_neg_bouy=0.15d0 ! &, max_neg_bouy=pt25 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -218,9 +219,9 @@ module module_rascnv ! For pressure gradient force in momentum mixing ! 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.0d0, pgfbot=0.0d0 & ! real (kind=kind_phys), parameter :: pgftop=0.55, pgfbot=0.55 & - &, pgfgrad=(pgfbot-pgftop)*0.001 + &, pgfgrad=(pgfbot-pgftop)*0.001d0 ! end module module_rascnv ! @@ -305,7 +306,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & integer, dimension(100) :: ic - real(kind=kind_phys), parameter :: clwmin=1.0e-10 + real(kind=kind_phys), parameter :: clwmin=1.0d-10 ! real(kind=kind_phys), allocatable :: ALFINT(:,:), uvi(:,:) &, trcfac(:,:), rcu(:,:) @@ -430,16 +431,16 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & 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.050d0) KRMIN = L +! IF (SGC <= 0.700d0) KRMAX = L +! IF (SGC <= 0.800d0) KRMAX = L + IF (SGC <= 0.760d0) KRMAX = L +! IF (SGC <= 0.930d0) KFMAX = L + IF (SGC <= 0.970d0) KFMAX = L ! Commented on 20060202 +! IF (SGC <= 0.700d0) kblmx = L ! Commented on 20101015 + IF (SGC <= 0.600d0) kblmx = L ! +! IF (SGC <= 0.650d0) kblmx = L ! Commented on 20060202 + IF (SGC <= 0.980d0) kblmn = L ! ENDDO krmin = max(krmin,2) @@ -449,7 +450,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! 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.10001d0 ! 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 @@ -459,7 +460,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & facdt = delt_c / dt else NCRND = min(nrcmax, (KRMAX-KRMIN+1)) - facdt = one / 3600.0 + facdt = one / 3600.0d0 endif NCRND = min(nrcm,max(NCRND, 1)) ! @@ -488,7 +489,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & 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.0005d0)*(KCR-KRMIN+1) IC(KFX+I) = IRND + KRMIN ENDDO ENDIF @@ -546,7 +547,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & if (trac > 0) then ! tracers such as O3, dust etc do n=1,trac 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.0d-20) uvi(l,n) = zero enddo endif enddo @@ -557,7 +558,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & 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) <= -999.0d0) then ! input ice/water are together do l=1,k ll = kp1 -l tem = ccin(ipt,ll,1) & @@ -595,7 +596,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & if (trac > 0) then ! tracers such as O3, dust etc do n=1,trac 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.0d-20) uvi(l,n) = zero enddo endif enddo @@ -605,7 +606,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & 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) <= -999.0d0) then ! input ice/water are together do l=1,k tem = ccin(ipt,l,1) & & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) @@ -663,7 +664,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvd=',dtvd(:,1) - if (abs(dtvd(2,1)) > 1.0e-10) then + if (abs(dtvd(2,1)) > 1.0d-10) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) alfint(l,1) = one - half*(tem1 + tem2)/(one + tem2) ! for h @@ -677,7 +678,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvd2=',dtvd(:,2) - if (abs(dtvd(2,2)) > 1.0e-10) then + if (abs(dtvd(2,2)) > 1.0d-10) then tem1 = dtvd(1,2) / dtvd(2,2) tem2 = abs(tem1) alfint(l,2) = one - half*(tem1 + tem2)/(one + tem2) ! for q @@ -688,7 +689,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvd3=',dtvd(:,3) - if (abs(dtvd(2,3)) > 1.0e-10) then + if (abs(dtvd(2,3)) > 1.0d-10) then tem1 = dtvd(1,3) / dtvd(2,3) tem2 = abs(tem1) alfint(l,3) = one - half*(tem1 + tem2)/(one + tem2) ! for ql @@ -699,7 +700,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*)' l=',l,' dtvd4=',dtvd(:,4) - if (abs(dtvd(2,4)) > 1.0e-10) then + if (abs(dtvd(2,4)) > 1.0d-10) then tem1 = dtvd(1,4) / dtvd(2,4) tem2 = abs(tem1) alfint(l,4) = one - half*(tem1 + tem2)/(one + tem2) ! for qi @@ -716,7 +717,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! 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.0d-10) then tem1 = dtvd(1,1) / dtvd(2,1) tem2 = abs(tem1) alfint(l,n+4) = one - half*(tem1 + tem2)/(one + tem2) ! for tracers @@ -858,7 +859,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! write(0,*) ' qiiin=',qii ! endif ! - TLA = -10.0 + TLA = -10.0d0 ! qiid = qii(ib) ! cloud top level ice before convection qlid = qli(ib) ! cloud top level water before convection @@ -870,7 +871,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! qli_l(ib:k) = qli(ib:k) ! qii_l(ib:k) = qii(ib:k) ! endif -! rainp = rain + rainp = rain CALL CLOUD(K, KP1, IB, ntrc, kblmx, kblmn & &, FRAC, MAX_NEG_BOUY, vsmooth, do_aw & @@ -950,7 +951,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! 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 @@ -974,7 +975,7 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! ENDDO ! End of the NC loop! ! - RAINC(ipt) = rain * 0.001 ! Output rain is in meters + RAINC(ipt) = rain * 0.001d0 ! Output rain is in meters ! if (lprint) then ! write(0,*) ' convective precip=',rain*86400/dt,' mm/day' @@ -997,9 +998,9 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & ! 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.93d0 .and. abs(tcu(l)) > one_m10) then +! if (sgcs(l,ipt) < 0.90d0 .and. tcu(l) .ne. 0.0) then +! if (sgcs(l,ipt) < 0.85d0 .and. tcu(l) .ne. 0.0) then kcnv(ipt) = 1 endif ! New test for convective clouds ! added in 08/21/96 @@ -1025,23 +1026,23 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & 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.d-10,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.d-10,qii(l)+qli(l)) endif !! CNV_PRC3(ipt,ll) = PCU(l)/dt ! CNV_PRC3(ipt,ll) = zero ! if(PCU(l) < zero) write(*,*)"AAA777",PCU(l),ipt,ll - 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.02d0*log(one+ + & 500.0d0*ud_mf(ipt,ll)/dt), cfmax)) ! & 500*ud_mf(ipt,ll)/dt), 0.60)) ! if (lprint) write(0,*)' ll=',ll,' cf_upi=',cf_upi(ipt,ll) ! &,' ud_mf=',ud_mf(ipt,ll),' dt=',dt,' cfmax=',cfmax 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.d-12)*prsl(ipt,ll)) endif if (trac > 0) then @@ -1086,21 +1087,21 @@ subroutine rascnv(IM, IX, k, dt, dtf, rannum & 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.d-10,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.d-10,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.02d0*log(one+ + & 500.0d0*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.d-12)*prsl(ipt,l)) endif if (trac > 0) then @@ -1151,7 +1152,7 @@ SUBROUTINE CRTWRK(PL, CCWF, ACR) real(kind=kind_phys) PL, CCWF, ACR INTEGER IWK ! - IWK = PL * 0.02 - 0.999999999 + IWK = PL * 0.02d0 - 0.999999999d0 IWK = MAX(1, MIN(IWK,16)) ACR = (AC(IWK) + PL * AD(IWK)) * CCWF ! @@ -1259,12 +1260,12 @@ SUBROUTINE CLOUD( & real(kind=kind_phys), dimension(K,NTRC) :: RCU real(kind=kind_phys) :: CUP ! - real(kind=kind_phys), parameter :: ERRMIN=0.0001 & - &, ERRMI2=0.1*ERRMIN & + real(kind=kind_phys), parameter :: ERRMIN=0.0001d0 & + &, ERRMI2=0.1d0*ERRMIN & ! &, rainmin=1.0e-9 & - &, rainmin=1.0e-8 & - &, oneopt9=1.0/0.09 & - &, oneopt4=1.0/0.04 + &, rainmin=1.0d-8 & + &, oneopt9=one/0.09d0 & + &, oneopt4=one/0.04d0 ! TEMPORARY WORK SPACE @@ -1312,7 +1313,7 @@ SUBROUTINE CLOUD( & ! &, almin1, almin2 INTEGER I, L, N, KD1, II, idh, lcon & - &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1, kbls, kmxh + &, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1, kmxh &, kblh, kblm, kblpmn, kmax, kmaxm1, kmaxp1, klcl, kmin, kmxb ! !*********************************************************************** @@ -1343,18 +1344,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 ! @@ -1463,8 +1464,14 @@ SUBROUTINE CLOUD( & ! ! if (lprnt) write(0,*) ' calkbl=',calkbl - hcrit = hcritd - if (sgcs(kd) > 0.65) hcrit = hcrits + if (sgcs(kd) < 0.5d0) then + hcrit = hcritd + elseif (sgcs(kd) > 0.65d0) then + hcrit = hcrits + else + hcrit = (hcrits*(sgcs(kd)-0.5d0) + hcritd*(0.65d0-sgcs(kd))) + & * (one/0.15d0) + endif IF (CALKBL) THEN KTEM = MAX(KD+1, KBLMX) hmin = hol(k) @@ -1522,7 +1529,7 @@ SUBROUTINE CLOUD( & enddo endif -! if(lprnt) write(0,*)' kbl=',kbl,' kbls=',kbls,' kmax=',kmax +! if(lprnt) write(0,*)' kbl=',kbl,' kmax=',kmax ! klcl = kd1 if (kmax > kd1) then @@ -1533,7 +1540,7 @@ SUBROUTINE CLOUD( & endif enddo endif -! if(lprnt) write(0,*)' klcl=',klcl,' ii=',ii +! if(lprnt) write(0,*)' klcl=',klcl ! if (klcl == kd .or. klcl < ktem) return ! This is to handle mid-level convection from quasi-uniform h @@ -1549,7 +1556,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.0d0,max(10.0d0,(prl(kmaxp1)-prl(kd))*0.10d0)) if (prl(kmaxp1) - prl(ii) > tem .and. ii > kbl) kbl = ii ! if(lprnt) write(0,*)' kbl2=',kbl,' ii=',ii @@ -1588,17 +1595,17 @@ SUBROUTINE CLOUD( & ! if(lprnt)write(0,*)' 1st kbl=',kbl,' kblmx=',kblmx,' kd=',kd ! if(lprnt)write(0,*)' tx3=',tx3,' tx1=',tx1,' tem=',tem -! 1, ' hcrit=',hcrit +! &, ' hcrit=',hcrit,' kblmn=',kblmn ELSE KBL = KPBL -! if(lprnt)write(0,*)' 2nd kbl=',kbl +! if(lprnt)write(0,*)' 2nd kbl=',kbl ENDIF ! if(lprnt)write(0,*)' after CALKBL l=',l,' hol=',hol(l) -! 1, ' hst=',hst(l) +! &, ' hst=',hst(l) ! - KBL = min(kmax,MAX(KBL,KD+2)) + KBL = min(kmax, MAX(KBL,KD+2)) KB1 = KBL - 1 !! ! if (lprnt) write(0,*)' kbl=',kbl,' prlkbl=',prl(kbl),prl(kp1) @@ -1620,8 +1627,8 @@ SUBROUTINE CLOUD( & ZET(KBL) = zero ! 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) < 300.0d0 .and. kmax == k) shal_fac = shalfac + if (prl(kbl)-prl(kd) < 350.0d0 .and. kmax == k) shal_fac = shalfac DO L=Kmax,KD,-1 IF (L >= KBL) THEN ETA(L) = (PRL(Kmaxp1)-PRL(L)) * PRISM @@ -1685,7 +1692,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.0d0) & & return ! TX1 = RHFACS - QBL / TX1 ! Average RH @@ -1702,9 +1709,9 @@ SUBROUTINE CLOUD( & IF (.NOT. cnvflg) RETURN ! - RHC = MAX(ZERO, MIN(ONE, EXP(-20.0*TX1) )) + RHC = MAX(ZERO, MIN(ONE, EXP(-20.0d0*TX1) )) ! - wcbase = 0.1 + wcbase = 0.1d0 if (ntrc > 0) then DO N=1,NTRC RBL(N) = ROI(Kmax,N) * ETA(Kmax) @@ -1717,9 +1724,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 @@ -1792,7 +1799,7 @@ SUBROUTINE CLOUD( & ! endif ! 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 ! @@ -1819,7 +1826,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 ! @@ -1891,13 +1898,13 @@ SUBROUTINE CLOUD( & HSU = HSU - ALM * TX3 ! CLP = ZERO - ALM = -100.0 + ALM = -100.0d0 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.0d-4 ! if (lprnt) write(0,*)' ii=',ii,' cnvflg=',cnvflg,' hsu=',hsu ! &,' hbl=',hbl,' tx1=',tx1,' hsd=',hsd @@ -1919,7 +1926,7 @@ SUBROUTINE CLOUD( & ! if (tx2 == zero) then alm = - st2 / tx1 - if (alm > almax) alm = -100.0 + if (alm > almax) alm = -100.0d0 else x00 = tx2 + tx2 epp = tx1 * tx1 - (x00+x00)*st2 @@ -1928,8 +1935,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.0d0 + if (tem2 > almax) tem2 = -100.0d0 alm = max(tem1,tem2) ! if (lprnt) write(0,*) ' tem1=',tem1,' tem2=',tem2,' alm=',alm @@ -2008,12 +2015,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.0d0, max(tx1,100.0d0)) + tem1 = log(tx2*0.01d0) * 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.0d0 + tem2*3.0d0) + rel_fac = (dt * facdt) / (tem1*6.0d0 + tem2*adjts_s) else rel_fac = (dt * facdt) / (tem1*adjts_d + tem2*adjts_s) endif @@ -2186,8 +2193,8 @@ SUBROUTINE CLOUD( & qw00 = zero qi00 = zero -! if (lprnt) write(0,*)' returning to 777 : ii=',ii,' qw00=',qw00,qi00 -! &,' clp=',clp,' hst(kd)=',hst(kd) +! if (lprnt) write(0,*)' returning to 777 : ii=',ii,' qw00=',qw00 +! &, qi00, ' clp=',clp,' hst(kd)=',hst(kd) go to 777 else @@ -2234,7 +2241,7 @@ SUBROUTINE CLOUD( & ! CALCUP = .FALSE. - TEM = max(0.05, MIN(CD*200.0, MAX_NEG_BOUY)) + TEM = max(0.05d0, MIN(CD*200.0d0, MAX_NEG_BOUY)) IF (.not. cnvflg .and. WFN > ACR .and. & & dpneg < dpnegcr .and. AKM <= TEM) CALCUP = .TRUE. @@ -2282,7 +2289,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.0d-4 .AND. PL <= dpd*prl(kp1)) DDFT = .TRUE. ENDIF ! ! if (lprnt) then @@ -2636,7 +2643,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.2d0 / max(alm, 1.0d-5)) tx2 = one - min(one, pi * tx1 * tx1 / garea) ! if(lprnt) write(0,*)' kd=',kd,' alm=',alm,' tx1=',tx1 ! &,' garea=',garea,' pi=',pi,' tx2=',tx2 @@ -2664,6 +2671,7 @@ SUBROUTINE CLOUD( & else sigf(kd:k) = one endif + ! if(lprnt) write(0,*)' for kd=',kd,'sigf=',sigf(kd:k) ! avt = zero @@ -2787,13 +2795,13 @@ SUBROUTINE CLOUD( & endif enddo tem = tem + amb * dof * sigf(kbl) - tem = tem * (3600.0/dt) + tem = tem * (3600.0d0/dt) !!!! tem1 = max(1.0, min(100.0,sqrt((5.0E10/max(garea,one))))) ! tem1 = max(1.0, min(100.0,(7.5E10/max(garea,one)))) ! tem1 = max(1.0, min(100.0,(5.0E10/max(garea,one)))) ! tem1 = max(1.0, min(100.0,(4.0E10/max(garea,one)))) !! tem1 = sqrt(max(1.0, min(100.0,(4.0E10/max(garea,one))))) ! 20100902 - tem1 = sqrt(max(one, min(100.0,(6.25E10/max(garea,one))))) ! 20110530 + tem1 = sqrt(max(one, min(100.0d0,(6.25d10/max(garea,one))))) ! 20110530 ! if (lprnt) write(0,*)' clfr0=',clf(tem),' tem=',tem,' tem1=', & ! & tem1 @@ -2801,6 +2809,7 @@ SUBROUTINE CLOUD( & ! clfrac = max(ZERO, min(ONE, rknob*clf(tem)*tem1)) ! clfrac = max(ZERO, min(0.25, rknob*clf(tem)*tem1)) clfrac = max(ZERO, min(half, rknob*clf(tem)*tem1)) + cldfrd = clfrac ! if (lprnt) then ! write(0,*) ' cldfrd=',cldfrd,' amb=',amb,' clfrac=',clfrac @@ -2853,21 +2862,18 @@ SUBROUTINE CLOUD( & tem4 = zero if (tx1 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778 ) ) -! & TEM4 = POTEVAP * (1. - EXP( AFC*tx4*SQRT(TX1) ) ) + & TEM4 = POTEVAP * (one - EXP( tx4*TX1**0.57777778d0 ) ) ACTEVAP = MIN(TX1, TEM4*CLFRAC) ! if(lprnt) write(0,*)' L=',L,' actevap=',actevap,' tem4=',tem4, -! &' clfrac=' -! &,clfrac,' potevap=',potevap,'efac=',AFC*SQRT(TX1*TEM3) -! &,' tx1=',tx1 +! &' clfrac=',clfrac,' potevap=',potevap,'tem4=',tem4 +! &,' tx1=',tx1,' rhc_ls=',rhc_ls(l) if (tx1 < rainmin*dt) actevap = min(tx1, potevap) ! tem4 = zero if (tx2 > zero) & - & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778 ) ) -! & TEM4 = POTEVAP * (1. - EXP( AFC*tx4*SQRT(TX2) ) ) + & TEM4 = POTEVAP * (one - EXP( tx4*TX2**0.57777778d0 ) ) TEM4 = min(MIN(TX2, TEM4*CLDFRD), potevap-actevap) if (tx2 < rainmin*dt) tem4 = min(tx2, potevap-actevap) ! @@ -2894,7 +2900,7 @@ SUBROUTINE CLOUD( & ENDIF ! if (lprnt) write(0,*)' tx1=',tx1,' tx2=',tx2,' dof=',dof -! &,' cup=',cup*86400/dt,' amb=',amb +!! &,' cup=',cup*86400/dt,' amb=',amb ! &,' amb=',amb,' cup=',cup,' clfrac=',clfrac,' cldfrd=',cldfrd ! &,' ddft=',ddft,' kd=',kd,' kbl=',kbl,' k=',k ! @@ -2940,7 +2946,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.001d0) FNOSCAV = exp(- FSCAV_(N) * DELZKM) else FNOSCAV = one @@ -2950,7 +2956,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.001d0) FNOSCAV = exp(- FSCAV_(N) * DELZKM) endif lm1 = l - 1 @@ -3091,7 +3097,7 @@ SUBROUTINE DDRFT( & ! integer, parameter :: NUMTLA=2 ! integer, parameter :: NUMTLA=4 - parameter (ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) + parameter (ERRMIN=0.0001d0, ERRMI2=0.1d0*ERRMIN) ! parameter (ERRMIN=0.00001, ERRMI2=0.1*ERRMIN) ! real (kind=kind_phys), parameter :: PIINV=one/PI @@ -3102,8 +3108,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.0d0, BB1=1.0d0, CC1=1.0d0, DD1=1.0d0, & + & F3=CC1, F5=1.0d0) + parameter (QRMIN=1.0d-6, WC2MIN=0.01d0, 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) @@ -3140,7 +3147,7 @@ SUBROUTINE DDRFT( & CLDFRD = zero RNTP = zero DOF = zero - ERRQ = 10.0 + ERRQ = 10.0d0 RNB = zero RNT = zero TX2 = PRL(KBL) @@ -3171,7 +3178,7 @@ SUBROUTINE DDRFT( & ENDDO if (kk /= kbl) then do l=kk,kbl - buy(l) = 0.9 * buy(l-1) + buy(l) = 0.9d0 * buy(l-1) enddo endif ! @@ -3179,24 +3186,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.25d0 * (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.0d0 + 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.2d0) ! WCMIN = SQRT(WC2MIN) ! WCBASE = WCMIN ! ! del_tla = TLA * 0.2 ! del_tla = TLA * 0.25 - del_tla = TLA * 0.3 + del_tla = TLA * 0.3d0 TLA = TLA - DEL_TLA ! DO L=KD,K @@ -3257,7 +3264,7 @@ 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.1d0 .or. tla > 45.0d0) cycle ! tla = tla + del_tla STLA = SIN(TLA*deg2rad) ! sine of tilting angle @@ -3267,9 +3274,9 @@ SUBROUTINE DDRFT( & ! &,0.5*(prl(kd)+prl(kd1)),' ntla=',ntla,' f2=',f2,' stla=',stla ! if (lprnt) write(0,*)' buy=',(buy(l),l=kd,kbl) ! - STLA = F2 * STLA * AL2 - CTL2 = DD1 * CTL2 - CTL3 = 0.1364 * CTL2 + STLA = F2 * STLA * AL2 + CTL2 = DD1 * CTL2 + CTL3 = 0.1364d0 * CTL2 ! DO L=KD,K RNF(L) = zero @@ -3345,7 +3352,7 @@ 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) + DOF = 1.1364d0 * BUD(KD) * QRPI(KD) DOFW = -BUD(KD) * STLT(KD) ! RNT = TRW(1) * VRW(1) @@ -3379,7 +3386,7 @@ SUBROUTINE DDRFT( & ! QA(2) = DOF WA(2) = DOFW - DOF = 1.1364 * BUD(L) * QRPI(L) + DOF = 1.1364d0 * BUD(L) * QRPI(L) DOFW = -BUD(L) * STLT(L) ! RNF(LL) = RNF(LL) + QQQ * ST1 @@ -3450,7 +3457,7 @@ SUBROUTINE DDRFT( & QA(2) = DOF WA(2) = DOFW - DOF = 1.1364 * BUD(L) * QRPI(L) + DOF = 1.1364d0 * BUD(L) * QRPI(L) DOFW = -BUD(L) * STLT(L) ! RNF(LL) = RNF(LL) + ST1 @@ -3591,7 +3598,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.1d0) then tem = half !! elseif (tx2 < 0.1) then !! tem = 1.2 @@ -3619,18 +3626,18 @@ SUBROUTINE DDRFT( & 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.5d0) THEN ! IF (TEM < ZERO .and. & ! & (ntla < numtla .or. ERRQ > 0.5)) THEN ! if (lprnt) write(0,*)' tx2=',tx2,' errq=',errq,' tem=',tem SKPUP = .TRUE. ! No convergence ! - ERRQ = 10.0 ! No rain profile! + ERRQ = 10.0d0 ! No rain profile! !!!! ELSEIF (ABS(TEM) < ERRMI2 .OR. TX2 < ERRMIN) THEN ELSEIF (TX2 < ERRMIN) THEN SKPUP = .TRUE. ! Converges ! ERRQ = zero ! Rain profile exists! ! if (lprnt) write(0,*)' here2' - elseif (tem < zero .and. errq < 0.1) then + elseif (tem < zero .and. errq < 0.1d0) then skpup = .true. ! if (ntla == numtla .or. tem > -0.003) then errq = zero @@ -3657,7 +3664,7 @@ SUBROUTINE DDRFT( & ! &,' errq=',errq ! endif ! - IF (ERRQ < 0.1) THEN + IF (ERRQ < 0.1d0) THEN DDFT = .TRUE. RNB = - RNB ! do l=kd1,kb1-1 @@ -3680,7 +3687,7 @@ SUBROUTINE DDRFT( & ! if (lprnt) write(0,*)' tx1+rnt+rnb=',tx1+rnt+rnb, ' train=',train TX1 = TRAIN / (TX1+RNT+RNB) ! if (lprnt) write(0,*)' tx1= ', tx1 - IF (ABS(TX1-one) < 0.2) THEN + IF (ABS(TX1-one) < 0.2d0) THEN RNT = MAX(RNT*TX1,ZERO) RNB = RNB * TX1 DO L=KD,KB1 @@ -3693,7 +3700,7 @@ SUBROUTINE DDRFT( & ELSE DDFT = .FALSE. - ERRQ = 10.0 + ERRQ = 10.0d0 ENDIF ENDIF ! @@ -3718,7 +3725,7 @@ SUBROUTINE DDRFT( & WCB(L) = zero ENDDO ! - ERRQ = 10.0 + ERRQ = 10.0d0 ! At this point stlt contains inverse of updraft vertical velocity 1/Wu. KK = MAX(KB1,KD1) @@ -3768,9 +3775,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.1364d0) else - tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364) + tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364d0) endif RNTP = (one - RPART) * RNT BUY(KD) = - ROR(KD) * TX1 * QRP(KD) @@ -3834,7 +3841,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.0d0*EKNOB) ! DOFW = one / (WA(3) * (one + NU*WA(2))) ! 1.0 / TVbar! ! @@ -3842,7 +3849,7 @@ SUBROUTINE DDRFT( & HOD(L) = HOD(L-1) QOD(L) = QOD(L-1) ! - ERRQ = 10.0 + ERRQ = 10.0d0 ! IF (L <= KBL) THEN @@ -3867,7 +3874,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.0d0) ENDIF WVL(L) = MAX(ONE_M2, WVL(L)) TRW(1) = TRW(1) * half @@ -4013,9 +4020,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.6d0 + 124.9d0 * QRAF) * QRBF * TX4 ! - CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6 * ST2 / ((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) ! TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) TEM3 = (one + TEM1) * QHS * (QOD(L)+CE) @@ -4026,7 +4033,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.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) ! CEE = CE * (ETD(L)+DDZ) ! @@ -4050,7 +4057,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.1364d0) ELSE QRP(L) = zero ENDIF @@ -4086,7 +4093,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.0d-10 else WVL(L) = half*(WVL(L)+TEM1) endif @@ -4110,7 +4117,7 @@ SUBROUTINE DDRFT( & ! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN ! if(lprnt) write(0,*)' itr=',itr,' etd1=',etd(l-1),' errq=',errq - IF (ETD(L-1) == zero .AND. ERRQ > 0.2) THEN + IF (ETD(L-1) == zero .AND. ERRQ > 0.2d0) THEN ! if(lprnt) write(0,*)' bud=',bud(kd),' wa=',wa(1),wa(2) ROR(L) = BUD(KD) ETD(L) = zero @@ -4123,7 +4130,7 @@ SUBROUTINE DDRFT( & TX5 = TX9 else TX5 = (STLT(KB1) * QRT(KB1) & - & + STLT(KBL) * QRB(KB1)) * (0.5*FAC) + & + STLT(KBL) * QRB(KB1)) * (0.5d0*FAC) endif ! if(lprnt) write(0,*)' tx1=',tx1,' rnt=',rnt,' rnf=',rnf(l-1) @@ -4145,14 +4152,14 @@ SUBROUTINE DDRFT( & ! *,' errq=',errq QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (one/1.1364) + & ** (one/1.1364d0) ! 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.1d0) THEN ROR(L) = BUD(KD) ETD(L) = zero WVL(L) = zero @@ -4179,9 +4186,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.6d0 + 124.9d0 * QRAF) * QRBF * TX4 ! - CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) + CE = TEM6*ST2/((5.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) ! TEM2 = - ((one+TEM1)*(QHS+CE) + TEM1*QOD(L)) @@ -4192,7 +4199,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.4d5*ST2 + 2.55d6)*(ETD(L)+DDZ)) ! CEE = CE * (ETD(L)+DDZ) ! @@ -4252,7 +4259,8 @@ 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.1d0 .and. & + & l <= kbl) THEN !!! & .AND. ERRQ > ERRMIN*10.0 .and. l <= kbl) THEN ! & .AND. ERRQ > ERRMIN*10.0) THEN ROR(L) = BUD(KD) @@ -4275,7 +4283,7 @@ SUBROUTINE DDRFT( & ! IF (QA(1) > 0.0) THEN QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & - & ** (one/1.1364) + & ** (one/1.1364d0) ! ENDIF ETD(L) = zero WVL(L) = zero @@ -4312,7 +4320,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.1d0 .AND. IDN(idnm) == idnmax) DDFT = .FALSE. ! DOF = zero IF (.NOT. DDFT) RETURN @@ -4417,18 +4425,18 @@ SUBROUTINE QSATCN(TT,P,Q,DQDT) ! real(kind=kind_phys) TT, P, Q, DQDT ! - real(kind=kind_phys), parameter :: ZERO=0.0, ONE=1.0 & - &, ONE_M10=1.E-10 & + real(kind=kind_phys), parameter :: ZERO=0.0d0, ONE=1.0d0 & + &, ONE_M10=1.0d-10 & &, rvi=one/rv, facw=CVAP-CLIQ & &, faci=CVAP-CSOL, hsub=HVAP+HFUS & - &, tmix=TTP-20.0 & + &, tmix=TTP-20.0d0 & &, DEN=one/(TTP-TMIX) ! logical lprnt ! 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 = 10.0 * fpvs(tt) ! fpvs is in centibars! + es = min(p, 0.01d0 * fpvs(tt)) ! fpvs is in Pascals! ! D = one / max(p+epsm1*es,ONE_M10) D = one / (p+epsm1*es) ! @@ -4451,7 +4459,7 @@ SUBROUTINE ANGRAD(PRES, ALM, AL2, TLA) ! integer i ! - IF (TLA < 0.0) THEN + IF (TLA < 0.0d0) THEN IF (PRES <= PLAC(1)) THEN TLA = TLAC(1) ELSEIF (PRES <= PLAC(2)) THEN @@ -4488,8 +4496,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.0d-4 / tem + al2 = min(4.0d0*tem, max(alm, tem)) ! RETURN END @@ -4502,18 +4510,18 @@ SUBROUTINE SETQRP integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! XMIN = 1.0E-6 - XMIN = 0.0 - XMAX = 5.0 + XMIN = 0.0d0 + XMAX = 5.0d0 XINC = (XMAX-XMIN)/(NQRP-1) C2XQRP = one / XINC C1XQRP = one - XMIN*C2XQRP - TEM1 = 0.001 ** 0.2046 - TEM2 = 0.001 ** 0.525 + TEM1 = 0.001d0 ** 0.2046d0 + TEM2 = 0.001d0 ** 0.525d0 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.1364d0 + TBQRA(JX) = TEM1 * X ** 0.2046d0 + TBQRB(JX) = TEM2 * X ** 0.525d0 ENDDO ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - RETURN @@ -4560,8 +4568,8 @@ SUBROUTINE SETVTP real(kind=kind_phys) xinc,x,xmax,xmin integer jx ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - XMIN = 0.05 - XMAX = 1.5 + XMIN = 0.05d0 + XMAX = 1.5d0 XINC = (XMAX-XMIN)/(NVTP-1) C2XVTP = one / XINC C1XVTP = one - XMIN*C2XVTP @@ -4593,10 +4601,10 @@ FUNCTION CLF(PRATE) implicit none real(kind=kind_phys) PRATE, CLF ! - 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.30d0, ccf2=0.09d0 & + &, ccf3=0.04d0, ccf4=0.01d0 & + &, pr1=1.0d0, pr2=5.0d0 & + &, pr3=20.0d0 ! if (prate < pr1) then clf = ccf1 diff --git a/gfsphysics/physics/sfc_cice.f b/gfsphysics/physics/sfc_cice.f index cddf2d449..64a2565cb 100644 --- a/gfsphysics/physics/sfc_cice.f +++ b/gfsphysics/physics/sfc_cice.f @@ -29,9 +29,10 @@ subroutine sfc_cice & ! --- inputs: & ( im, t1, q1, cm, ch, prsl1, & & wind, flag_cice, flag_iter, dqsfc, dtsfc, & - & dusfc, dvsfc, & + & dusfc, dvsfc, snowd, & +! --- input/output: ! --- outputs: - & qsurf, cmm, chh, evap, hflx, stress ) + & qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep) ! ===================================================================== ! ! description: ! @@ -43,8 +44,9 @@ subroutine sfc_cice & ! inputs: ! ! ( im, t1, q1, cm, ch, prsl1, ! ! wind, flag_cice, flag_iter, dqsfc, dtsfc, ! +! dusfc, dvsfc, snowd, ! ! outputs: ! -! qsurf, cmm, chh, evap, hflx) ! +! qsurf, cmm, chh, evap, hflx, stress, weasd, snwdph, ep) ! ! ! ! ==================== defination of variables ==================== ! ! ! @@ -64,6 +66,7 @@ subroutine sfc_cice & ! dusfc - real, zonal momentum stress ! dvsfc - real, meridional momentum stress ! dvsfc - real, sensible heat flux +! snowd - real, snow depth from cice ! outputs: ! qsurf - real, specific humidity at sfc ! cmm - real, ? @@ -71,52 +74,61 @@ subroutine sfc_cice & ! 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 ===================== ! ! ! ! --- constant parameters: - real(kind=kind_phys), parameter :: cpinv = 1.0/cp - real(kind=kind_phys), parameter :: hvapi = 1.0/hvap + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + real(kind=kind_phys), parameter :: cpinv = one/cp + real(kind=kind_phys), parameter :: hvapi = one/hvap + real(kind=kind_phys), parameter :: dsi = one/0.33_kind_phys ! --- inputs: integer, intent(in) :: im ! 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 + & 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, & - & cmm, chh, evap, hflx, stress + real (kind=kind_phys), dimension(im), intent(inout) :: qsurf, & + & cmm, chh, evap, hflx, stress, & + & weasd, snwdph, ep ! --- locals: real (kind=kind_phys) :: rho, tem - - integer :: i - - logical :: flag(im) -! - do i = 1, im - flag(i) = flag_cice(i) .and. flag_iter(i) - enddo + integer :: i ! do i = 1, im - if (flag(i)) then + 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.0d-8))) 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/gfsphysics/physics/sfc_diag.f b/gfsphysics/physics/sfc_diag.f index 7c6f64b7c..afb996e75 100644 --- a/gfsphysics/physics/sfc_diag.f +++ b/gfsphysics/physics/sfc_diag.f @@ -12,14 +12,15 @@ subroutine sfc_diag(im,ps,u1,v1,t1,q1,prslki, ! integer, intent(IN) :: im real, dimension(im), intent(IN) :: - & ps, u1, v1, t1, q1, tskin, qsurf, + & ps, u1, v1, t1, q1, tskin, qsurf, & fm, fm10, fh, fh2, prslki, evap real, dimension(im), intent(OUT) :: & f10m, u10m, v10m, t2m, q2m ! ! locals ! - real (kind=kind_phys), parameter :: qmin=1.0e-8 + real (kind=kind_phys), parameter :: one=1.0d0, zero=0.0d0 + &, qmin=1.0d-8 integer k,i ! real(kind=kind_phys) fhi, qss, wrk @@ -44,11 +45,11 @@ subroutine sfc_diag(im,ps,u1,v1,t1,q1,prslki, ! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi ! sig2k = 1. - (grav+grav) / (cp * t2m(i)) ! t2m(i) = t2m(i) * sig2k - wrk = 1.0 - fhi + wrk = one - fhi t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp - if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + if(evap(i) >= zero) then ! for evaporation>0, use inferred qsurf to deduce q2m q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi else ! for dew formation, use saturated q at tskin qss = fpvs(tskin(i)) diff --git a/gfsphysics/physics/sfc_diff.f b/gfsphysics/physics/sfc_diff.f index 22bfe4289..9b56cdd33 100644 --- a/gfsphysics/physics/sfc_diff.f +++ b/gfsphysics/physics/sfc_diff.f @@ -2,7 +2,7 @@ module module_sfc_diff use machine , only : kind_phys use physcons, grav => con_g - real (kind=kind_phys), parameter :: ca=.4 ! ca - von karman constant + real (kind=kind_phys), parameter :: ca=0.4d0 ! ca - von karman constant contains subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) @@ -12,9 +12,9 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) & flag_iter,redrag, !intent(in) & u10m,v10m,sfc_z0_type, !hafs,z0 type !intent(in) & wet,dry,icy, !intent(in) - & tskin, tsurf, snwdph, z0rl, ustar, + & tskin, tsurf, snwdph, z0rl, z0rlw, ustar ! - & cm, ch, rb, stress, fm, fh, fm10, fh2) + &, cm, ch, rb, stress, fm, fh, fm10, fh2) ! use physcons, rvrdm1 => con_fvirt implicit none @@ -23,7 +23,6 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) ! -------- -------- --------- integer, intent(in) :: im, ivegsrc integer, intent(in) :: sfc_z0_type ! option for calculating surface roughness length over ocean - integer, dimension(im), intent(in) :: vegtype logical, intent(in) :: redrag ! reduced drag coeff. flag for high wind over sea (j.han) @@ -37,6 +36,7 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) real(kind=kind_phys), dimension(im,3), intent(in) :: & tskin, tsurf, snwdph + real(kind=kind_phys), dimension(im), intent(in) :: z0rlw real(kind=kind_phys), dimension(im,3), intent(inout) :: & z0rl, ustar @@ -55,8 +55,10 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !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 + & one=1.0d0, zero=0.0d0, half=0.5d0, qmin=1.0d-8 + &, charnock=.014d0, z0s_max=.317d-2 ! a limiting value at high winds over sea + &, zmin=1.0d-6 + &, vis=1.4d-5, rnu=1.51d-5, visi=one/vis &, log01=log(0.01), log05=log(0.05), log07=log(0.07) ! parameter (charnock=.014,ca=.4)!c ca is the von karman constant @@ -84,19 +86,19 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !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 ! this portion of the code is presently suppressed ! if (dry(i)) then ! Some land - tvs = 0.5 * (tsurf(i,1)+tskin(i,1)) * virtfac - z0max = max(1.0e-6, min(0.01 * z0rl(i,1), z1(i))) + tvs = half * (tsurf(i,1)+tskin(i,1)) * virtfac + z0max = max(zmin, min(0.01d0 * z0rl(i,1), 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 @@ -106,10 +108,10 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) z0max = exp( tem2*log01 + tem1*log05 ) elseif (vegtype(i) == 7) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01d0 elseif (vegtype(i) == 16) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01d0 else z0max = exp( tem2*log01 + tem1*log(z0max) ) endif @@ -122,34 +124,34 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) z0max = exp( tem2*log01 + tem1*log05 ) elseif (vegtype(i) == 9) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01d0 elseif (vegtype(i) == 11) then ! z0max = exp( tem2*log01 + tem1*log01 ) - z0max = 0.01 + z0max = 0.01d0 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.0d0**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.8d0 - tem1 = 1.0 - sigmaf(i) + tem1 = 1.0d0 - sigmaf(i) ztmax = z0max*exp( - tem1*tem1 & * czilc*ca*sqrt(ustar(i,1)*(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.0d0**ztpert(i)) endif - ztmax = max(ztmax, 1.0e-6) + ztmax = max(ztmax, zmin) ! call stability ! --- inputs: @@ -160,12 +162,12 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) endif ! Dry points if (icy(i)) then ! Some ice - tvs = 0.5 * (tsurf(i,2)+tskin(i,2)) * virtfac - z0max = max(1.0e-6, min(0.01 * z0rl(i,2), z1(i))) + tvs = half * (tsurf(i,2)+tskin(i,2)) * virtfac + z0max = max(zmin, min(0.01d0 * z0rl(i,2), 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 @@ -174,13 +176,14 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !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 - tem1 = 1.0 - sigmaf(i) + czilc = 0.8d0 + + tem1 = 1.0d0 - sigmaf(i) ztmax = z0max*exp( - tem1*tem1 & * czilc*ca*sqrt(ustar(i,2)*(0.01/1.5e-05))) ztmax = max(ztmax, 1.0e-6) @@ -197,9 +200,9 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) ! the stuff now put into "stability" if (wet(i)) then ! Some open ocean - tvs = 0.5 * (tsurf(i,3)+tskin(i,3)) * virtfac - z0 = 0.01 * z0rl(i,3) - z0max = max(1.0e-6, min(z0,z1(i))) + tvs = half * (tsurf(i,3)+tskin(i,3)) * virtfac + z0 = 0.01d0 * z0rl(i,3) + z0max = max(zmin, min(z0,z1(i))) ustar(i,3) = sqrt(grav * z0 / charnock) wind10m = sqrt(u10m(i)*u10m(i)+v10m(i)*v10m(i)) @@ -207,7 +210,7 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) ! ztmax = z0max - restar = max(ustar(i,3)*z0max*visi, 0.000001) + restar = max(ustar(i,3)*z0max*visi, 0.000001d0) ! restar = log(restar) ! restar = min(restar,5.) @@ -216,8 +219,8 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !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.0d0, 2.67d0 * sqrt(sqrt(restar)) - 2.57d0) + 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) @@ -250,20 +253,30 @@ subroutine sfc_diff(im,ps,t1,q1,z1, wind, !intent(in) ! z0 = arnu / (ustar(i) * ff ** pp) if (redrag) then - z0rl(i,3) = 100.0 * max(min(z0, z0s_max), 1.e-7) + z0rl(i,3) = 100.0d0 * max(min(z0, z0s_max), 1.0d-7) else - z0rl(i,3) = 100.0 * max(min(z0,.1), 1.e-7) + z0rl(i,3) = 100.0d0 * max(min(z0, 0.1d0), 1.0d-7) endif elseif (sfc_z0_type == 6) then ! wang - call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m - z0rl(i,3) = 100.0 * z0 ! cm + call znot_m_v6(wind10m, z0) ! wind, m/s, z0, m + z0rl(i,3) = 100.0d0 * z0 ! cm elseif (sfc_z0_type == 7) then ! wang - call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m - z0rl(i,3) = 100.0 * z0 ! cm + call znot_m_v7(wind10m, z0) ! wind, m/s, z0, m + z0rl(i,3) = 100.0d0 * z0 ! cm + else + z0rl(i,3) = 1.0d-4 + endif + + elseif (z0rlw(i) < 1.0d-7) then + z0 = (charnock / grav) * ustar(i,3) * ustar(i,3) + + if (redrag) then + z0rl(i,3) = 100.0d0 * max(min(z0, z0s_max), 1.0d-7) else - z0rl(i,3) = 1.0e-4 + z0rl(i,3) = 100.0d0 * max(min(z0, 0.1d0), 1.0d-7) endif + endif endif ! end of if(open ocean) @@ -293,11 +306,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.0d0, a0=-3.975d0 & + &, a1=12.32d0, alpha4=4.0d0*alpha & + &, b1=-7.755d0, b2=6.041d0, alpha2=alpha+alpha & + &, beta=1.0d0 & + &, a0p=-7.941d0, a1p=24.75d0, b1p=-8.705d0, b2p=7.899d0& + &, ztmin1=-999.0d0, zero=0.0d0, one=1.0d0 real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, & hl1, hl12, pm, ph, pm10, ph2, @@ -306,46 +320,46 @@ 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.0d-6) then + ztmax1 = - beta*log(tem1)/(alpha2*(one-tem1)) else - ztmax1 = 99.0 + ztmax1 = 99.0d0 endif - if( z0max < 0.05 .and. snwdph < 10.0 ) ztmax1 = 99.0 + if( z0max < 0.05d0 .and. snwdph < 10.0d0 ) ztmax1 = 99.0d0 ! compute stability indices (rb and hlinf) dtv = thv1 - tvs - adtv = max(abs(dtv),0.001) + adtv = max(abs(dtv),0.001d0) dtv = sign(1.,dtv) * adtv - rb = max(-5000.0, (grav+grav) * dtv * z1 + rb = max(-5000.0d0, (grav+grav) * dtv * z1 & / ((thv1 + tvs) * wind * wind)) - 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.0d0) * tem1) + fh2 = log((ztmax+2.0d0) * 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.25d0) 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 @@ -357,27 +371,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.0d0 * 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.0d0 * z0max if(abs(olinf) <= tem1) then hlinf = -z1 / tem1 hlinf = min(max(hlinf,ztmin1),ztmax1) @@ -385,30 +399,30 @@ subroutine stability ! ! get pm and ph ! - if (hlinf >= -0.5) then + if (hlinf >= -0.5d0) 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.0d0 * 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.0d0 * sqrt(tem1) - .8776d0 + ph = log(hl1) + 0.5d0 * tem1 + 1.386d0 ! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 ! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 - hl110 = hl1 * 10. * z1i + hl110 = hl1 * 10.0d0 * z1i hl110 = min(max(hl110, ztmin1), ztmax1) - pm10 = log(hl110) + 2.0 / sqrt(sqrt(hl110)) - .8776 + pm10 = log(hl110) + 2.0d0 / sqrt(sqrt(hl110)) - 0.8776d0 ! 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.5d0 / sqrt(hl12) + 1.386d0 ! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 endif @@ -422,7 +436,7 @@ subroutine stability fh2 = fh2 - ph2 cm = ca * ca / (fm * fm) ch = ca * ca / (fm * fh) - tem1 = 0.00001/z1 + tem1 = 0.00001d0 / z1 cm = max(cm, tem1) ch = max(ch, tem1) stress = cm * wind * wind diff --git a/gfsphysics/physics/sfc_drv.f b/gfsphysics/physics/sfc_drv.f index e5626362f..84b4b84d5 100644 --- a/gfsphysics/physics/sfc_drv.f +++ b/gfsphysics/physics/sfc_drv.f @@ -166,17 +166,19 @@ subroutine sfc_drv & implicit none ! --- constant parameters: - real(kind=kind_phys), parameter :: cpinv = 1.0/cp - real(kind=kind_phys), parameter :: hvapi = 1.0/hvap + real(kind=kind_phys), parameter :: one = 1.0d0, zero = 0.0d0 + real(kind=kind_phys), parameter :: cpinv = one/cp + real(kind=kind_phys), parameter :: hvapi = one/hvap real(kind=kind_phys), parameter :: elocp = hvap/cp - 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 :: rhoh2o = 1000.0d0 + real(kind=kind_phys), parameter :: a2 = 17.2693882d0 + real(kind=kind_phys), parameter :: a3 = 273.16d0 + real(kind=kind_phys), parameter :: a4 = 35.86d0 real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) + real(kind=kind_phys), parameter :: qmin = 1.0d-8 real(kind=kind_phys), save :: zsoil_noah(4) - data zsoil_noah / -0.1, -0.4, -1.0, -2.0 / + data zsoil_noah / -0.1d0, -0.4d0, -1.0d0, -2.0d0 / ! --- input: integer, intent(in) :: im, km, isot, ivegsrc @@ -260,19 +262,19 @@ subroutine sfc_drv & 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 + 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 endif ! flag_iter & land enddo @@ -280,12 +282,12 @@ subroutine sfc_drv & 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) - theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) + 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))) - 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) + 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)), qmin) q0 (i) = min(qs1(i), q0(i)) endif ! flag_iter & land enddo @@ -381,12 +383,12 @@ subroutine sfc_drv & ! perturb vegetation fraction that goes into sflx, use the same ! perturbation strategy as for albedo (percentile matching) vegfp = vegfpert(i) ! sfc-perts, mgehne - if (pertvegf(1) > 0.0) then + if (pertvegf(1) > 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 + 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) @@ -398,7 +400,7 @@ subroutine sfc_drv & shdmax1d = shdmax(i) snoalb1d = snoalb(i) - ptu = 0.0 + ptu = zero alb = sfalb(i) tbot = tg3(i) @@ -415,7 +417,7 @@ subroutine sfc_drv & ! ch - surface exchange coefficient for heat and moisture (m s-1) -> chx ! cm - surface exchange coefficient for momentum (m s-1) -> cmx - cmc = canopy(i) * 0.001 ! convert from mm to m + cmc = canopy(i) * 0.001d0 ! convert from mm to m tsea = tsurf(i) ! clu_q2m_iter do k = 1, km @@ -424,10 +426,10 @@ subroutine sfc_drv & 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.001d0 ! convert from mm to m + sneqv = weasd(i) * 0.001d0 ! convert from mm to m + if (sneqv /= zero .and. snowh == zero) then + snowh = 10.0d0 * sneqv endif chx = ch(i) * wind(i) ! compute conductance @@ -436,7 +438,7 @@ subroutine sfc_drv & cmm(i) = cmx ! ---- ... outside sflx, roughness uses cm as unit - z0 = zorl(i)/100. + z0 = zorl(i) * 0.01d0 ! ---- mgehne, sfc-perts bexpp = bexppert(i) ! sfc perts, mgehne xlaip = xlaipert(i) ! sfc perts, mgehne @@ -481,7 +483,7 @@ subroutine sfc_drv & 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.0d0 ! unit conversion (from m to kg m-2) snohf(i) = flx1 + flx2 + flx3 smcwlt2(i) = smcwlt @@ -498,17 +500,17 @@ subroutine sfc_drv & 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.0d0 + drain (i) = runoff2 * 1000.0d0 ! --- ... 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.0d0 + snwdph(i) = snowh * 1000.0d0 + weasd(i) = sneqv * 1000.0d0 sncovr1(i) = sncovr ! ---- ... outside sflx, roughness uses cm as unit (update after snow's ! effect) - zorl(i) = z0*100. + zorl(i) = z0*100.0d0 ! --- ... do not return the following output fields to parent model ! ec - canopy water evaporation (m s-1) @@ -563,7 +565,7 @@ subroutine sfc_drv & 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 & flag diff --git a/gfsphysics/physics/sfc_ocean.f b/gfsphysics/physics/sfc_ocean.f index 2f3d4e468..ad18899fc 100644 --- a/gfsphysics/physics/sfc_ocean.f +++ b/gfsphysics/physics/sfc_ocean.f @@ -67,16 +67,14 @@ subroutine sfc_ocean & ! use machine , only : kind_phys use funcphys, only : fpvs - use physcons, only : cp => con_cp, rd => con_rd, eps => con_eps, & - & epsm1 => con_epsm1, hvap => con_hvap, & - & rvrdm1 => con_fvirt + use physcons, only : rd => con_rd, eps => con_eps, & + & epsm1 => con_epsm1, rvrdm1 => con_fvirt ! implicit none ! ! --- constant parameters: - real (kind=kind_phys), parameter :: cpinv = 1.0/cp & - &, hvapi = 1.0/hvap & - &, elocp = hvap/cp + real (kind=kind_phys), parameter :: one = 1.0d0, zero = 0.0d0 & + &, qmin = 1.0d-8 ! --- inputs: integer, intent(in) :: im @@ -92,50 +90,40 @@ subroutine sfc_ocean & ! --- locals: - real (kind=kind_phys) :: q0, qss, rch, rho, tem - - integer :: i - - logical :: flag(im) + real (kind=kind_phys) :: q0, qss, rho, tem + integer :: i ! !===> ... begin here ! -! --- ... 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 - q0 = max( q1(i), 1.0e-8 ) - rho = prsl1(i) / (rd*t1(i)*(1.0 + rvrdm1*q0)) + if (wet(i) .and. flag_iter(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 enddo ! diff --git a/gfsphysics/physics/sfc_sice.f b/gfsphysics/physics/sfc_sice.f index 72addd6f1..c3680aa93 100644 --- a/gfsphysics/physics/sfc_sice.f +++ b/gfsphysics/physics/sfc_sice.f @@ -124,17 +124,19 @@ subroutine sfc_sice & ! ! ! --- constant parameters: - integer, parameter :: kmi = 2 ! 2-layer of ice - real(kind=kind_phys), parameter :: zero = 0.0d0, one = 1.0d0 + integer, parameter :: kmi = 2 ! 2-layer of ice + 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 :: cpinv = one/cp real(kind=kind_phys), parameter :: hvapi = one/hvap real(kind=kind_phys), parameter :: elocp = hvap/cp - 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 + 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, km, ipr @@ -156,7 +158,7 @@ subroutine sfc_sice & real (kind=kind_phys), dimension(im,km), intent(inout) :: stc ! --- outputs: - real (kind=kind_phys), dimension(im), intent(out) :: snwdph, & + real (kind=kind_phys), dimension(im), intent(inout) :: snwdph, & & qsurf, snowmt, gflux, cmm, chh, evap, hflx ! --- locals: @@ -190,7 +192,7 @@ subroutine sfc_sice & 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) + 1.0d3*tprcp(i)*srflag(i) tprcp(i) = tprcp(i)*(one-srflag(i)) endif endif @@ -219,12 +221,12 @@ subroutine sfc_sice & ! 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) theta1(i) = t1(i) * prslki(i) 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 @@ -234,7 +236,7 @@ subroutine sfc_sice & 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) @@ -243,7 +245,7 @@ subroutine sfc_sice & ! --- ... snow depth in water equivalent is converted 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 @@ -264,7 +266,8 @@ subroutine sfc_sice & ! 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(i) = min(3.0_kind_phys*sfcnsw(i) & + & / (one+2.0_kind_phys*ffw(i)), snetw(i)) sneti(i) = (sfcnsw(i) - ffw(i)*snetw(i)) / fice(i) t12 = tice(i) * tice(i) @@ -274,7 +277,7 @@ subroutine sfc_sice & hfi(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapi(i) & & + rch(i)*(tice(i) - theta1(i)) - 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) @@ -286,13 +289,13 @@ subroutine sfc_sice & ! hfw(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapw(i) & ! & + rch(i)*(tgice - theta1(i)) - snetw(i) - 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 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) @@ -356,10 +359,10 @@ subroutine sfc_sice & ! --- ... 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 @@ -437,28 +440,32 @@ 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 + real (kind=kind_phys), parameter :: half = 0.5_kind_phys + real (kind=kind_phys), parameter :: one = 1.0_kind_phys + real (kind=kind_phys), parameter :: four = 4.0_kind_phys ! --- inputs: integer, intent(in) :: im, kmi, ipr @@ -491,9 +498,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 @@ -540,13 +547,13 @@ subroutine ice3lay b1 = b10 + ai * wrk1 c1 = dili * tfi * dt2i * hice(i) - stsice(i,1) = -(sqrt(b1*b1 - 4.0d0*a1*c1) + b1)/(a1+a1) + stsice(i,1) = -(sqrt(b1*b1 - four*a1*c1) + b1)/(a1+a1) tice(i) = (k12*stsice(i,1) - ai) / (k12 + bi) 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 - four*a1*c1) + b1)/(a1+a1) tice(i) = tsf tmelt = (k12*(stsice(i,1)-tsf) - (ai+bi*tsf)) * delt else @@ -561,8 +568,8 @@ subroutine ice3lay ! --- ... resize the ice ... - h1 = 0.5d0 * hice(i) - h2 = 0.5d0 * hice(i) + h1 = half * hice(i) + h2 = half * hice(i) ! --- ... top ... @@ -591,7 +598,7 @@ subroutine ice3lay hice(i) = h1 + h2 if (hice(i) > zero) then - if (h1 > 0.5d0*hice(i)) then + if (h1 > half*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) @@ -605,7 +612,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 + & - four*tfi*li/ci)) * half endif k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) diff --git a/gfsphysics/physics/sfcsub.F b/gfsphysics/physics/sfcsub.F index 4fbabab8f..d3e94943b 100644 --- a/gfsphysics/physics/sfcsub.F +++ b/gfsphysics/physics/sfcsub.F @@ -28,103 +28,107 @@ module sfccyc_module integer :: soil_type_landice ! end module sfccyc_module - subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc - &, iy,im,id,ih,fh - &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl - &, sihfcs,sicfcs,sitfcs - &, swdfcs,slcfcs - &, vmnfcs,vmxfcs,slpfcs,absfcs - &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs - &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs - &, vegfcs,vetfcs,sotfcs,alffcs - &, cvfcs,cvbfcs,cvtfcs,me,nlunit - &, sz_nml,input_nml_file + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & + &, iy,im,id,ih,fh & + &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl & + &, sihfcs,sicfcs,sitfcs & + &, swdfcs,slcfcs & + &, vmnfcs,vmxfcs,slpfcs,absfcs & + &, tsffcs,snofcs,zorfcs,albfcs,tg3fcs & + &, cnpfcs,smcfcs,stcfcs,slifcs,aisfcs & + &, vegfcs,vetfcs,sotfcs,alffcs & + &, cvfcs,cvbfcs,cvtfcs,me,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 - real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, - & orolmx,orolmn,oroomx,oroomn,orosmx, - & orosmn,oroimx,oroimn,orojmx,orojmn, - & alblmx,alblmn,albomx,albomn,albsmx, - & albsmn,albimx,albimn,albjmx,albjmn, - & wetlmx,wetlmn,wetomx,wetomn,wetsmx, - & wetsmn,wetimx,wetimn,wetjmx,wetjmn, - & snolmx,snolmn,snoomx,snoomn,snosmx, - & snosmn,snoimx,snoimn,snojmx,snojmn, - & zorlmx,zorlmn,zoromx,zoromn,zorsmx, - & zorsmn,zorimx,zorimn,zorjmx, zorjmn, - & plrlmx,plrlmn,plromx,plromn,plrsmx, - & plrsmn,plrimx,plrimn,plrjmx,plrjmn, - & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, - & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, - & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, - & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, - & stclmx,stclmn,stcomx,stcomn,stcsmx, - & stcsmn,stcimx,stcimn,stcjmx,stcjmn, - & smclmx,smclmn,smcomx,smcomn,smcsmx, - & smcsmn,smcimx,smcimn,smcjmx,smcjmn, - & scvlmx,scvlmn,scvomx,scvomn,scvsmx, - & scvsmn,scvimx,scvimn,scvjmx,scvjmn, - & veglmx,veglmn,vegomx,vegomn,vegsmx, - & vegsmn,vegimx,vegimn,vegjmx,vegjmn, - & vetlmx,vetlmn,vetomx,vetomn,vetsmx, - & vetsmn,vetimx,vetimn,vetjmx,vetjmn, - & sotlmx,sotlmn,sotomx,sotomn,sotsmx, - & sotsmn,sotimx,sotimn,sotjmx,sotjmn, - & alslmx,alslmn,alsomx,alsomn,alssmx, - & alssmn,alsimx,alsimn,alsjmx,alsjmn, - & epstsf,epsalb,epssno,epswet,epszor, - & epsplr,epsoro,epssmc,epsscv,eptsfc, - & epstg3,epsais,epsacn,epsveg,epsvet, - & epssot,epsalf,qctsfs,qcsnos,qctsfi, - & aislim,snwmin,snwmax,cplrl,cplrs, - & cvegl,czors,csnol,csnos,czorl,csots, - & csotl,cvwgs,cvetl,cvets,calfs, - & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, - & calbl,calfl,calbs,ctsfs,grboro, - & grbmsk,ctsfl,deltf,caisl,caiss, - & fsalfl,fsalfs,flalfs,falbl,ftsfl, - & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, - & faiss,fsnol,bltmsk,falbs,cvegs,percrit, - & deltsfc,critp2,critp3,blnmsk,critp1, - & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, - & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, - & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, - & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 - &, fsihl,fsihs,fsicl,fsics, - & csihl,csihs,csicl,csics,epssih,epssic - &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, - & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, - & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, - & epsslp,epsabs - &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, - & sihsmn,sihimx,sihimn,sihjmx,sihjmn, - & siclmx,siclmn,sicomx,sicomn,sicsmx, - & sicsmn,sicimx,sicimn,sicjmx,sicjmn - &, glacir_hice - &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, - & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, - & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, - & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, - & slplmx,slplmn,slpomx,slpomn,slpsmx, - & slpsmn,slpimx,slpimn,slpjmx,slpjmn, - & abslmx,abslmn,absomx,absomn,abssmx, - & abssmn,absimx,absimn,absjmx,absjmn + character(len=*), intent(in) :: tile_num_ch + integer, intent(in) :: i_index(len), j_index(len) + 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, & + & alblmx,alblmn,albomx,albomn,albsmx, & + & albsmn,albimx,albimn,albjmx,albjmn, & + & wetlmx,wetlmn,wetomx,wetomn,wetsmx, & + & wetsmn,wetimx,wetimn,wetjmx,wetjmn, & + & snolmx,snolmn,snoomx,snoomn,snosmx, & + & snosmn,snoimx,snoimn,snojmx,snojmn, & + & zorlmx,zorlmn,zoromx,zoromn,zorsmx, & + & zorsmn,zorimx,zorimn,zorjmx,zorjmn, & + & plrlmx,plrlmn,plromx,plromn,plrsmx, & + & plrsmn,plrimx,plrimn,plrjmx,plrjmn, & + & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, & + & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, & + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, & + & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, & + & stclmx,stclmn,stcomx,stcomn,stcsmx, & + & stcsmn,stcimx,stcimn,stcjmx,stcjmn, & + & smclmx,smclmn,smcomx,smcomn,smcsmx, & + & smcsmn,smcimx,smcimn,smcjmx,smcjmn, & + & scvlmx,scvlmn,scvomx,scvomn,scvsmx, & + & scvsmn,scvimx,scvimn,scvjmx,scvjmn, & + & veglmx,veglmn,vegomx,vegomn,vegsmx, & + & vegsmn,vegimx,vegimn,vegjmx,vegjmn, & + & vetlmx,vetlmn,vetomx,vetomn,vetsmx, & + & vetsmn,vetimx,vetimn,vetjmx,vetjmn, & + & sotlmx,sotlmn,sotomx,sotomn,sotsmx, & + & sotsmn,sotimx,sotimn,sotjmx,sotjmn, & + & alslmx,alslmn,alsomx,alsomn,alssmx, & + & alssmn,alsimx,alsimn,alsjmx,alsjmn, & + & epstsf,epsalb,epssno,epswet,epszor, & + & epsplr,epsoro,epssmc,epsscv,eptsfc, & + & epstg3,epsais,epsacn,epsveg,epsvet, & + & epssot,epsalf,qctsfs,qcsnos,qctsfi, & + & aislim,snwmin,snwmax,cplrl,cplrs, & + & cvegl,czors,csnol,csnos,czorl,csots, & + & csotl,cvwgs,cvetl,cvets,calfs, & + & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, & + & calbl,calfl,calbs,ctsfs,grboro, & + & grbmsk,ctsfl,deltf,caisl,caiss, & + & fsalfl,fsalfs,flalfs,falbl,ftsfl, & + & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, & + & faiss,fsnol,bltmsk,falbs,cvegs,percrit, & + & deltsfc,critp2,critp3,blnmsk,critp1, & + & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, & + & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, & + & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, & + & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 & + &, fsihl,fsihs,fsicl,fsics, & + & csihl,csihs,csicl,csics,epssih,epssic & + &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, & + & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, & + & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, & + & epsslp,epsabs & + &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, & + & sihsmn,sihimx,sihimn,sihjmx,sihjmn, & + & siclmx,siclmn,sicomx,sicomn,sicsmx, & + & sicsmn,sicimx,sicimn,sicjmx,sicjmn & + &, glacir_hice & + &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, & + & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, & + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, & + & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, & + & slplmx,slplmn,slpomx,slpomn,slpsmx, & + & slpsmn,slpimx,slpimn,slpjmx,slpjmn, & + & abslmx,abslmn,absomx,absomn,abssmx, & + & abssmn,absimx,absimn,absjmx,absjmn & &, sihnew - integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, - & 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 + integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, & + & 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 & &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc - logical gausm, deads, qcmsk, znlst, monclm, monanl, + logical gausm, deads, qcmsk, znlst, monclm, monanl, & & monfcs, monmer, mondif, landice character(len=*), intent(in) :: input_nml_file(sz_nml) @@ -265,8 +269,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, @@ -415,7 +420,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! ! mask orography and variance on gaussian grid ! - real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) + real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) & &, orogd(len) real (kind=kind_io8) rla(len), rlo(len) ! @@ -428,50 +433,50 @@ 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 - &, 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) - &, sihclm(len), sicclm(len) + 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) & + &, 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) - &, sihanl(len), sicanl(len) + 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) ! real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0. ! ! 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) - &, sihfcs(len), sicfcs(len), sitfcs(len) - &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) + 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) ! ! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched @@ -553,8 +558,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 ! @@ -775,7 +779,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. @@ -792,15 +796,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 @@ -818,176 +822,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 ---------------------------------------------------------------------- ! -! read a high resolution mask field for use in grib interpolation +!> - 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 @@ -1095,32 +1099,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 @@ -1175,7 +1182,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, @@ -1227,17 +1234,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - if(fnstcc(1:8).eq.' ') then + if(fnstcc(1:8) == ' ') then call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) endif call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, @@ -1249,15 +1256,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add stcclm(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1276,10 +1283,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, @@ -1302,7 +1309,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 *,' ' @@ -1352,7 +1359,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,*) '==============' @@ -1451,42 +1458,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. @@ -1497,11 +1510,13 @@ 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=' ! &,glacir(iprnt),' slmask=',slmask(iprnt) ! @@ -1532,10 +1547,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 ! @@ -1544,13 +1559,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, @@ -1562,7 +1577,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, @@ -1580,7 +1595,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, @@ -1592,7 +1607,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, @@ -1615,7 +1630,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 call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, @@ -1627,17 +1642,17 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - if(fnstca(1:8).eq.' ') then + if(fnstca(1:8) == ' ') then call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) endif call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, @@ -1649,15 +1664,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1693,7 +1708,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 *,' ' @@ -1742,20 +1757,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' + percrit = critp3 + 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, @@ -1773,13 +1788,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, @@ -1794,7 +1809,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 @@ -1823,7 +1838,7 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc ! do j=1, lsoil do i=1, len - if(smcfcs(i,j) .ne. 0.) then + if(smcfcs(i,j) /= 0.) then swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) else swratio(i,j) = -999. @@ -1832,13 +1847,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc 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, @@ -1853,7 +1868,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, @@ -1879,10 +1894,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) call qcmxmn('smc1f ',smcfcs(1,1),slifcs,snofcs,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, @@ -1892,15 +1907,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add smcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, @@ -1911,15 +1926,15 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) !clu [+8l] add stcfcs(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) + if (lsoil > 2) then + call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, @@ -1956,7 +1971,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 *,' ' @@ -1971,11 +1986,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc call monitr('stcfcs1',stcfcs(1,1),slifcs,snofcs,len) call monitr('stcfcs2',stcfcs(1,2),slifcs,snofcs,len) !clu [+4l] add smcfcs(3:4) and stcfcs(3:4) - if(lsoil.gt.2) then - call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) - call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) - call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) - call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) + if (lsoil > 2) then + call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) + call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) + call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) + call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) endif call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) call monitr('zorfcs',zorfcs,slifcs,snofcs,len) @@ -2023,14 +2038,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 ! @@ -2084,9 +2099,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, @@ -2101,8 +2116,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, @@ -2127,17 +2141,6 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add stcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, - & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, - & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - endif call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, @@ -2146,18 +2149,26 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, & rla,rlo,len,kqcm,percrit,lgchek,me) -!clu [+8l] add smcanl(3:4) - if(lsoil.gt.2) then - call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) - call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, - & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, - & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, - & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcanl(3:4) + if (lsoil > 2) then + call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) endif - kqcm=1 + kqcm = 1 call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, @@ -2175,10 +2186,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, @@ -2198,7 +2209,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,*) '==============' @@ -2228,7 +2239,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)' @@ -2244,13 +2255,13 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) !clu [+4l] add smcanl(3:4) and stcanl(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) - call monitr('tg3anl',tg3anl,slianl,snoanl,len) - call monitr('zoranl',zoranl,slianl,snoanl,len) + if (lsoil > 2) then + call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) + call monitr('tg3anl',tg3anl,slianl,snoanl,len) + call monitr('zoranl',zoranl,slianl,snoanl,len) endif ! if (gaus) then call monitr('cvaanl',cvanl ,slianl,snoanl,len) @@ -2312,7 +2323,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)' @@ -2330,11 +2341,11 @@ subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc call monitr('stcanl1',stcfcs(1,1),slianl,snoanl,len) call monitr('stcanl2',stcfcs(1,2),slianl,snoanl,len) !clu [+4l] add smcfcs(3:4) and stc(3:4) - if(lsoil.gt.2) then - call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) - call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) - call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) - call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) + if (lsoil > 2) then + call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) endif call monitr('tg3dif',tg3fcs,slianl,snoanl,len) call monitr('zordif',zorfcs,slianl,snoanl,len) @@ -2386,7 +2397,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) @@ -2405,62 +2416,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 @@ -2471,13 +2503,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. @@ -2485,14 +2517,14 @@ 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) + 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 @@ -2504,7 +2536,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 @@ -2648,7 +2680,7 @@ subroutine dayoyr(iyr,imo,idy,ldy) enddo return end - subroutine hmskrd(lugb,imsk,jmsk,fnmskh, + subroutine hmskrd(lugb,imsk,jmsk,fnmskh, & & kpds5,slmskh,gausm,blnmsk,bltmsk,me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata, xdata, ydata @@ -2681,7 +2713,7 @@ subroutine hmskrd(lugb,imsk,jmsk,fnmskh, ! return end - subroutine fixrdg(lugb,idim,jdim,fngrib, + subroutine fixrdg(lugb,idim,jdim,fngrib, & & kpds5,gdata,gaus,blno,blto,me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata @@ -2796,8 +2828,7 @@ subroutine fixrdg(lugb,idim,jdim,fngrib, deallocate(lbms) return end - 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 @@ -3006,16 +3037,16 @@ subroutine subst(data,imax,jmax,dlon,dlat,ijordr) endif return end - subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, - & gauout,len,lmask,rslmsk,slmask + 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 implicit none - real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, - & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, - & wi1j2,wi2j1,rlat,rlon,aphi, + real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, & + & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, & + & wi1j2,wi2j1,rlat,rlon,aphi, & & rnume,alamd,denom - integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, + integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, & & ii,i1,i2,kmami,it integer nx,kxs,kxt integer, allocatable, save :: imxnx(:) @@ -3023,7 +3054,7 @@ subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, ! ! interpolation from lat/lon or gaussian grid to other lat/lon grid ! - real (kind=kind_io8) outlon(len),outlat(len),gauout(len), + real (kind=kind_io8) outlon(len),outlat(len),gauout(len), & & slmask(len) real (kind=kind_io8) regin (imxin,jmxin),rslmsk(imxin,jmxin) ! @@ -3575,54 +3606,46 @@ subroutine maxmin(f,imax,kmax) ! return end - subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, - & aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, - & vetanl,sotanl,alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, - & aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, - & vetclm,sotclm,alfclm, -!cwu [+1l] add ()clm for sih, sic - & sihclm,sicclm, -!clu [+1l] add ()clm for vmn, vmx, slp, abs - & vmnclm,vmxclm,slpclm,absclm, + subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, & + & aisanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, & + & vetanl,sotanl,alfanl, & + & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, & + & aisclm, & + & tg3clm,cvclm ,cvbclm,cvtclm, & + & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, & + & vetclm,sotclm,alfclm, & + & sihclm,sicclm, & !cwu [+1l] add ()clm for sih, sic + & vmnclm,vmxclm,slpclm,absclm, & !clu [+1l] add ()clm for vmn, vmx, slp, abs & len,lsoil) use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil ! - real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), - & snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),scvanl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs + real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), & + & snoanl(len), & + & zoranl(len),albanl(len,4),aisanl(len), & + & tg3anl(len), & + & cvanl (len),cvbanl(len),cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len),scvanl(len),veganl(len), & + & vetanl(len),sotanl(len),alfanl(len,2) & + &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) - real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), - & snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) -!cwu [+1l] add ()clm for sih, sic - &, sihclm(len),sicclm(len) -!clu [+1l] add ()clm for vmn, vmx, slp, abs + real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), & + & snoclm(len), & + & zorclm(len),albclm(len,4),aisclm(len), & + & tg3clm(len), & + & cvclm (len),cvbclm(len),cvtclm(len), & + & cnpclm(len), & + & smcclm(len,lsoil),stcclm(len,lsoil), & + & sliclm(len),scvclm(len),vegclm(len), & + & vetclm(len),sotclm(len),alfclm(len,2) & + &, sihclm(len),sicclm(len) & &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) ! do i=1,len @@ -3672,43 +3695,34 @@ subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, ! return end - subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, - & fnveta,fnsota, -!clu [+1l] add fn()a for vmn, vmx, slp, abs - & fnvmna,fnvmxa,fnslpa,fnabsa, - & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & smcanl,stcanl,slianl,scvanl,acnanl,veganl, - & vetanl,sotanl,alfanl,tsfan0, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, -!cggg snow mods start & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, -!cggg snow mods end - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kprvet,kpdsot,kpdalf, -!clu [+1l] add kpd() for vmn, vmx, slp, abs - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvet,irtsot,irtalf -!clu [+1l] add irt() for vmn, vmx, slp, abs - &, irtvmn,irtvmx,irtslp,irtabs - &, imsk, jmsk, slmskh, outlat, outlon + subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, & + & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa,& + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & + & fnveta,fnsota, & + & fnvmna,fnvmxa,fnslpa,fnabsa, & !clu [+1l] add fn()a for vmn, vmx, slp, abs + & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & smcanl,stcanl,slianl,scvanl,acnanl,veganl, & + & vetanl,sotanl,alfanl,tsfan0, & + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs + & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais,& + & 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, & !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 + &, imsk, jmsk, slmskh, outlat, outlon & &, gaus, blno, blto, me, lanom) use machine , only : kind_io8,kind_io4 implicit none logical lanom - integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, - & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, -!cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, - & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy, -!cggg snow mods end - & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, - & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j -!clu [+1l] add kpd() and irt() for vmn, vmx, slp, abs + integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, & + & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, & + & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy,& + & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, & + & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j & &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs real (kind=kind_io8) blto,blno,fh ! @@ -3721,21 +3735,19 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, integer lugi, lskip, lgrib, ndata !cggg snow mods end ! - character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, - & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, & + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, & & fnveta,fnsota -!clu [+1l] add fn()a for vmn, vmx, slp, abs &, 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), - & cvanl (len), cvbanl(len), cvtanl(len), - & slianl(len), scvanl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2), - & smcanl(len,lsoil), stcanl(len,lsoil), - & tsfan0(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), & + & zoranl(len), albanl(len,4), aisanl(len), & + & tg3anl(len), acnanl(len), & + & cvanl (len), cvbanl(len), cvtanl(len), & + & slianl(len), scvanl(len), veganl(len), & + & vetanl(len), sotanl(len), alfanl(len,2), & + & smcanl(len,lsoil), stcanl(len,lsoil), & + & tsfan0(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! logical gaus @@ -3788,36 +3800,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 @@ -3825,30 +3837,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 @@ -4336,53 +4348,45 @@ subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, ! return end - subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, - & tg3fcs,cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, - & vegfcs, vetfcs, sotfcs, alffcs, -!cwu [+1l] add ()fcs for sih, sic - & sihfcs,sicfcs, -!clu [+1l] add ()fcs for vmn, vmx, slp, abs - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsfanl,wetanl,snoanl,zoranl,albanl, - & tg3anl,cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,aisanl, - & veganl, vetanl, sotanl, alfanl, -!cwu [+1l] add ()anl for sih, sic - & sihanl,sicanl, -!clu [+1l] add ()anl for vmn, vmx, slp, abs - & vmnanl,vmxanl,slpanl,absanl, + subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, & + & tg3fcs,cvfcs ,cvbfcs,cvtfcs, & + & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, & + & vegfcs, vetfcs, sotfcs, alffcs, & + & sihfcs,sicfcs, & !cwu [+1l] add ()fcs for sih, sic + & vmnfcs,vmxfcs,slpfcs,absfcs, & !clu [+1l] add ()fcs for vmn, vmx, slp, abs + & tsfanl,wetanl,snoanl,zoranl,albanl, & + & tg3anl,cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,aisanl, & + & veganl, vetanl, sotanl, alfanl, & + & sihanl,sicanl, & !cwu [+1l] add ()anl for sih, sic + & vmnanl,vmxanl,slpanl,absanl, & !clu [+1l] add ()anl for vmn, vmx, slp, abs & len,lsoil) ! use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil - real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), - & zorfcs(len),albfcs(len,4),aisfcs(len), - & tg3fcs(len), - & cvfcs (len),cvbfcs(len),cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len),vegfcs(len), - & vetfcs(len),sotfcs(len),alffcs(len,2) -!cwu [+1l] add ()fcs for sih, sic - &, sihfcs(len),sicfcs(len) -!clu [+1l] add ()fcs for vmn, vmx, slp, abs + real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), & + & zorfcs(len),albfcs(len,4),aisfcs(len), & + & tg3fcs(len), & + & cvfcs (len),cvbfcs(len),cvtfcs(len), & + & cnpfcs(len), & + & smcfcs(len,lsoil),stcfcs(len,lsoil), & + & slifcs(len),vegfcs(len), & + & vetfcs(len),sotfcs(len),alffcs(len,2) & + &, sihfcs(len),sicfcs(len) & &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), - & zoranl(len),albanl(len,4),aisanl(len), - & tg3anl(len), - & cvanl (len),cvbanl(len),cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len),veganl(len), - & vetanl(len),sotanl(len),alfanl(len,2) -!cwu [+1l] add ()anl for sih, sic - &, sihanl(len),sicanl(len) -!clu [+1l] add ()anl for vmn, vmx, slp, abs + real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), & + & zoranl(len),albanl(len,4),aisanl(len), & + & tg3anl(len), & + & cvanl (len),cvbanl(len),cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len),veganl(len), & + & vetanl(len),sotanl(len),alfanl(len,2) & + &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! - write(6,*) ' this is a dead start run, tsfc over land is', + write(6,*) ' this is a dead start run, tsfc over land is', & & ' set as lowest sigma level temperture if given.' write(6,*) ' if not, set to climatological tsf over land is used' ! @@ -4433,7 +4437,7 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) use machine , only : kind_io8,kind_io4 implicit none integer i,j,len,lsoil,k - real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), + real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), & & slianl(len) ! ! note that smfcs comes in with the original unit (cm?) (not grib file) @@ -4456,43 +4460,97 @@ subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) ! return end - 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 + write(6,*) ' illegal operator in rof01. op=',op + call abort + endif +! + return + end + 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 @@ -4517,7 +4575,7 @@ subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) enddo return end - subroutine snodpth(scvanl,slianl,tsfanl,snoclm, + subroutine snodpth(scvanl,slianl,tsfanl,snoclm, & & glacir,snwmax,snwmin,landice,len,snoanl, me) use machine , only : kind_io8,kind_io4 implicit none @@ -4525,7 +4583,7 @@ subroutine snodpth(scvanl,slianl,tsfanl,snoclm, logical, intent(in) :: landice real (kind=kind_io8) sno,snwmax,snwmin ! - real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), + real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), & & snoclm(len), snoanl(len), glacir(len) ! if (me .eq. 0) write(6,*) 'snodpth' @@ -4571,80 +4629,80 @@ subroutine snodpth(scvanl,slianl,tsfanl,snoclm, enddo return end subroutine snodpth - subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, - & sihfcs,sicfcs, - & vmnfcs,vmxfcs,slpfcs,absfcs, - & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, - & cvfcs ,cvbfcs,cvtfcs, - & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, - & vetfcs,sotfcs,alffcs, - & sihanl,sicanl, - & vmnanl,vmxanl,slpanl,absanl, - & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, - & cvanl ,cvbanl,cvtanl, - & cnpanl,smcanl,stcanl,slianl,veganl, - & vetanl,sotanl,alfanl, - & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, - & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, - & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, - & calfl,calfs, - & csihl,csihs,csicl,csics, - & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, - & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, - & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, - & irtvmn,irtvmx,irtslp,irtabs, + subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, & + & sihfcs,sicfcs, & + & vmnfcs,vmxfcs,slpfcs,absfcs, & + & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, & + & cvfcs ,cvbfcs,cvtfcs, & + & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, & + & vetfcs,sotfcs,alffcs, & + & sihanl,sicanl, & + & vmnanl,vmxanl,slpanl,absanl, & + & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl,& + & cvanl ,cvbanl,cvtanl, & + & cnpanl,smcanl,stcanl,slianl,veganl, & + & vetanl,sotanl,alfanl, & + & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, & + & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, & + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, & + & calfl,calfs, & + & csihl,csihs,csicl,csics, & + & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, & + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, & + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, & + & 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 implicit none - integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, - & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, - & irtalb,irtsno,irttsf,irtwet,j + integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, & + & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, & + & irtalb,irtsno,irttsf,irtwet,j & &, irtvmn,irtvmx,irtslp,irtabs logical, intent(in) :: landice - real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, - & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, - & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, - & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, - & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, - & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, - & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, - & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, - & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, - & cvets,calfs,deltsfc, - & csihl,csihs,csicl,csics, - & rsihl,rsihs,rsicl,rsics, - & qsihl,qsihs,qsicl,qsics - &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps - &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs - &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns + real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, & + & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, & + & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, & + & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, & + & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, & + & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, & + & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, & + & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, & + & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, & + & cvets,calfs,deltsfc, & + & csihl,csihs,csicl,csics, & + & rsihl,rsihs,rsicl,rsics, & + & qsihl,qsihs,qsicl,qsics & + &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps & + &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs & + &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns & &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss ! - real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), - & zorfcs(len), albfcs(len,4), aisfcs(len), - & cvfcs (len), cvbfcs(len), cvtfcs(len), - & cnpfcs(len), - & smcfcs(len,lsoil),stcfcs(len,lsoil), - & slifcs(len), vegfcs(len), - & vetfcs(len), sotfcs(len), alffcs(len,2) - &, sihfcs(len), sicfcs(len) + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), & + & zorfcs(len), albfcs(len,4), aisfcs(len), & + & cvfcs (len), cvbfcs(len), cvtfcs(len), & + & cnpfcs(len), & + & smcfcs(len,lsoil),stcfcs(len,lsoil), & + & slifcs(len), vegfcs(len), & + & vetfcs(len), sotfcs(len), alffcs(len,2) & + &, sihfcs(len), sicfcs(len) & &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) - real (kind=kind_io8) tsfanl(len),tsfan2(len), - & wetanl(len),snoanl(len), - & zoranl(len), albanl(len,4), aisanl(len), - & cvanl (len), cvbanl(len), cvtanl(len), - & cnpanl(len), - & smcanl(len,lsoil),stcanl(len,lsoil), - & slianl(len), veganl(len), - & vetanl(len), sotanl(len), alfanl(len,2) - &, sihanl(len),sicanl(len) + real (kind=kind_io8) tsfanl(len),tsfan2(len), & + & wetanl(len),snoanl(len), & + & zoranl(len), albanl(len,4), aisanl(len), & + & cvanl (len), cvbanl(len), cvtanl(len), & + & cnpanl(len), & + & smcanl(len,lsoil),stcanl(len,lsoil), & + & slianl(len), veganl(len), & + & vetanl(len), sotanl(len), alfanl(len,2) & + &, sihanl(len),sicanl(len) & &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) ! - real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), + real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), & & cstcl(lsoil), cstcs(lsoil) - real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), + real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), & & rstcl(lsoil), rstcs(lsoil) - real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), + real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), & & qstcl(lsoil), qstcs(lsoil) logical first integer num_threads @@ -5022,18 +5080,17 @@ subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, !$omp end parallel do return end subroutine merge - subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, -!cwu [+1l] add sihnew,sicnew,sihanl,sicanl - & sihnew,sicnew,sihanl,sicanl, - & albanl,snoanl,zoranl,smcanl,stcanl, - & albsea,snosea,zorsea,smcsea,smcice, - & tsfmin,tsfice,albice,zorice,tgice, + subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, & + & sihnew,sicnew,sihanl,sicanl, & !cwu [+1l] add sihnew,sicnew,sihanl,sicanl + & albanl,snoanl,zoranl,smcanl,stcanl, & + & albsea,snosea,zorsea,smcsea,smcice, & + & tsfmin,tsfice,albice,zorice,tgice, & & rla,rlo,me) ! use machine , only : kind_io8,kind_io4 implicit none real (kind=kind_io8), parameter :: one=1.0 - real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, + real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, & & smcice,tsfmin,zorsea,smcsea !cwu [+1l] add sicnew,sihnew &, sicnew,sihnew @@ -5118,7 +5175,7 @@ subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, ! return end - subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, + subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, & & landice,me) use machine , only : kind_io8,kind_io4 implicit none @@ -5164,20 +5221,20 @@ subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, endif return end subroutine qcsnow - subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, + subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, & & rla,rlo,len,me) use machine , only : kind_io8,kind_io4 implicit none integer kount1,kount,i,me,len real (kind=kind_io8) per,aicsea,aicice,sllnd ! - real (kind=kind_io8) ais(len), glacir(len), + real (kind=kind_io8) ais(len), glacir(len), & & amxice(len), slmask(len) real (kind=kind_io8) rla(len), rlo(len) ! ! 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 @@ -5275,9 +5332,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 @@ -5292,66 +5348,63 @@ subroutine scale(fld,len,scl) enddo return end - subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, - & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, - & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, + subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, & + & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, & + & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, & & rla,rlo,len,mode,percrit,lgchek,me) ! use machine , only : kind_io8,kind_io4 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*8 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 ! - integer len_thread_m, i1_t, i2_t, it - integer num_parthds + integer :: len_thread_m, i1_t, i2_t, it, num_parthds, & + & 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) @@ -5360,24 +5413,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 @@ -5386,11 +5439,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 @@ -5399,11 +5452,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 @@ -5412,11 +5465,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 @@ -5425,11 +5478,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 @@ -5438,11 +5491,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 @@ -5451,11 +5504,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,i & & ' 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 @@ -5464,11 +5517,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 @@ -5477,11 +5529,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 @@ -5490,24 +5542,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 @@ -5516,11 +5567,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 @@ -5529,11 +5580,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 @@ -5542,12 +5593,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 @@ -5556,11 +5607,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 @@ -5569,11 +5620,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 @@ -5582,11 +5633,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 @@ -5595,12 +5646,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 @@ -5609,11 +5660,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 @@ -5624,78 +5675,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 @@ -5784,7 +5834,7 @@ subroutine getsmc(wetfld,len,lsoil,smcfld,me) enddo return end - subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, + subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, & & tsfimx) ! use machine , only : kind_io8,kind_io4 @@ -5930,23 +5980,21 @@ subroutine qcsli(slianl,slifcs,len,me) !1111 format(80i1) ! return ! end - subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, - & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, - & zoranl,smcanl, - & smcclm,tsfsmx,albomx,zoromx, me) + subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, & + & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, & + & 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 ! @@ -5954,7 +6002,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. @@ -6026,8 +6074,8 @@ subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, ! return end - subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, - & data,imax,jmax,rlnout,rltout,lmask,rslmsk + subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, & + & data,imax,jmax,rlnout,rltout,lmask,rslmsk & &, gaus,blno, blto, kgds1, kpds4, lbms) use machine , only : kind_io8,kind_io4 use sfccyc_module @@ -6507,25 +6555,25 @@ subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, ! return end - subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, + subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, & & wlon,rnlat,rlnout,rltout,gaus,blno, blto) use machine , only : kind_io8,kind_io4 implicit none - integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, + integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, & & j,iret - real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, - & rnlat,dxout,dphi,dlat,facns,tem,blno, + real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, & + & rnlat,dxout,dphi,dlat,facns,tem,blno, & & blto ! ! interpolation from lat/lon grid to other lat/lon grid ! - real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) + real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) & &, rlnout(imxout), rltout(jmxout) logical gaus ! real, allocatable :: gaul(:) real (kind=kind_io8) ddx(imxout),ddy(jmxout) - integer iindx1(imxout), iindx2(imxout), + integer iindx1(imxout), iindx2(imxout), & & jindx1(jmxout), jindx2(jmxout) integer jmxsav,n,kspla data jmxsav/0/ @@ -6757,8 +6805,8 @@ subroutine landtyp(vegtype,soiltype,slptype,slmask,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) - +, slptype(len) + real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) & + &, slptype(len) ! ! make sure that the soil type and veg type are non-zero over land ! @@ -6800,7 +6848,7 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) use machine , only : kind_io8,kind_io4 implicit none integer i,len - real (kind=kind_io8) tsfanl(len), tsfan0(len), + real (kind=kind_io8) tsfanl(len), tsfan0(len), & & tsfclm(len), tsfcl0(len) ! ! time interpolation of anomalies @@ -6812,53 +6860,53 @@ subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) enddo return end - subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, - & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc, - & fnvmnc,fnvmxc,fnslpc,fnabsc, - & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, - & tg3clm,cvclm ,cvbclm,cvtclm, - & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, - & vetclm,sotclm,alfclm, - & vmnclm,vmxclm,slpclm,absclm, - & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, - & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, - & kpdvet,kpdsot,kpdalf,tsfcl0, - & kpdvmn,kpdvmx,kpdslp,kpdabs, - & deltsfc, lanom - &, imsk, jmsk, slmskh, outlat, outlon - &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb + subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, & + & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc,& + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & + & fnvetc,fnsotc, & + & fnvmnc,fnvmxc,fnslpc,fnabsc, & + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm,& + & tg3clm,cvclm ,cvbclm,cvtclm, & + & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm,& + & vetclm,sotclm,alfclm, & + & vmnclm,vmxclm,slpclm,absclm, & + & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, & + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, & + & kpdvet,kpdsot,kpdalf,tsfcl0, & + & kpdvmn,kpdvmx,kpdslp,kpdabs, & + & deltsfc, lanom & + &, imsk, jmsk, slmskh, outlat, outlon & + &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb & &, tile_num_ch, i_index, j_index) ! use machine , only : kind_io8,kind_io4 implicit none character(len=*), intent(in) :: tile_num_ch integer, intent(in) :: i_index(len), j_index(len) - real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, + real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, & & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2 real (kind=kind_io8) wei1y,wei2y - integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, - & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, - & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, - & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, - & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb + integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, & + & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, & + & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, & + & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, & + & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb & &, kpdvmn,kpdvmx,kpdslp,kpdabs,landice_cat integer kpdalb(4), kpdalf(2) ! - character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, - & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, - & fnvetc,fnsotc,fnalbc2 + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, & + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, & + & fnvetc,fnsotc,fnalbc2 & &, fnvmnc,fnvmxc,fnslpc,fnabsc - real (kind=kind_io8) tsfclm(len),tsfcl2(len), - & wetclm(len),snoclm(len), - & zorclm(len),albclm(len,4),aisclm(len), - & tg3clm(len),acnclm(len), - & cvclm (len),cvbclm(len),cvtclm(len), - & cnpclm(len), - & smcclm(len,lsoil),stcclm(len,lsoil), - & sliclm(len),scvclm(len),vegclm(len), - & vetclm(len),sotclm(len),alfclm(len,2) + real (kind=kind_io8) tsfclm(len),tsfcl2(len), & + & wetclm(len),snoclm(len), & + & zorclm(len),albclm(len,4),aisclm(len), & + & tg3clm(len),acnclm(len), & + & cvclm (len),cvbclm(len),cvtclm(len), & + & cnpclm(len), & + & smcclm(len,lsoil),stcclm(len,lsoil), & + & sliclm(len),scvclm(len),vegclm(len), & + & vetclm(len),sotclm(len),alfclm(len,2) & &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) real (kind=kind_io8) slmskh(imsk,jmsk) real (kind=kind_io8) outlat(len), outlon(len) @@ -7175,8 +7223,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 @@ -7982,9 +8029,8 @@ subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, ! return end subroutine clima - subroutine fixrdc_tile(filename_raw, tile_num_ch, - & i_index, j_index, kpds, - & var, mon, npts, me) + subroutine fixrdc_tile(filename_raw, tile_num_ch, & + & i_index, j_index, kpds, var, mon, npts, me) use netcdf use machine , only : kind_io8 implicit none @@ -8001,7 +8047,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) = " " @@ -8132,15 +8179,17 @@ subroutine netcdf_err(error) call abort end subroutine netcdf_err - subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, - & gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto + + + subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, & + & gdata,len,iret & + &, imsk, jmsk, slmskh, gaus,blno, blto & &, outlat, outlon, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata implicit none - integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, - & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami + integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, & + & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami & &, jj,w3kindreal,w3kindint real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto ! @@ -8308,18 +8357,19 @@ subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, deallocate(lbms) return end subroutine fixrdc - subroutine fixrda(lugb,fngrib,kpds5,slmask, - & iy,im,id,ih,fh,gdata,len,iret - &, imsk, jmsk, slmskh, gaus,blno, blto + + subroutine fixrda(lugb,fngrib,kpds5,slmask, & + & iy,im,id,ih,fh,gdata,len,iret & + &, imsk, jmsk, slmskh, gaus,blno, blto & &, outlat, outlon, me) use machine , only : kind_io8,kind_io4 use sfccyc_module, only : mdata implicit none - integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, - & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, - & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, + integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, & + & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, & + & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, & & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint - real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, + real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, & & rjday,blto ! ! read in grib climatology/analysis files and interpolate to the input diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index b86cd0295..e0898c3f6 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -91,6 +91,7 @@ module FV3GFS_io_mod real(kind=kind_phys) :: zhour ! + integer, parameter :: r8 = kind_phys integer :: tot_diag_idx = 0 integer :: total_outputlevel = 0 integer :: isco,ieco,jsco,jeco,levo,num_axes_phys @@ -107,10 +108,10 @@ module FV3GFS_io_mod logical :: uwork_set = .false. character(128) :: uwindname integer, parameter, public :: DIAG_SIZE = 500 - real, parameter :: missing_value = 9.99e20 - real, parameter:: stndrd_atmos_ps = 101325. - real, parameter:: stndrd_atmos_lapse = 0.0065 - real, parameter:: drythresh = 1.e-4 + real, parameter :: missing_value = 9.99e20_r8 + real, parameter:: stndrd_atmos_ps = 101325.0_r8 + real, parameter:: stndrd_atmos_lapse = 0.0065_r8 + real, parameter:: drythresh = 1.e-4_r8, zero = 0.0_r8, one = 1.0_r8 !--- miscellaneous other variables logical :: use_wrtgridcomp_output = .FALSE. @@ -207,9 +208,9 @@ subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) allocate (temp3d(isc:iec,jsc:jec,1:lev,14+Model%ntot3d+2*ntr)) allocate (temp3dlevsp1(isc:iec,jsc:jec,1:lev+1,3)) - temp2d = 0. - temp3d = 0. - temp3dlevsp1 = 0. + temp2d = zero + temp3d = zero + temp3dlevsp1 = zero do j=jsc,jec do i=isc,iec @@ -385,16 +386,16 @@ subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) endif if (Model%nstf_name(1) > 0) then - temp2d(i,j,idx_opt) = IPD_Data(nb)%Sfcprop%tref(ix) - temp2d(i,j,idx_opt+1) = IPD_Data(nb)%Sfcprop%z_c(ix) - temp2d(i,j,idx_opt+2) = IPD_Data(nb)%Sfcprop%c_0(ix) - temp2d(i,j,idx_opt+3) = IPD_Data(nb)%Sfcprop%c_d(ix) - temp2d(i,j,idx_opt+4) = IPD_Data(nb)%Sfcprop%w_0(ix) - temp2d(i,j,idx_opt+5) = IPD_Data(nb)%Sfcprop%w_d(ix) - temp2d(i,j,idx_opt+6) = IPD_Data(nb)%Sfcprop%xt(ix) - temp2d(i,j,idx_opt+7) = IPD_Data(nb)%Sfcprop%xs(ix) - temp2d(i,j,idx_opt+8) = IPD_Data(nb)%Sfcprop%xu(ix) - temp2d(i,j,idx_opt+9) = IPD_Data(nb)%Sfcprop%xz(ix) + temp2d(i,j,idx_opt ) = IPD_Data(nb)%Sfcprop%tref(ix) + temp2d(i,j,idx_opt+ 1) = IPD_Data(nb)%Sfcprop%z_c(ix) + temp2d(i,j,idx_opt+ 2) = IPD_Data(nb)%Sfcprop%c_0(ix) + temp2d(i,j,idx_opt+ 3) = IPD_Data(nb)%Sfcprop%c_d(ix) + temp2d(i,j,idx_opt+ 4) = IPD_Data(nb)%Sfcprop%w_0(ix) + temp2d(i,j,idx_opt+ 5) = IPD_Data(nb)%Sfcprop%w_d(ix) + temp2d(i,j,idx_opt+ 6) = IPD_Data(nb)%Sfcprop%xt(ix) + temp2d(i,j,idx_opt+ 7) = IPD_Data(nb)%Sfcprop%xs(ix) + temp2d(i,j,idx_opt+ 8) = IPD_Data(nb)%Sfcprop%xu(ix) + temp2d(i,j,idx_opt+ 9) = IPD_Data(nb)%Sfcprop%xz(ix) temp2d(i,j,idx_opt+10) = IPD_Data(nb)%Sfcprop%zm(ix) temp2d(i,j,idx_opt+11) = IPD_Data(nb)%Sfcprop%xtts(ix) temp2d(i,j,idx_opt+12) = IPD_Data(nb)%Sfcprop%xzts(ix) @@ -509,7 +510,7 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !--- local variables for sncovr calculation integer :: vegtyp logical :: mand - real(kind=kind_phys) :: rsnow, tem + real(kind=kind_phys) :: rsnow, tem, tem1 !--- Noah MP integer :: soiltyp,ns,imon,iter,imn real(kind=kind_phys) :: masslai, masssai,snd @@ -520,15 +521,9 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) real(kind=kind_phys), dimension(-2:4) :: dzsnso real(kind=kind_phys), dimension(4), save :: zsoil,dzs - data dzs /0.1,0.3,0.6,1.0/ - data zsoil /-0.1,-0.4,-1.0,-2.0/ + data dzs / 0.1_r8, 0.3_r8, 0.6_r8, 1.0_r8/ + data zsoil /-0.1_r8,-0.4_r8,-1.0_r8,-2.0_r8/ - - if (Model%cplflx) then ! needs more variables - nvar_s2m = 34 - else - nvar_s2m = 32 - endif nvar_o2 = 19 nvar_oro_ls_ss = 10 nvar_s2o = 18 @@ -612,6 +607,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) call restore_state(Oro_restart) !--- copy data into GFS containers + +!$omp parallel do default(shared) private(i, j, nb, ix) do nb = 1, Atm_block%nblks !--- 2D variables do ix = 1, Atm_block%blksz(nb) @@ -646,6 +643,15 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo +! if (Model%frac_grid) then ! needs more variables + nvar_s2m = 35 +! else +! nvar_s2m = 32 +! endif + if (Model%cplwav) then + nvar_s2m = nvar_s2m + 1 + endif + !--- deallocate containers and free restart container deallocate(oro_name2, oro_var2) call free_restart_type(Oro_restart) @@ -745,19 +751,20 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) allocate(sfc_name3(0:nvar_s3+nvar_s3mp)) allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp)) + allocate(sfc_var3ice(nx,ny,Model%kice)) allocate(sfc_var3(nx,ny,Model%lsoil,nvar_s3)) #endif - sfc_var2 = -9999._kind_phys - sfc_var3 = -9999._kind_phys - sfc_var3ice= -9999._kind_phys + sfc_var2 = -9999.0_r8 + sfc_var3 = -9999.0_r8 + sfc_var3ice= -9999.0_r8 ! if (Model%lsm == Model%lsm_noahmp) then allocate(sfc_var3sn(nx,ny,-2:0,4:6)) allocate(sfc_var3eq(nx,ny,1:4,7:7)) allocate(sfc_var3zn(nx,ny,-2:4,8:8)) - sfc_var3sn = -9999._kind_phys - sfc_var3eq = -9999._kind_phys - sfc_var3zn = -9999._kind_phys + sfc_var3sn = -9999.0_r8 + sfc_var3eq = -9999.0_r8 + sfc_var3zn = -9999.0_r8 end if !--- names of the 2D variables to save @@ -794,10 +801,14 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) sfc_name2(31) = 'snoalb' !--- variables below here are optional sfc_name2(32) = 'sncovr' - if(Model%cplflx) then +! if(Model%frac_grid) then sfc_name2(33) = 'tsfcl' !temp on land portion of a cell sfc_name2(34) = 'zorll' !zorl on land portion of a cell - end if + sfc_name2(35) = 'zorli' !zorl on land portion of a cell +! endif + if(Model%cplwav) then + sfc_name2(nvar_s2m) = 'zorlw' !zorl on land portion of a cell + endif !--- NSSTM inputs only needed when (nstf_name(1) > 0) .and. (nstf_name(2)) == 0) sfc_name2(nvar_s2m+1) = 'tref' @@ -870,7 +881,8 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !--- register the 2D fields do num = 1,nvar_s2m var2_p => sfc_var2(:,:,num) - if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll') then + if (trim(sfc_name2(num)) == 'sncovr'.or. trim(sfc_name2(num)) == 'tsfcl' .or. trim(sfc_name2(num)) == 'zorll' & + .or. trim(sfc_name2(num)) == 'zorli' .or. trim(sfc_name2(num)) == 'zorlw') then id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain, mandatory=.false.) else id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain) @@ -978,17 +990,20 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) !coldstart(sfcfile doesn't include noah mp fields) or not if (Model%lsm == Model%lsm_noahmp) then - sfc_var2(1,1,nvar_s2m+19) = -66666. + sfc_var2(1,1,nvar_s2m+19) = -66666.0_r8 endif !--- read the surface restart/data call mpp_error(NOTE,'reading surface properties data from INPUT/sfc_data.tile*.nc') call restore_state(Sfc_restart) +! write(0,*)' stype read in min,max=',minval(sfc_var2(:,:,35)),maxval(sfc_var2(:,:,35)),' sfc_name2=',sfc_name2(35) ! write(0,*)' stype read in min,max=',minval(sfc_var2(:,:,18)),maxval(sfc_var2(:,:,18)) ! write(0,*)' sfc_var2=',sfc_var2(:,:,12) !--- place the data into the block GFS containers + +!$omp parallel do default(shared) private(i, j, nb, ix, lsoil) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) i = Atm_block%index(nb)%ii(ix) - isc + 1 @@ -1028,61 +1043,94 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) Sfcprop(nb)%slope(ix) = sfc_var2(i,j,30) !--- slope Sfcprop(nb)%snoalb(ix) = sfc_var2(i,j,31) !--- snoalb Sfcprop(nb)%sncovr(ix) = sfc_var2(i,j,32) !--- sncovr - if(Model%cplflx) then +! if(Model%frac_grid) then Sfcprop(nb)%tsfcl(ix) = sfc_var2(i,j,33) !--- sfcl (temp on land portion of a cell) Sfcprop(nb)%zorll(ix) = sfc_var2(i,j,34) !--- zorll (zorl on land portion of a cell) - end if + Sfcprop(nb)%zorli(ix) = sfc_var2(i,j,35) !--- zorll (zorl on ice portion of a cell) +! else +! Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) +! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) +! endif + if(Model%cplwav) then + Sfcprop(nb)%zorlw(ix) = sfc_var2(i,j,nvar_s2m) !--- (zorw from wave model) + else + Sfcprop(nb)%zorlw(ix) = Sfcprop(nb)%zorlo(ix) + endif if(Model%frac_grid) then ! obtain slmsk from landfrac !! next 5 lines are temporary till lake model is available - if (Sfcprop(nb)%lakefrac(ix) > 0.0) then - Sfcprop(nb)%lakefrac(ix) = nint(Sfcprop(nb)%lakefrac(ix)) - Sfcprop(nb)%landfrac(ix) = 1.-Sfcprop(nb)%lakefrac(ix) - if (Sfcprop(nb)%lakefrac(ix) == 0) Sfcprop(nb)%fice(ix)=0. - end if + if (Sfcprop(nb)%lakefrac(ix) > zero) then +! Sfcprop(nb)%lakefrac(ix) = nint(Sfcprop(nb)%lakefrac(ix)) + Sfcprop(nb)%landfrac(ix) = one - Sfcprop(nb)%lakefrac(ix) + if (Sfcprop(nb)%lakefrac(ix) == zero) Sfcprop(nb)%fice(ix) = zero + endif Sfcprop(nb)%slmsk(ix) = ceiling(Sfcprop(nb)%landfrac(ix)) - if (Sfcprop(nb)%fice(ix) > 0. .and. Sfcprop(nb)%landfrac(ix)==0.) Sfcprop(nb)%slmsk(ix) = 2 ! land dominates ice if co-exist + if (Sfcprop(nb)%fice(ix) > Model%min_lakeice .and. Sfcprop(nb)%landfrac(ix) == zero) Sfcprop(nb)%slmsk(ix) = 2 ! land dominates ice if co-exist else ! obtain landfrac from slmsk - if (Sfcprop(nb)%slmsk(ix) > 1.9) then - Sfcprop(nb)%landfrac(ix) = 0.0 + if (Sfcprop(nb)%slmsk(ix) > 1.9_r8) then + Sfcprop(nb)%landfrac(ix) = zero else Sfcprop(nb)%landfrac(ix) = Sfcprop(nb)%slmsk(ix) endif - end if + endif - if (Sfcprop(nb)%lakefrac(ix) > 0.0) then - Sfcprop(nb)%oceanfrac(ix) = 0.0 ! lake & ocean don't coexist in a cell - if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) Sfcprop(nb)%fice(ix) = 0. + if (Sfcprop(nb)%lakefrac(ix) > zero) then + Sfcprop(nb)%oceanfrac(ix) = zero ! lake & ocean don't coexist in a cell + if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) then + Sfcprop(nb)%fice(ix) = zero + if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 + endif else - Sfcprop(nb)%oceanfrac(ix) = 1.0 - Sfcprop(nb)%landfrac(ix) - if (Sfcprop(nb)%fice(ix) < Model%min_seaice) Sfcprop(nb)%fice(ix) = 0. + Sfcprop(nb)%oceanfrac(ix) = one - Sfcprop(nb)%landfrac(ix) + if (Sfcprop(nb)%fice(ix) < Model%min_seaice) then + Sfcprop(nb)%fice(ix) = zero + if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 + endif endif ! !--- NSSTM variables - if ((Model%nstf_name(1) > 0) .and. (Model%nstf_name(2) == 1)) then + if (Model%nstf_name(1) > 0) then + if (Model%nstf_name(2) == 1) then ! nsst spinup !--- nsstm tref - Sfcprop(nb)%tref(ix) = Sfcprop(nb)%tsfco(ix) - Sfcprop(nb)%xz(ix) = 30.0d0 - endif - if ((Model%nstf_name(1) > 0) .and. (Model%nstf_name(2) == 0)) then - Sfcprop(nb)%tref(ix) = sfc_var2(i,j,nvar_s2m+1) !--- nsstm tref - Sfcprop(nb)%z_c(ix) = sfc_var2(i,j,nvar_s2m+2) !--- nsstm z_c - Sfcprop(nb)%c_0(ix) = sfc_var2(i,j,nvar_s2m+3) !--- nsstm c_0 - Sfcprop(nb)%c_d(ix) = sfc_var2(i,j,nvar_s2m+4) !--- nsstm c_d - Sfcprop(nb)%w_0(ix) = sfc_var2(i,j,nvar_s2m+5) !--- nsstm w_0 - Sfcprop(nb)%w_d(ix) = sfc_var2(i,j,nvar_s2m+6) !--- nsstm w_d - Sfcprop(nb)%xt(ix) = sfc_var2(i,j,nvar_s2m+7) !--- nsstm xt - Sfcprop(nb)%xs(ix) = sfc_var2(i,j,nvar_s2m+8) !--- nsstm xs - Sfcprop(nb)%xu(ix) = sfc_var2(i,j,nvar_s2m+9) !--- nsstm xu - Sfcprop(nb)%xv(ix) = sfc_var2(i,j,nvar_s2m+10) !--- nsstm xv - Sfcprop(nb)%xz(ix) = sfc_var2(i,j,nvar_s2m+11) !--- nsstm xz - Sfcprop(nb)%zm(ix) = sfc_var2(i,j,nvar_s2m+12) !--- nsstm zm - Sfcprop(nb)%xtts(ix) = sfc_var2(i,j,nvar_s2m+13) !--- nsstm xtts - Sfcprop(nb)%xzts(ix) = sfc_var2(i,j,nvar_s2m+14) !--- nsstm xzts - Sfcprop(nb)%d_conv(ix) = sfc_var2(i,j,nvar_s2m+15) !--- nsstm d_conv - Sfcprop(nb)%ifd(ix) = sfc_var2(i,j,nvar_s2m+16) !--- nsstm ifd - Sfcprop(nb)%dt_cool(ix) = sfc_var2(i,j,nvar_s2m+17) !--- nsstm dt_cool - Sfcprop(nb)%qrain(ix) = sfc_var2(i,j,nvar_s2m+18) !--- nsstm qrain + Sfcprop(nb)%tref(ix) = Sfcprop(nb)%tsfco(ix) + Sfcprop(nb)%z_c(ix) = zero + Sfcprop(nb)%c_0(ix) = zero + Sfcprop(nb)%c_d(ix) = zero + Sfcprop(nb)%w_0(ix) = zero + Sfcprop(nb)%w_d(ix) = zero + Sfcprop(nb)%xt(ix) = zero + Sfcprop(nb)%xs(ix) = zero + Sfcprop(nb)%xu(ix) = zero + Sfcprop(nb)%xv(ix) = zero + Sfcprop(nb)%xz(ix) = 30.0_r8 + Sfcprop(nb)%zm(ix) = zero + Sfcprop(nb)%xtts(ix) = zero + Sfcprop(nb)%xzts(ix) = zero + Sfcprop(nb)%d_conv(ix) = zero + Sfcprop(nb)%ifd(ix) = zero + Sfcprop(nb)%dt_cool(ix) = zero + Sfcprop(nb)%qrain(ix) = zero + elseif (Model%nstf_name(2) == 0) then ! nsst restart + Sfcprop(nb)%tref(ix) = sfc_var2(i,j,nvar_s2m+1) !--- nsstm tref + Sfcprop(nb)%z_c(ix) = sfc_var2(i,j,nvar_s2m+2) !--- nsstm z_c + Sfcprop(nb)%c_0(ix) = sfc_var2(i,j,nvar_s2m+3) !--- nsstm c_0 + Sfcprop(nb)%c_d(ix) = sfc_var2(i,j,nvar_s2m+4) !--- nsstm c_d + Sfcprop(nb)%w_0(ix) = sfc_var2(i,j,nvar_s2m+5) !--- nsstm w_0 + Sfcprop(nb)%w_d(ix) = sfc_var2(i,j,nvar_s2m+6) !--- nsstm w_d + Sfcprop(nb)%xt(ix) = sfc_var2(i,j,nvar_s2m+7) !--- nsstm xt + Sfcprop(nb)%xs(ix) = sfc_var2(i,j,nvar_s2m+8) !--- nsstm xs + Sfcprop(nb)%xu(ix) = sfc_var2(i,j,nvar_s2m+9) !--- nsstm xu + Sfcprop(nb)%xv(ix) = sfc_var2(i,j,nvar_s2m+10) !--- nsstm xv + Sfcprop(nb)%xz(ix) = sfc_var2(i,j,nvar_s2m+11) !--- nsstm xz + Sfcprop(nb)%zm(ix) = sfc_var2(i,j,nvar_s2m+12) !--- nsstm zm + Sfcprop(nb)%xtts(ix) = sfc_var2(i,j,nvar_s2m+13) !--- nsstm xtts + Sfcprop(nb)%xzts(ix) = sfc_var2(i,j,nvar_s2m+14) !--- nsstm xzts + Sfcprop(nb)%d_conv(ix) = sfc_var2(i,j,nvar_s2m+15) !--- nsstm d_conv + Sfcprop(nb)%ifd(ix) = sfc_var2(i,j,nvar_s2m+16) !--- nsstm ifd + Sfcprop(nb)%dt_cool(ix) = sfc_var2(i,j,nvar_s2m+17) !--- nsstm dt_cool + Sfcprop(nb)%qrain(ix) = sfc_var2(i,j,nvar_s2m+18) !--- nsstm qrain + endif endif #ifdef CCPP if (Model%lsm == Model%lsm_ruc .and. warm_start) then @@ -1221,31 +1269,38 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) ! in the FV3/non-CCPP physics when the CCPP-enabled executable is built. #endif !#ifndef CCPP + + i = Atm_block%index(1)%ii(1) - isc + 1 + j = Atm_block%index(1)%jj(1) - jsc + 1 + !--- if sncovr does not exist in the restart, need to create it - if (nint(sfc_var2(1,1,32)) == -9999) then + if (sfc_var2(i,j,32) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing sncovr') !--- compute sncovr from existing variables !--- code taken directly from read_fix.f +!$omp parallel do default(shared) private(nb, ix, vegtyp, rsnow) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) - Sfcprop(nb)%sncovr(ix) = 0.0 + Sfcprop(nb)%sncovr(ix) = zero if (Sfcprop(nb)%landfrac(ix) >= drythresh .or. Sfcprop(nb)%fice(ix) >= Model%min_seaice) then vegtyp = Sfcprop(nb)%vtype(ix) if (vegtyp == 0) vegtyp = 7 - rsnow = 0.001*Sfcprop(nb)%weasd(ix)/snupx(vegtyp) - if (0.001*Sfcprop(nb)%weasd(ix) < snupx(vegtyp)) then - Sfcprop(nb)%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + rsnow = 0.001_r8*Sfcprop(nb)%weasd(ix)/snupx(vegtyp) + if (0.001_r8*Sfcprop(nb)%weasd(ix) < snupx(vegtyp)) then + Sfcprop(nb)%sncovr(ix) = one - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) else - Sfcprop(nb)%sncovr(ix) = 1.0 + Sfcprop(nb)%sncovr(ix) = one endif endif enddo enddo endif - if (Model%cplflx .or. Model%frac_grid) then - if (nint(sfc_var2(1,1,33)) == -9999) then +! if (Model%frac_grid) then + + if (sfc_var2(i,j,33) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tsfcl') +!$omp parallel do default(shared) private(nb, ix) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) !--- compute tsfcl from existing variables @@ -1253,55 +1308,91 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo endif - if (nint(sfc_var2(1,1,34)) == -9999) then + if (sfc_var2(i,j,34) < -9990.0_r8) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorll') +!$omp parallel do default(shared) private(nb, ix) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) !--- compute zorll from existing variables enddo enddo endif - endif -#ifdef CCPP - if (nint(sfc_var3ice(1,1,1)) == -9999) then - if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tiice') - do nb = 1, Atm_block%nblks - do ix = 1, Atm_block%blksz(nb) - Sfcprop(nb)%tiice(ix,1) = Sfcprop(nb)%stc(ix,1) !--- initialize internal ice temp from soil temp at layer 1 - Sfcprop(nb)%tiice(ix,2) = Sfcprop(nb)%stc(ix,2) !--- initialize internal ice temp from soil temp at layer 2 + if (sfc_var2(i,j,35) < -9990.0_r8) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorli') +!$omp parallel do default(shared) private(nb, ix) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) !--- compute zorli from existing variables + enddo enddo - enddo - endif + endif + + if (sfc_var2(i,j,nvar_s2m) < -9990.0_r8) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing zorli') +!$omp parallel do default(shared) private(nb, ix) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + Sfcprop(nb)%zorlw(ix) = Sfcprop(nb)%zorlo(ix) !--- compute zorlw from existing variables + enddo + enddo + endif -#endif !#endif if(Model%frac_grid) then ! 3-way composite +!$omp parallel do default(shared) private(nb, ix, tem, tem1) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) Sfcprop(nb)%tsfco(ix) = max(con_tice, Sfcprop(nb)%tsfco(ix)) - tem = (1.-Sfcprop(nb)%landfrac(ix)) * Sfcprop(nb)%fice(ix) ! tem = ice fraction wrt whole cell + tem1 = one - Sfcprop(nb)%landfrac(ix) + tem = tem1 * Sfcprop(nb)%fice(ix) ! tem = ice fraction wrt whole cell Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) * Sfcprop(nb)%landfrac(ix) & - + Sfcprop(nb)%zorll(ix) * tem & !zorl ice = zorl land - + Sfcprop(nb)%zorlo(ix) * (1.-Sfcprop(nb)%landfrac(ix)-tem) + + Sfcprop(nb)%zorli(ix) * tem & + + Sfcprop(nb)%zorlo(ix) * (tem1-tem) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) * Sfcprop(nb)%landfrac(ix) & - + Sfcprop(nb)%tisfc(ix) * tem & - + Sfcprop(nb)%tsfco(ix) * (1.-Sfcprop(nb)%landfrac(ix)-tem) + + Sfcprop(nb)%tisfc(ix) * tem & + + Sfcprop(nb)%tsfco(ix) * (tem1-tem) enddo enddo else +!$omp parallel do default(shared) private(nb, ix, tem) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) - !--- specify tsfcl/zorll from existing variable tsfco/zorlo - Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) - Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) - Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) - Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) + !--- specify tsfcl/zorll/zorli from existing variable tsfco/zorlo +! Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) +! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) + if (Sfcprop(nb)%slmsk(ix) == 1) then + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + else + tem = one - Sfcprop(nb)%fice(ix) + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%zorlo(ix) * tem + + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%tsfco(ix) * tem + endif enddo enddo endif ! if (Model%frac_grid) +!#ifdef CCPP + if (nint(sfc_var3ice(1,1,1)) == -9999) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing tiice') + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + Sfcprop(nb)%tiice(ix,1) = Sfcprop(nb)%stc(ix,1) !--- initialize internal ice temp from soil temp at layer 1 + Sfcprop(nb)%tiice(ix,2) = Sfcprop(nb)%stc(ix,2) !--- initialize internal ice temp from soil temp at layer 2 + enddo + enddo + endif +!#endif + if (Model%lsm == Model%lsm_noahmp) then if (nint(sfc_var2(1,1,nvar_s2m+19)) == -66666) then if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver:: - Cold start Noah MP ') @@ -1603,11 +1694,12 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p2 => NULL() real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p3 => NULL() - if (Model%cplflx) then ! needs more variables - nvar2m = 34 - else - nvar2m = 32 - endif +! if (Model%frac_grid) then ! needs more variables + nvar2m = 35 +! else +! nvar2m = 32 +! endif + if (Model%cplwav) nvar2m = nvar2m + 1 nvar2o = 18 #ifdef CCPP if (Model%lsm == Model%lsm_ruc) then @@ -1674,16 +1766,16 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta allocate(sfc_var2(nx,ny,nvar2m+nvar2o+nvar2mp)) allocate(sfc_var3(nx,ny,Model%lsoil,nvar3)) #endif - sfc_var2 = -9999._kind_phys - sfc_var3 = -9999._kind_phys + sfc_var2 = -9999.0_r8 + sfc_var3 = -9999.0_r8 if (Model%lsm == Model%lsm_noahmp) then allocate(sfc_var3sn(nx,ny,-2:0,4:6)) allocate(sfc_var3eq(nx,ny,1:4,7:7)) allocate(sfc_var3zn(nx,ny,-2:4,8:8)) - sfc_var3sn = -9999._kind_phys - sfc_var3eq = -9999._kind_phys - sfc_var3zn = -9999._kind_phys + sfc_var3sn = -9999.0_r8 + sfc_var3eq = -9999.0_r8 + sfc_var3zn = -9999.0_r8 endif @@ -1721,10 +1813,14 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name2(31) = 'snoalb' !--- variables below here are optional sfc_name2(32) = 'sncovr' - if (Model%cplflx) then +! if (Model%frac_grid) then sfc_name2(33) = 'tsfcl' !temp on land portion of a cell sfc_name2(34) = 'zorll' !zorl on land portion of a cell - end if + sfc_name2(35) = 'zorli' !zorl on land portion of a cell +! endif + if (Model%cplwav) then + sfc_name2(nvar2m) = 'zorlw' !zorl on land portion of a cell + endif !--- NSSTM inputs only needed when (nstf_name(1) > 0) .and. (nstf_name(2)) == 0) sfc_name2(nvar2m+1) = 'tref' sfc_name2(nvar2m+2) = 'z_c' @@ -1794,7 +1890,8 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta !--- register the 2D fields do num = 1,nvar2m var2_p => sfc_var2(:,:,num) - if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll') then + if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll' & + .or.trim(sfc_name2(num)) == 'zorli' .or.trim(sfc_name2(num)) == 'zorlw') then id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain, mandatory=.false.) else id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name2(num), var2_p, domain=fv_domain) @@ -1866,7 +1963,7 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_name3(0) = 'tiice' var3_p => sfc_var3ice(:,:,:) id_restart = register_restart_field(Sfc_restart, fn_srf, sfc_name3(0), var3_p, domain=fv_domain) - end if + endif do num = 1,nvar3 var3_p => sfc_var3(:,:,:,num) @@ -1894,16 +1991,23 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta endif +!$omp parallel do default(shared) private(i, j, nb, ix, lsoil) do nb = 1, Atm_block%nblks do ix = 1, Atm_block%blksz(nb) !--- 2D variables i = Atm_block%index(nb)%ii(ix) - isc + 1 j = Atm_block%index(nb)%jj(ix) - jsc + 1 sfc_var2(i,j,1) = Sfcprop(nb)%slmsk(ix) !--- slmsk - sfc_var2(i,j,2) = Sfcprop(nb)%tsfc(ix) !--- tsfc (tsea in sfc file) +! if (Model%frac_grid) then + sfc_var2(i,j,2) = Sfcprop(nb)%tsfco(ix) !--- tsfc (tsea in sfc file) + sfc_var2(i,j,5) = Sfcprop(nb)%zorlo(ix) !--- zorlo +! else +! sfc_var2(i,j,2) = Sfcprop(nb)%tsfc(ix) !--- tsfc (tsea in sfc file) +! sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl +! endif sfc_var2(i,j,3) = Sfcprop(nb)%weasd(ix) !--- weasd (sheleg in sfc file) sfc_var2(i,j,4) = Sfcprop(nb)%tg3(ix) !--- tg3 - sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl +! sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl sfc_var2(i,j,6) = Sfcprop(nb)%alvsf(ix) !--- alvsf sfc_var2(i,j,7) = Sfcprop(nb)%alvwf(ix) !--- alvwf sfc_var2(i,j,8) = Sfcprop(nb)%alnsf(ix) !--- alnsf @@ -1931,21 +2035,25 @@ subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timesta sfc_var2(i,j,30) = Sfcprop(nb)%slope(ix) !--- slope sfc_var2(i,j,31) = Sfcprop(nb)%snoalb(ix)!--- snoalb sfc_var2(i,j,32) = Sfcprop(nb)%sncovr(ix)!--- sncovr - if (Model%cplflx) then +! if (Model%frac_grid) then sfc_var2(i,j,33) = Sfcprop(nb)%tsfcl(ix) !--- tsfcl (temp on land) sfc_var2(i,j,34) = Sfcprop(nb)%zorll(ix) !--- zorll (zorl on land) - end if + sfc_var2(i,j,35) = Sfcprop(nb)%zorli(ix) !--- zorli (zorl on ice) +! endif + if (Model%cplwav) then + sfc_var2(i,j,nvar2m) = Sfcprop(nb)%zorlw(ix) !--- zorlw (zorl from wav) + endif !--- NSSTM variables if (Model%nstf_name(1) > 0) then - sfc_var2(i,j,nvar2m+1) = Sfcprop(nb)%tref(ix) !--- nsstm tref - sfc_var2(i,j,nvar2m+2) = Sfcprop(nb)%z_c(ix) !--- nsstm z_c - sfc_var2(i,j,nvar2m+3) = Sfcprop(nb)%c_0(ix) !--- nsstm c_0 - sfc_var2(i,j,nvar2m+4) = Sfcprop(nb)%c_d(ix) !--- nsstm c_d - sfc_var2(i,j,nvar2m+5) = Sfcprop(nb)%w_0(ix) !--- nsstm w_0 - sfc_var2(i,j,nvar2m+6) = Sfcprop(nb)%w_d(ix) !--- nsstm w_d - sfc_var2(i,j,nvar2m+7) = Sfcprop(nb)%xt(ix) !--- nsstm xt - sfc_var2(i,j,nvar2m+8) = Sfcprop(nb)%xs(ix) !--- nsstm xs - sfc_var2(i,j,nvar2m+9) = Sfcprop(nb)%xu(ix) !--- nsstm xu + sfc_var2(i,j,nvar2m+1) = Sfcprop(nb)%tref(ix) !--- nsstm tref + sfc_var2(i,j,nvar2m+2) = Sfcprop(nb)%z_c(ix) !--- nsstm z_c + sfc_var2(i,j,nvar2m+3) = Sfcprop(nb)%c_0(ix) !--- nsstm c_0 + sfc_var2(i,j,nvar2m+4) = Sfcprop(nb)%c_d(ix) !--- nsstm c_d + sfc_var2(i,j,nvar2m+5) = Sfcprop(nb)%w_0(ix) !--- nsstm w_0 + sfc_var2(i,j,nvar2m+6) = Sfcprop(nb)%w_d(ix) !--- nsstm w_d + sfc_var2(i,j,nvar2m+7) = Sfcprop(nb)%xt(ix) !--- nsstm xt + sfc_var2(i,j,nvar2m+8) = Sfcprop(nb)%xs(ix) !--- nsstm xs + sfc_var2(i,j,nvar2m+9) = Sfcprop(nb)%xu(ix) !--- nsstm xu sfc_var2(i,j,nvar2m+10) = Sfcprop(nb)%xv(ix) !--- nsstm xv sfc_var2(i,j,nvar2m+11) = Sfcprop(nb)%xz(ix) !--- nsstm xz sfc_var2(i,j,nvar2m+12) = Sfcprop(nb)%zm(ix) !--- nsstm zm @@ -2125,8 +2233,8 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) if (.not. allocated(phy_var2)) then allocate (phy_var2(nx,ny,nvar2d)) allocate (phy_var3(nx,ny,npz,nvar3d)) - phy_var2 = 0.0_kind_phys - phy_var3 = 0.0_kind_phys + phy_var2 = zero + phy_var3 = zero do num = 1,nvar2d var2_p => phy_var2(:,:,num) @@ -2154,6 +2262,7 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) !--- place the data into the block GFS containers !--- phy_var* variables +!$omp parallel do default(shared) private(i, j, nb, ix) do num = 1,nvar2d do nb = 1,Atm_block%nblks do ix = 1, Atm_block%blksz(nb) @@ -2166,16 +2275,18 @@ subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) !-- if restart from init time, reset accumulated diag fields if( Model%phour < 1.e-7) then do num = fdiag,ldiag +!$omp parallel do default(shared) private(i, j, nb, ix) do nb = 1,Atm_block%nblks do ix = 1, Atm_block%blksz(nb) i = Atm_block%index(nb)%ii(ix) - isc + 1 j = Atm_block%index(nb)%jj(ix) - jsc + 1 - IPD_Restart%data(nb,num)%var2p(ix) = 0. + IPD_Restart%data(nb,num)%var2p(ix) = zero enddo enddo enddo endif do num = 1,nvar3d +!$omp parallel do default(shared) private(i, j, k, nb, ix) do nb = 1,Atm_block%nblks do k=1,npz do ix = 1, Atm_block%blksz(nb) @@ -2230,8 +2341,8 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta if (.not. allocated(phy_var2)) then allocate (phy_var2(nx,ny,nvar2d)) allocate (phy_var3(nx,ny,npz,nvar3d)) - phy_var2 = 0.0_kind_phys - phy_var3 = 0.0_kind_phys + phy_var2 = zero + phy_var3 = zero do num = 1,nvar2d var2_p => phy_var2(:,:,num) @@ -2248,6 +2359,7 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta endif !--- 2D variables +!$omp parallel do default(shared) private(i, j, num, nb, ix) do num = 1,nvar2d do nb = 1,Atm_block%nblks do ix = 1, Atm_block%blksz(nb) @@ -2258,6 +2370,7 @@ subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timesta enddo enddo !--- 3D variables +!$omp parallel do default(shared) private(i, j, k, num, nb, ix) do num = 1,nvar3d do nb = 1,Atm_block%nblks do k=1,npz @@ -2383,9 +2496,9 @@ subroutine fv3gfs_diag_register(Diag, Time, Atm_block, Model, xlon, xlat, axes) allocate(buffer_phys_bl(isco:ieco,jsco:jeco,nrgst_bl)) allocate(buffer_phys_nb(isco:ieco,jsco:jeco,nrgst_nb)) allocate(buffer_phys_windvect(3,isco:ieco,jsco:jeco,nrgst_vctbl)) - buffer_phys_bl = 0. - buffer_phys_nb = 0. - buffer_phys_windvect = 0. + buffer_phys_bl = zero + buffer_phys_nb = zero + buffer_phys_windvect = zero if(mpp_pe() == mpp_root_pe()) print *,'in fv3gfs_diag_register, nrgst_bl=',nrgst_bl,' nrgst_nb=',nrgst_nb, & ' nrgst_vctbl=',nrgst_vctbl, 'isco=',isco,ieco,'jsco=',jsco,jeco,' num_axes_phys=', num_axes_phys @@ -2426,11 +2539,11 @@ subroutine fv3gfs_diag_output(time, diag, atm_block, nx, ny, levs, ntcw, ntoz, & logical :: used nblks = atm_block%nblks - rdt = 1.0d0/dt - rtime_int = 1.0d0/time_int - rtime_intfull = 1.0d0/time_intfull - rtime_radsw = 1.0d0/time_radsw - rtime_radlw = 1.0d0/time_radlw + rdt = one/dt + rtime_int = one/time_int + rtime_intfull = one/time_intfull + rtime_radsw = one/time_radsw + rtime_radlw = one/time_radlw isc = atm_block%isc jsc = atm_block%jsc @@ -2729,7 +2842,7 @@ subroutine store_data(id, work, Time, idx, intpl_method, fldname) enddo enddo endif - uwork = 0.0 + uwork = zero uwindname = '' uwork_set = .false. endif @@ -2830,7 +2943,7 @@ subroutine store_data3D(id, work, Time, idx, intpl_method, fldname) enddo deallocate (sinlon, coslon, sinlat, coslat) endif - uwork3d = 0. + uwork3d = zero uwindname = '' uwork_set = .false. endif From 5dbea25dbae55a318848f0989f24b9b2ddd31e48 Mon Sep 17 00:00:00 2001 From: ericaligo-NOAA <48365233+ericaligo-NOAA@users.noreply.github.com> Date: Thu, 20 Aug 2020 18:02:52 -0400 Subject: [PATCH 02/13] Diagnostic 3D instantaneous cloud fractions added (#154) * Diagnostic 3D instantaneous cloud fractions added. * Bug fix for reflectivity in restart files. * Update to GFS_restart.F90 to include if block to test for reflectivity flag. --- .gitmodules | 4 ++-- ccpp/physics | 2 +- gfsphysics/GFS_layer/GFS_diagnostics.F90 | 11 +++++++++++ gfsphysics/GFS_layer/GFS_restart.F90 | 7 +++++-- gfsphysics/GFS_layer/GFS_typedefs.F90 | 12 +++++++++++- gfsphysics/GFS_layer/GFS_typedefs.meta | 7 +++++++ 6 files changed, 37 insertions(+), 6 deletions(-) diff --git a/.gitmodules b/.gitmodules index d253f6966..789f67889 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,5 @@ branch = master [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NCAR/ccpp-physics - branch = master + url = https://github.com/NCAR/ccpp-physics.git + branch = master diff --git a/ccpp/physics b/ccpp/physics index 09c4ee333..8617587ed 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 09c4ee3335d7e1e1c5433f390db38658aac3525d +Subproject commit 8617587edb95aa097b7bbc2735990393bc6d9b90 diff --git a/gfsphysics/GFS_layer/GFS_diagnostics.F90 b/gfsphysics/GFS_layer/GFS_diagnostics.F90 index ed2e5d51a..1b6fabe96 100644 --- a/gfsphysics/GFS_layer/GFS_diagnostics.F90 +++ b/gfsphysics/GFS_layer/GFS_diagnostics.F90 @@ -1937,6 +1937,17 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%refl_10cm(:,:) enddo + idx = idx + 1 + ExtDiag(idx)%axes = 3 + ExtDiag(idx)%name = 'cldfra' + ExtDiag(idx)%desc = 'Instantaneous 3D Cloud Fraction' + ExtDiag(idx)%unit = 'frac' + ExtDiag(idx)%mod_name = 'gfs_phys' + allocate (ExtDiag(idx)%data(nblks)) + do nb = 1,nblks + ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%cldfra(:,:) + enddo + idx = idx + 1 ExtDiag(idx)%axes = 3 ExtDiag(idx)%name = 'cnvw' diff --git a/gfsphysics/GFS_layer/GFS_restart.F90 b/gfsphysics/GFS_layer/GFS_restart.F90 index 52b3d7b83..eada1fc3d 100644 --- a/gfsphysics/GFS_layer/GFS_restart.F90 +++ b/gfsphysics/GFS_layer/GFS_restart.F90 @@ -263,9 +263,12 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, & enddo endif #ifdef CCPP + if (Model%lrefres) then + num = Model%ntot3d+1 + else + num = Model%ntot3d + endif !--- RAP/HRRR-specific variables, 3D - num = Model%ntot3d - ! GF if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then num = num + 1 diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index c5c16ed4e..3c1252b1e 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -1551,7 +1551,9 @@ module GFS_typedefs #ifdef CCPP real (kind=kind_phys), pointer :: TRAIN (:,:) => null() !< accumulated stratiform T tendency (K s-1) #endif - +#ifdef CCPP + real (kind=kind_phys), pointer :: cldfra (:,:) => null() !< instantaneous 3D cloud fraction +#endif !--- MP quantities for 3D diagnositics real (kind=kind_phys), pointer :: refl_10cm(:,:) => null() !< instantaneous refl_10cm ! @@ -5613,6 +5615,10 @@ subroutine diag_create (Diag, IM, Model) end if #endif +#ifdef CCPP + allocate (Diag%cldfra (IM,Model%levs)) +#endif + allocate (Diag%ca_deep (IM)) allocate (Diag%ca_turb (IM)) allocate (Diag%ca_shal (IM)) @@ -5930,6 +5936,10 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) Diag%TRAIN = zero end if #endif +#ifdef CCPP + Diag%cldfra = zero +#endif + Diag%totprcpb = zero Diag%cnvprcpb = zero Diag%toticeb = zero diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 0c04b6baf..4c5d75267 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -6030,6 +6030,13 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys +[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 [ndust] standard_name = number_of_dust_bins_for_diagnostics long_name = number of dust bins for diagnostics From 0975bb669bb911d2eec9cd6cf5c3dd8a78108dcf Mon Sep 17 00:00:00 2001 From: Jun Wang <37633869+junwang-noaa@users.noreply.github.com> Date: Tue, 25 Aug 2020 08:33:42 -0400 Subject: [PATCH 03/13] Esmf810bs21 (#160) * add esmf810 VMEpoch change and iau restart timing change --- atmos_model.F90 | 7 +++++-- fv3_cap.F90 | 37 ++++++++++++++++++++++++++++--------- 2 files changed, 33 insertions(+), 11 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 9b2098c9c..900c9143e 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -688,8 +688,11 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) diag_time = Time - real_to_time_type(mod(int((first_kdt - 1)*dt_phys/3600.),6)*3600.0) endif if (Atmos%iau_offset > zero) then - diag_time = Atmos%Time_init - diag_time_fhzero = Atmos%Time + call get_time (Atmos%Time - Atmos%Time_init, sec) + if (sec < Atmos%iau_offset*3600) then + diag_time = Atmos%Time_init + diag_time_fhzero = Atmos%Time + endif endif !---- print version number to logfile ---- diff --git a/fv3_cap.F90 b/fv3_cap.F90 index d0d55b47a..0ff14e91f 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -247,7 +247,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) integer,dimension(:), allocatable :: petList, originPetList, targetPetList character(20) :: cwrtcomp character(160) :: msg - integer :: isrctermprocessing + integer :: isrcTermProcessing character(len=*),parameter :: subname='(fv3_cap:InitializeAdvertise)' integer nfmout, nfsout , nfmout_hf, nfsout_hf @@ -344,8 +344,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) label ='app_domain:',rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + CALL ESMF_ConfigGetAttribute(config=CF,value=isrcTermProcessing, default=0, & + label ='isrcTermProcessing:',rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if(mype == 0) print *,'af nems config,quilting=',quilting,'write_groups=', & - write_groups,wrttasks_per_group,'calendar=',trim(calendar),'calendar_type=',calendar_type + write_groups,wrttasks_per_group,'calendar=',trim(calendar),'calendar_type=',calendar_type, & + 'isrcTermProcessing=', isrcTermProcessing ! CALL ESMF_ConfigGetAttribute(config=CF,value=num_files, & label ='num_files:',rc=rc) @@ -733,11 +738,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! this is a Store() for the first wrtComp -> must do the Store() timewri = mpi_wtime() - isrctermprocessing = 1 call ESMF_FieldBundleRegridStore(fcstFB(j), wrtFB(j,i), & regridMethod=regridmethod, routehandle=routehandle(j,i), & unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, & - srcTermProcessing=isrctermprocessing, rc=rc) + srcTermProcessing=isrcTermProcessing, rc=rc) ! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (rc /= ESMF_SUCCESS) then @@ -799,6 +803,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) alarm_output_hf_ring = startTime + (nhf+1_ESMF_KIND_I4)*output_interval_hf if(iau_offset > 0) then alarm_output_hf_ring = startTime + IAU_offsetTI + if( currtime > alarm_output_hf_ring ) then + alarm_output_hf_ring = startTime + (nhf+1_ESMF_KIND_I4)*output_interval_hf + endif endif alarm_output_hf = ESMF_AlarmCreate(clock_fv3,name='ALARM_OUTPUT_HF', & ringTime =alarm_output_hf_ring, & @@ -819,6 +826,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) alarm_output_ring = startTime + (nrg+1_ESMF_KIND_I4) * output_interval if(iau_offset > 0) then alarm_output_ring = startTime + IAU_offsetTI + if( currtime > alarm_output_ring ) then + alarm_output_ring = startTime + (nrg+1_ESMF_KIND_I4) * output_interval + endif endif endif @@ -1120,6 +1130,10 @@ subroutine ModelAdvance(gcomp, rc) timerhi = mpi_wtime() ! if (mype == 0 .or. mype == lead_wrttask(1)) print *,' aft fcst run alarm is on, na=',na,'mype=',mype + + call ESMF_VMEpochEnter(epoch=ESMF_VMEpoch_Buffer, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + do i=1, FBCount ! ! get fcst fieldbundle @@ -1127,13 +1141,15 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_FieldBundleRegrid(fcstFB(i), wrtFB(i,n_group), & routehandle=routehandle(i, n_group), & termorderflag=(/ESMF_TERMORDER_SRCSEQ/), rc=rc) - timerh = mpi_wtime() if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! !end FBcount - enddo -! if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, & -! ' time=', timerh- timerhi + enddo + call ESMF_VMEpochExit(rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + timerh = mpi_wtime() + if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, & + ' time=', timerh- timerhi ! if(mype==0 .or. mype==lead_wrttask(1)) print *,'on wrt bf wrt run, na=',na call ESMF_LogWrite('Model Advance: before wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc) @@ -1410,17 +1426,20 @@ subroutine ModelAdvance_phase2(gcomp, rc) output: IF(lalarm .or. na==first_kdt ) then timerhi = mpi_wtime() + call ESMF_VMEpochEnter(epoch=ESMF_VMEpoch_Buffer, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return do i=1, FBCount ! ! get fcst fieldbundle ! call ESMF_FieldBundleRegrid(fcstFB(i), wrtFB(i,n_group), & routehandle=routehandle(i, n_group), rc=rc) - timerh = mpi_wtime() if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return ! !end FBcount enddo + call ESMF_VMEpochExit(rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, & ' time=', timerh- timerhi From 0b2d3ec4ad172d718abdb05493e9fe6e5e9c272b Mon Sep 17 00:00:00 2001 From: ClaraDraper-NOAA <33430543+ClaraDraper-NOAA@users.noreply.github.com> Date: Sun, 30 Aug 2020 18:36:37 -0600 Subject: [PATCH 04/13] Updated land perturbation scheme (#148) * update to pre-existing land perts scheme, ready for addition of the new scheme * updates to land perts scheme, so that namelist input and control_type variables are in generic (i.e., variable agnostic) arrays * minor bug fix GFS_typedefs.meta * Phil's ccpp changes * minor bug fix * Lndp updates, including moving around the calling structure. * lndp clean-up * lndp submodule clean-up * Updated submodules for merge. * Fixed typo in vegfrac name * deleted GFS_land_perts.F90 (moved to stochastic_physics) * Removing FV3 dependency from stochastic_physics, and into wrapper * Fix linker problem in gfsphysics/CMakeLists.txt by removing physics/physparam.f from IPD sources * edits to compile with gnumake * Revert change to .gitmodules for ccpp-physics and update submodule pointer for ccpp-physics Co-authored-by: Dom Heinzeller --- .gitmodules | 4 +- atmos_model.F90 | 7 +- ccpp/framework | 2 +- ccpp/physics | 2 +- gfsphysics/CMakeLists.txt | 1 - gfsphysics/GFS_layer/GFS_driver.F90 | 1 + gfsphysics/GFS_layer/GFS_physics_driver.F90 | 55 +++++------ gfsphysics/GFS_layer/GFS_radiation_driver.F90 | 21 ++-- gfsphysics/GFS_layer/GFS_typedefs.F90 | 55 +++++------ gfsphysics/GFS_layer/GFS_typedefs.meta | 81 ++++++---------- gfsphysics/physics/GFS_debug.F90 | 2 +- gfsphysics/physics/radiation_surface.f | 6 +- gfsphysics/physics/sfc_drv.f | 6 +- stochastic_physics/makefile | 2 +- .../stochastic_physics_wrapper.F90 | 95 +++++++++++++++---- 15 files changed, 189 insertions(+), 151 deletions(-) diff --git a/.gitmodules b/.gitmodules index 789f67889..d253f6966 100644 --- a/.gitmodules +++ b/.gitmodules @@ -8,5 +8,5 @@ branch = master [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NCAR/ccpp-physics.git - branch = master + url = https://github.com/NCAR/ccpp-physics + branch = master diff --git a/atmos_model.F90 b/atmos_model.F90 index 900c9143e..35b2c4ceb 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -297,7 +297,9 @@ subroutine update_atmos_radiation_physics (Atmos) #endif !--- call stochastic physics pattern generation / cellular automata - call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block) + call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) + if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') + !--- if coupled, assign coupled fields @@ -628,7 +630,8 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) #endif !--- Initialize stochastic physics pattern generation / cellular automata for first time step - call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block) + call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) + if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') Atmos%Diag => IPD_Diag diff --git a/ccpp/framework b/ccpp/framework index 209f1c92d..f5d4cd2bf 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 209f1c92d99b7d4cc63e0d41c652fcfd730bd9fa +Subproject commit f5d4cd2bf7752ebf1e4ed16dfdfae71dbfabfb76 diff --git a/ccpp/physics b/ccpp/physics index 8617587ed..4c17ff716 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 8617587edb95aa097b7bbc2735990393bc6d9b90 +Subproject commit 4c17ff716a92d8ac0261d6cc2365bbd7a752b74a diff --git a/gfsphysics/CMakeLists.txt b/gfsphysics/CMakeLists.txt index 34faf6f4c..2c5040588 100644 --- a/gfsphysics/CMakeLists.txt +++ b/gfsphysics/CMakeLists.txt @@ -17,7 +17,6 @@ endif() set(CCPP_SOURCES physics/mersenne_twister.f physics/namelist_soilveg.f - physics/physparam.f physics/set_soilveg.f physics/noahmp_tables.f90 diff --git a/gfsphysics/GFS_layer/GFS_driver.F90 b/gfsphysics/GFS_layer/GFS_driver.F90 index 4abde43d0..e32ec4c26 100644 --- a/gfsphysics/GFS_layer/GFS_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_driver.F90 @@ -633,6 +633,7 @@ subroutine GFS_time_vary_step (Model, Statein, Stateout, Sfcprop, Coupling, & if (mod(Model%kdt,Model%nscyc) == 1) THEN call gcycle (nblks, Model, Grid(:), Sfcprop(:), Cldprop(:)) endif + ! if not updating surface params through fcast, perturb params once at start of fcast endif !--- determine if diagnostics buckets need to be cleared diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90 index 02eb00e00..899955f03 100644 --- a/gfsphysics/GFS_layer/GFS_physics_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_physics_driver.F90 @@ -660,6 +660,7 @@ subroutine GFS_physics_driver & real :: pshltr,QCQ,rh02 real(kind=kind_phys), allocatable, dimension(:,:) :: den + real(kind=kind_phys) :: lndp_vgf !! Initialize local variables (for debugging purposes only, !! because the corresponding variables Interstitial(nt)%... !! are reset to zero every time). @@ -928,34 +929,28 @@ subroutine GFS_physics_driver & ! alb1d(i) = zero vegf1d(i) = zero enddo - if (Model%do_sfcperts) then - if (Model%pertz0(1) > zero) then - z01d(:) = Model%pertz0(1) * Coupling%sfc_wts(:,1) -! if (me == 0) print*,'Coupling%sfc_wts(:,1) min and max',minval(Coupling%sfc_wts(:,1)),maxval(Coupling%sfc_wts(:,1)) -! if (me == 0) print*,'z01d min and max ',minval(z01d),maxval(z01d) - endif - if (Model%pertzt(1) > zero) then - zt1d(:) = Model%pertzt(1) * Coupling%sfc_wts(:,2) - endif - if (Model%pertshc(1) > zero) then - bexp1d(:) = Model%pertshc(1) * Coupling%sfc_wts(:,3) - endif - if (Model%pertlai(1) > zero) then - xlai1d(:) = Model%pertlai(1) * Coupling%sfc_wts(:,4) - endif -! --- do the albedo percentile calculation in GFS_radiation_driver instead --- ! -! if (Model%pertalb(1) > zero) then -! do i=1,im -! call cdfnor(Coupling%sfc_wts(i,5),cdfz) -! alb1d(i) = cdfz -! enddo -! endif - if (Model%pertvegf(1) > zero) then - do i=1,im - call cdfnor(Coupling%sfc_wts(i,6),cdfz) - vegf1d(i) = cdfz - enddo - endif + lndp_vgf=-999. + + if (Model%lndp_type==1) then + do k =1,Model%n_var_lndp + select case(Model%lndp_var_list(k)) + case ('rz0') + z01d(:) = Model%lndp_prt_list(k)* Coupling%sfc_wts(:,k) + case ('rzt') + zt1d(:) = Model%lndp_prt_list(k)* Coupling%sfc_wts(:,k) + case ('shc') + bexp1d(:) = Model%lndp_prt_list(k) * Coupling%sfc_wts(:,k) + case ('lai') + xlai1d(:) = Model%lndp_prt_list(k)* Coupling%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(Coupling%sfc_wts(i,k),cdfz) + vegf1d(i) = cdfz + enddo + lndp_vgf = Model%lndp_prt_list(k) + end select + enddo endif !*## CCPP ## ! @@ -1856,6 +1851,7 @@ subroutine GFS_physics_driver & ! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr) !## CCPP ##* sfc_drv.f/lsm_noah_run + call sfc_drv & ! --- inputs: (im, lsoil, Statein%pgr, & @@ -1867,7 +1863,8 @@ subroutine GFS_physics_driver & Sfcprop%shdmin, Sfcprop%shdmax, Sfcprop%snoalb, & Radtend%sfalb, flag_iter, flag_guess, Model%lheatstrg, & Model%isot, Model%ivegsrc, & - bexp1d, xlai1d, vegf1d, Model%pertvegf, & + bexp1d, xlai1d, vegf1d,lndp_vgf, & + ! --- input/output: weasd3(:,1), snowd3(:,1), tsfc3(:,1), tprcp3(:,1), & Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & diff --git a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 index ebec30c4d..da5078f7b 100644 --- a/gfsphysics/GFS_layer/GFS_radiation_driver.F90 +++ b/gfsphysics/GFS_layer/GFS_radiation_driver.F90 @@ -1221,6 +1221,7 @@ subroutine GFS_radiation_driver & ! mg, sfc perts real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: alb1d + real(kind=kind_phys) :: lndp_alb real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtausw real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtaulw @@ -1846,14 +1847,18 @@ subroutine GFS_radiation_driver & ! --- scale random patterns for surface perturbations with ! perturbation size ! --- turn vegetation fraction pattern into percentile pattern - alb1d(:) = zero - if (Model%do_sfcperts) then - if (Model%pertalb(1) > zero) then - do i=1,im - call cdfnor(Coupling%sfc_wts(i,5),alb1d(i)) - enddo + alb1d(:) = 0. + lndp_alb = -999. + 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 !*## CCPP ## @@ -1870,7 +1875,7 @@ subroutine GFS_radiation_driver & 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. diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 3c1252b1e..4d3140d24 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -517,7 +517,6 @@ module GFS_typedefs real (kind=kind_phys), pointer :: skebu_wts (:,:) => null() ! real (kind=kind_phys), pointer :: skebv_wts (:,:) => null() ! real (kind=kind_phys), pointer :: sfc_wts (:,:) => null() ! mg, sfc-perts - integer :: nsfcpert=6 !< number of sfc perturbations !--- aerosol surface emissions for Thompson microphysics real (kind=kind_phys), pointer :: nwfa2d (:) => null() !< instantaneous water-friendly sfc aerosol source @@ -1045,14 +1044,14 @@ module GFS_typedefs logical :: do_shum logical :: do_skeb integer :: skeb_npass - logical :: do_sfcperts - integer :: nsfcpert=6 - real(kind=kind_phys) :: pertz0(5) ! mg, sfc-perts - real(kind=kind_phys) :: pertzt(5) ! mg, sfc-perts - real(kind=kind_phys) :: pertshc(5) ! mg, sfc-perts - real(kind=kind_phys) :: pertlai(5) ! mg, sfc-perts - real(kind=kind_phys) :: pertalb(5) ! mg, sfc-perts - real(kind=kind_phys) :: pertvegf(5) ! mg, sfc-perts + integer :: lndp_type + integer :: n_var_lndp + character(len=3) :: lndp_var_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def + real(kind=kind_phys) :: lndp_prt_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def + ! also previous code had dimension 5 for each pert, to allow + ! multiple patterns. It wasn't fully coded (and wouldn't have worked + ! with nlndp>1, so I just dropped it). If we want to code it properly, + ! we'd need to make this dim(6,5). !--- tracer handling character(len=32), pointer :: tracer_names(:) !< array of initialized tracers from dynamic core integer :: ntrac !< number of tracers @@ -1948,6 +1947,8 @@ module GFS_typedefs real (kind=kind_phys), pointer :: uustar_ocean(:) => null() !< real (kind=kind_phys), pointer :: vdftra(:,:,:) => null() !< real (kind=kind_phys), pointer :: vegf1d(:) => null() !< + real (kind=kind_phys) :: lndp_vgf !< + integer, pointer :: vegtype(:) => null() !< real (kind=kind_phys), pointer :: w_upi(:,:) => null() !< real (kind=kind_phys), pointer :: wcbmax(:) => null() !< @@ -2800,9 +2801,9 @@ subroutine coupling_create (Coupling, IM, Model) Coupling%skebv_wts = clear_val endif - !--- stochastic physics option - if (Model%do_sfcperts) then - allocate (Coupling%sfc_wts (IM,Model%nsfcpert)) + !--- stochastic land perturbation option + if (Model%lndp_type .NE. 0) then + allocate (Coupling%sfc_wts (IM,Model%n_var_lndp)) Coupling%sfc_wts = clear_val endif @@ -3314,15 +3315,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: use_zmtnblck = .false. logical :: do_shum = .false. logical :: do_skeb = .false. - integer :: skeb_npass = 11 - logical :: do_sfcperts = .false. ! mg, sfc-perts - integer :: nsfcpert = 6 ! mg, sfc-perts - real(kind=kind_phys) :: pertz0 = -999. - real(kind=kind_phys) :: pertzt = -999. - real(kind=kind_phys) :: pertshc = -999. - real(kind=kind_phys) :: pertlai = -999. - real(kind=kind_phys) :: pertalb = -999. - real(kind=kind_phys) :: pertvegf = -999. + integer :: skeb_npass = 11 + integer :: lndp_type = 0 + integer :: n_var_lndp = 0 !--- aerosol scavenging factors character(len=20) :: fscav_aero(20) = 'default' @@ -3399,7 +3394,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & do_deep, jcap, & cs_parm, flgmin, cgwf, ccwf, cdmbgwd, sup, ctei_rm, crtrh, & dlqf, rbcr, shoc_parm, psauras, prauras, wminras, & - do_sppt, do_shum, do_skeb, do_sfcperts, & + do_sppt, do_shum, do_skeb, lndp_type, n_var_lndp, & !--- Rayleigh friction prslrd0, ral_ts, ldiag_ugwp, do_ugwp, do_tofd, & ! --- Ferrier-Aligo @@ -4007,21 +4002,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%e0fac = e0fac !--- stochastic physics options - ! do_sppt, do_shum, do_skeb and do_sfcperts are namelist variables in group + ! do_sppt, do_shum, do_skeb and lndp_type are namelist variables in group ! physics that are parsed here and then compared in init_stochastic_physics ! to the stochastic physics namelist parametersto ensure consistency. Model%do_sppt = do_sppt Model%use_zmtnblck = use_zmtnblck Model%do_shum = do_shum Model%do_skeb = do_skeb - Model%do_sfcperts = do_sfcperts ! mg, sfc-perts - Model%nsfcpert = nsfcpert ! mg, sfc-perts - Model%pertz0 = pertz0 - Model%pertzt = pertzt - Model%pertshc = pertshc - Model%pertlai = pertlai - Model%pertalb = pertalb - Model%pertvegf = pertvegf + Model%lndp_type = lndp_type + Model%n_var_lndp = n_var_lndp !--- cellular automata options Model%nca = nca @@ -5075,7 +5064,8 @@ subroutine control_print(Model) print *, ' do_sppt : ', Model%do_sppt print *, ' do_shum : ', Model%do_shum print *, ' do_skeb : ', Model%do_skeb - print *, ' do_sfcperts : ', Model%do_sfcperts + print *, ' lndp_type : ', Model%lndp_type + print *, ' n_var_lndp : ', Model%n_var_lndp print *, ' ' print *, 'cellular automata' print *, ' nca : ', Model%nca @@ -7015,6 +7005,7 @@ subroutine interstitial_phys_reset (Interstitial, Model) Interstitial%uustar_ocean = huge Interstitial%vdftra = clear_val Interstitial%vegf1d = clear_val + Interstitial%lndp_vgf = clear_val Interstitial%vegtype = 0 Interstitial%wcbmax = clear_val Interstitial%weasd_ice = huge diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 4c5d75267..dab6a5c17 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -1900,7 +1900,7 @@ 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) + dimensions = (horizontal_dimension,number_of_land_surface_variables_perturbed) type = real kind = kind_phys [dqdti] @@ -3691,8 +3691,8 @@ type = real kind = kind_phys [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 @@ -3714,60 +3714,32 @@ units = flag dimensions = () type = logical -[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 -[nsfcpert] - standard_name = number_of_surface_perturbations - long_name = number of surface perturbations + type = integer +[n_var_lndp] + standard_name = number_of_land_surface_variables_perturbed + long_name = number of land surface variables perturbed units = count dimensions = () type = integer -[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 -[pertzt] - standard_name = magnitude_of_perturbation_of_heat_to_momentum_roughness_length_ratio - long_name = magnitude of perturbation of heat to momentum roughness length ratio - units = frac - dimensions = (5) - type = real - kind = kind_phys -[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) - type = real - kind = kind_phys -[pertlai] - standard_name = magnitude_of_perturbation_of_leaf_area_index - long_name = magnitude of perturbation of leaf area index - units = frac - dimensions = (5) - type = real - kind = kind_phys -[pertalb] - standard_name = magnitude_of_surface_albedo_perturbation - long_name = magnitude of surface albedo perturbation - units = frac - dimensions = (5) - type = real - kind = kind_phys -[pertvegf] - standard_name = magnitude_of_perturbation_of_vegetation_fraction - long_name = magnitude of perturbation of vegetation fraction - 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 +[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 [ntrac] standard_name = number_of_tracers long_name = number of tracers @@ -8591,6 +8563,13 @@ dimensions = (horizontal_dimension,vertical_dimension,number_of_vertical_diffusion_tracers) type = real kind = kind_phys +[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 [vegf1d] standard_name = perturbation_of_vegetation_fraction long_name = perturbation of vegetation fraction diff --git a/gfsphysics/physics/GFS_debug.F90 b/gfsphysics/physics/GFS_debug.F90 index 2887d6e64..e1953a9ff 100644 --- a/gfsphysics/physics/GFS_debug.F90 +++ b/gfsphysics/physics/GFS_debug.F90 @@ -468,7 +468,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling, call print_var(mpirank,omprank, blkno, 'Coupling%skebu_wts', Coupling%skebu_wts ) call print_var(mpirank,omprank, blkno, 'Coupling%skebv_wts', Coupling%skebv_wts ) end if - if (Model%do_sfcperts) then + if (Model%lndp_type .NE. 0) then call print_var(mpirank,omprank, blkno, 'Coupling%sfc_wts' , Coupling%sfc_wts ) end if if (Model%do_ca) then diff --git a/gfsphysics/physics/radiation_surface.f b/gfsphysics/physics/radiation_surface.f index 99f0ebc2f..9ae258a0c 100644 --- a/gfsphysics/physics/radiation_surface.f +++ b/gfsphysics/physics/radiation_surface.f @@ -382,7 +382,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) :: & @@ -620,12 +620,12 @@ subroutine setalb & ! sfc-perts, mgehne *** ! perturb all 4 kinds 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/gfsphysics/physics/sfc_drv.f b/gfsphysics/physics/sfc_drv.f index 84b4b84d5..80e081909 100644 --- a/gfsphysics/physics/sfc_drv.f +++ b/gfsphysics/physics/sfc_drv.f @@ -182,7 +182,7 @@ subroutine sfc_drv & ! --- input: integer, intent(in) :: im, km, isot, ivegsrc - real (kind=kind_phys), dimension(5), intent(in) :: pertvegf + real (kind=kind_phys), intent(in) :: pertvegf integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp @@ -383,10 +383,10 @@ subroutine sfc_drv & ! perturb vegetation fraction that goes into sflx, use the same ! perturbation strategy as for albedo (percentile matching) vegfp = vegfpert(i) ! sfc-perts, mgehne - if (pertvegf(1) > zero) then + if (pertvegf > zero) then ! compute beta distribution parameters for vegetation fraction mv = shdfac - sv = pertvegf(1)*mv*(1.-mv) + sv = pertvegf*mv*(one-mv) alphav = mv*mv*(one-mv)/(sv*sv)-mv betav = alphav*(one-mv)/mv ! compute beta distribution value corresponding diff --git a/stochastic_physics/makefile b/stochastic_physics/makefile index eb721c8c4..c841571a4 100644 --- a/stochastic_physics/makefile +++ b/stochastic_physics/makefile @@ -18,7 +18,7 @@ $(info $$ESMF_INC is [${ESMF_INC}]) LIBRARY = libstochastic_physics_wrapper.a -FFLAGS += -I$(FMS_DIR) -I ../../stochastic_physics -I../ccpp/physics -I../atmos_cubed_sphere +FFLAGS += -I$(FMS_DIR) -I ../../stochastic_physics -I../ccpp/physics -I../ccpp/build/physics -I../atmos_cubed_sphere SRCS_f = diff --git a/stochastic_physics/stochastic_physics_wrapper.F90 b/stochastic_physics/stochastic_physics_wrapper.F90 index 2fb8cafd1..d4803c639 100644 --- a/stochastic_physics/stochastic_physics_wrapper.F90 +++ b/stochastic_physics/stochastic_physics_wrapper.F90 @@ -13,6 +13,12 @@ module stochastic_physics_wrapper_mod real(kind=kind_phys), dimension(:,:,:), allocatable, save :: skebv_wts real(kind=kind_phys), dimension(:,:,:), allocatable, save :: sfc_wts + real(kind=kind_phys), dimension(:,:,:), allocatable, save :: smc + real(kind=kind_phys), dimension(:,:,:), allocatable, save :: stc + real(kind=kind_phys), dimension(:,:,:), allocatable, save :: slc + real(kind=kind_phys), dimension(:,:), allocatable, save :: vfrac + real(kind=kind_phys), dimension(:,:), allocatable, save :: stype + ! For cellular automata real(kind=kind_phys), dimension(:,:,:), allocatable, save :: ugrs real(kind=kind_phys), dimension(:,:,:), allocatable, save :: qgrs @@ -37,7 +43,7 @@ module stochastic_physics_wrapper_mod !------------------------------- ! CCPP step !------------------------------- - subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block) + subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr) #ifdef OPENMP use omp_lib @@ -49,47 +55,56 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block) use atmosphere_mod, only: Atm, mygrid use stochastic_physics, only: init_stochastic_physics, run_stochastic_physics - use stochastic_physics_sfc, only: run_stochastic_physics_sfc use cellular_automata_global_mod, only: cellular_automata_global use cellular_automata_sgs_mod, only: cellular_automata_sgs + use lndp_apply_perts_mod, only: lndp_apply_perts + use namelist_soilveg, only: maxsmc implicit none type(GFS_control_type), intent(inout) :: GFS_Control type(GFS_data_type), intent(inout) :: GFS_Data(:) type(block_control_type), intent(inout) :: Atm_block + integer, intent(out) :: ierr integer :: nthreads, nb + logical :: param_update_flag #ifdef OPENMP nthreads = omp_get_max_threads() #else nthreads = 1 #endif + ierr = 0 ! Initialize initalize_stochastic_physics: if (GFS_Control%kdt==0) then - if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. GFS_Control%do_sfcperts) then + if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type .GT. 0) ) then ! Initialize stochastic physics call init_stochastic_physics(GFS_Control%levs, GFS_Control%blksz, GFS_Control%dtp, & GFS_Control%input_nml_file, GFS_Control%fn_nml, GFS_Control%nlunit, GFS_Control%do_sppt, GFS_Control%do_shum, & - GFS_Control%do_skeb, GFS_Control%do_sfcperts, GFS_Control%use_zmtnblck, GFS_Control%skeb_npass, GFS_Control%nsfcpert, & - GFS_Control%pertz0, GFS_Control%pertzt, GFS_Control%pertshc, GFS_Control%pertlai, GFS_Control%pertalb, GFS_Control%pertvegf, & - GFS_Control%ak, GFS_Control%bk, nthreads, GFS_Control%master, GFS_Control%communicator) + GFS_Control%do_skeb, GFS_Control%lndp_type, GFS_Control%n_var_lndp, GFS_Control%use_zmtnblck, GFS_Control%skeb_npass, & + GFS_Control%lndp_var_list, GFS_Control%lndp_prt_list, & + GFS_Control%ak, GFS_Control%bk, nthreads, GFS_Control%master, GFS_Control%communicator, ierr) + if (ierr/=0) then + write(6,*) 'call to init_stochastic_physics failed' + return + endif end if - ! Get land surface perturbations here (move to "else" block below if wanting to update each time-step) - if (GFS_Control%do_sfcperts) then + if ( GFS_Control%lndp_type .EQ. 1 ) then ! this scheme sets perts once ! Copy blocked data into contiguous arrays; no need to copy sfc_wts in (intent out) allocate(xlat(1:Atm_block%nblks,maxval(GFS_Control%blksz))) allocate(xlon(1:Atm_block%nblks,maxval(GFS_Control%blksz))) - allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) + allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%n_var_lndp)) do nb=1,Atm_block%nblks xlat(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlat(:) xlon(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlon(:) end do - call run_stochastic_physics_sfc(GFS_Control%blksz, xlat=xlat, xlon=xlon, sfc_wts=sfc_wts) + call run_stochastic_physics(GFS_Control%levs, GFS_Control%kdt, GFS_Control%phour, GFS_Control%blksz, xlat=xlat, xlon=xlon, & + sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, sfc_wts=sfc_wts, & + nthreads=nthreads) ! Copy contiguous data back; no need to copy xlat/xlon, these are intent(in) - just deallocate do nb=1,Atm_block%nblks GFS_Data(nb)%Coupling%sfc_wts(:,:) = sfc_wts(nb,1:GFS_Control%blksz(nb),:) @@ -97,8 +112,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block) deallocate(xlat) deallocate(xlon) deallocate(sfc_wts) - end if - + end if ! Consistency check for cellular automata if(GFS_Control%do_ca)then ! DH* The current implementation of cellular_automata assumes that all blocksizes are the @@ -111,7 +125,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block) else initalize_stochastic_physics - if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb) then + if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type .EQ. 2) ) then ! Copy blocked data into contiguous arrays; no need to copy weights in (intent(out)) allocate(xlat(1:Atm_block%nblks,maxval(GFS_Control%blksz))) allocate(xlon(1:Atm_block%nblks,maxval(GFS_Control%blksz))) @@ -129,11 +143,14 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block) allocate(skebu_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) allocate(skebv_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs)) end if + if ( GFS_Control%lndp_type .EQ. 2 ) then ! this scheme updates through forecast + allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%n_var_lndp)) + end if + call run_stochastic_physics(GFS_Control%levs, GFS_Control%kdt, GFS_Control%phour, GFS_Control%blksz, xlat=xlat, xlon=xlon, & - sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, nthreads=nthreads) + sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, sfc_wts=sfc_wts, & + nthreads=nthreads) ! Copy contiguous data back; no need to copy xlat/xlon, these are intent(in) - just deallocate - deallocate(xlat) - deallocate(xlon) if (GFS_Control%do_sppt) then do nb=1,Atm_block%nblks GFS_Data(nb)%Coupling%sppt_wts(:,:) = sppt_wts(nb,1:GFS_Control%blksz(nb),:) @@ -154,6 +171,52 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block) deallocate(skebu_wts) deallocate(skebv_wts) end if + if (GFS_Control%lndp_type .EQ. 2) then ! save wts, and apply lndp scheme + do nb=1,Atm_block%nblks + GFS_Data(nb)%Coupling%sfc_wts(:,:) = sfc_wts(nb,1:GFS_Control%blksz(nb),:) + end do + + allocate(smc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) + allocate(slc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) + allocate(stc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil)) + allocate(stype(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + allocate(vfrac(1:Atm_block%nblks,maxval(GFS_Control%blksz))) + do nb=1,Atm_block%nblks + stype(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%stype(:) + smc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%smc(:,:) + slc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%slc(:,:) + stc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%stc(:,:) + vfrac(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%vfrac(:) + end do + + ! determine whether land paramaters have been over-written + if (mod(GFS_Control%kdt,GFS_Control%nscyc) == 1) then ! logic copied from GFS_driver + param_update_flag = .true. + else + param_update_flag = .false. + endif + call lndp_apply_perts( GFS_Control%blksz, GFS_Control%lsm, GFS_Control%lsoil, GFS_Control%dtf, & + GFS_Control%n_var_lndp, GFS_Control%lndp_var_list, GFS_Control%lndp_prt_list, & + sfc_wts, xlon, xlat, stype, maxsmc,param_update_flag, smc, slc,stc, vfrac, ierr) + if (ierr/=0) then + write(6,*) 'call to GFS_apply_lndp failed' + return + endif + deallocate(stype) + deallocate(sfc_wts) + do nb=1,Atm_block%nblks + GFS_Data(nb)%Sfcprop%smc(:,:) = smc(nb,1:GFS_Control%blksz(nb),:) + GFS_Data(nb)%Sfcprop%slc(:,:) = slc(nb,1:GFS_Control%blksz(nb),:) + GFS_Data(nb)%Sfcprop%stc(:,:) = stc(nb,1:GFS_Control%blksz(nb),:) + GFS_Data(nb)%Sfcprop%vfrac(:) = vfrac(nb,1:GFS_Control%blksz(nb)) + enddo + deallocate(smc) + deallocate(slc) + deallocate(stc) + deallocate(vfrac) + endif ! lndp block + deallocate(xlat) + deallocate(xlon) end if endif initalize_stochastic_physics From 53fadefbc9522eacbbfd4e88557e176c4e8abbb6 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 1 Sep 2020 06:59:02 -0600 Subject: [PATCH 05/13] Fix submodule pointer for ccpp-framework (#164) --- ccpp/framework | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/framework b/ccpp/framework index f5d4cd2bf..209f1c92d 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit f5d4cd2bf7752ebf1e4ed16dfdfae71dbfabfb76 +Subproject commit 209f1c92d99b7d4cc63e0d41c652fcfd730bd9fa From 223f09255ac19cae2d1c8ee64c37c8c30ef449d0 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 2 Sep 2020 13:13:37 -0600 Subject: [PATCH 06/13] Add dependencies to CCPP metadata (#153) This PR removes dependency information from the CCPP prebuild config. See NCAR/ccpp-framework#308 and NCAR/ccpp-framework#317 for details on the motivation for this change and the actual implementation. It also removes some legacy code used by the dynamic CCPP build in the past. This PR also contains the changes in #156, i.e. the completion of adding the active attribute to GFS_typedefs.F90. On top of this PR, the missing active attribute for phy_fctd is added. Additionally, gfortran-10 compiler flags are added to CCPP's CMakeLists.txt. --- ccpp/CMakeLists.txt | 7 +- ccpp/config/ccpp_prebuild_config.py | 190 ++---------- ccpp/framework | 2 +- ccpp/physics | 2 +- gfsphysics/CCPP_layer/CCPP_data.meta | 5 + gfsphysics/CCPP_layer/CCPP_typedefs.meta | 10 + gfsphysics/GFS_layer/GFS_typedefs.F90 | 3 + gfsphysics/GFS_layer/GFS_typedefs.meta | 374 ++++++++++++++++++++++- 8 files changed, 416 insertions(+), 177 deletions(-) diff --git a/ccpp/CMakeLists.txt b/ccpp/CMakeLists.txt index dd1c317e4..b1395b23b 100644 --- a/ccpp/CMakeLists.txt +++ b/ccpp/CMakeLists.txt @@ -82,11 +82,12 @@ set (CMAKE_Fortran_FLAGS_OPT "") if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU") set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fcray-pointer -ffree-line-length-none -fno-range-check") set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fbacktrace -cpp") + if(${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 10) + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fallow-argument-mismatch") + endif() if (${CMAKE_BUILD_TYPE} MATCHES "Debug") - set (CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Wall") - set (CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wall") set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans") - set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffpe-trap=invalid,zero,overflow -fcheck=bounds -fbacktrace -fno-range-check -Wall") + set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffpe-trap=invalid,zero,overflow -fcheck=bounds -fbacktrace -fno-range-check") elseif (${CMAKE_BUILD_TYPE} MATCHES "Bitforbit") set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}") endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config.py index 0cc2fb605..4d61fbbae 100755 --- a/ccpp/config/ccpp_prebuild_config.py +++ b/ccpp/config/ccpp_prebuild_config.py @@ -11,8 +11,10 @@ # Add all files with metadata tables on the host model side and in CCPP, # relative to basedir = top-level directory of host model. This includes -# kind and type definitions used in CCPP physics. +# kind and type definitions used in CCPP physics. Also add any internal +# dependencies of these files to the list. VARIABLE_DEFINITION_FILES = [ + # actual variable definition files 'FV3/ccpp/physics/physics/machine.F', 'FV3/ccpp/physics/physics/radsw_param.f', 'FV3/ccpp/physics/physics/radlw_param.f', @@ -85,128 +87,6 @@ }, } -# Add all physics scheme dependencies relative to basedir - note that the CCPP -# rules stipulate that dependencies are not shared between the schemes! -SCHEME_FILES_DEPENDENCIES = [ - 'FV3/ccpp/physics/physics/GFDL_parse_tracers.F90', - 'FV3/ccpp/physics/physics/aer_cloud.F', - 'FV3/ccpp/physics/physics/aerclm_def.F', - 'FV3/ccpp/physics/physics/aerinterp.F90', - 'FV3/ccpp/physics/physics/calpreciptype.f90', - 'FV3/ccpp/physics/physics/cldwat2m_micro.F', - 'FV3/ccpp/physics/physics/cldmacro.F', - 'FV3/ccpp/physics/physics/date_def.f', - 'FV3/ccpp/physics/physics/funcphys.f90', - 'FV3/ccpp/physics/physics/gcycle.F90', - 'FV3/ccpp/physics/physics/gfs_phy_tracer_config.F', - 'FV3/ccpp/physics/physics/gocart_tracer_config_stub.f', - 'FV3/ccpp/physics/physics/h2o_def.f', - 'FV3/ccpp/physics/physics/h2ointerp.f90', - 'FV3/ccpp/physics/physics/iccn_def.F', - 'FV3/ccpp/physics/physics/iccninterp.F90', - 'FV3/ccpp/physics/physics/iounitdef.f', - 'FV3/ccpp/physics/physics/machine.F', - 'FV3/ccpp/physics/physics/mersenne_twister.f', - 'FV3/ccpp/physics/physics/mfpbl.f', - 'FV3/ccpp/physics/physics/micro_mg_utils.F90', - 'FV3/ccpp/physics/physics/micro_mg2_0.F90', - 'FV3/ccpp/physics/physics/micro_mg3_0.F90', - 'FV3/ccpp/physics/physics/module_bfmicrophysics.f', - 'FV3/ccpp/physics/physics/multi_gases.F90', - 'FV3/ccpp/physics/physics/module_gfdl_cloud_microphys.F90', - 'FV3/ccpp/physics/physics/module_nst_model.f90', - 'FV3/ccpp/physics/physics/module_nst_parameters.f90', - 'FV3/ccpp/physics/physics/module_nst_water_prop.f90', - 'FV3/ccpp/physics/physics/module_mp_radar.F90', - 'FV3/ccpp/physics/physics/module_mp_thompson.F90', - 'FV3/ccpp/physics/physics/module_mp_thompson_make_number_concentrations.F90', - 'FV3/ccpp/physics/physics/module_MP_FER_HIRES.F90', - 'FV3/ccpp/physics/physics/module_bl_mynn.F90', - 'FV3/ccpp/physics/physics/module_sf_mynn.F90', - 'FV3/ccpp/physics/physics/module_SF_JSFC.F90', - 'FV3/ccpp/physics/physics/module_BL_MYJPBL.F90', - 'FV3/ccpp/physics/physics/module_sf_noahmp_glacier.f90', - 'FV3/ccpp/physics/physics/module_sf_noahmplsm.f90', - 'FV3/ccpp/physics/physics/cires_ugwp_module.F90', - 'FV3/ccpp/physics/physics/ugwp_driver_v0.F', - 'FV3/ccpp/physics/physics/cires_ugwp_triggers.F90', - 'FV3/ccpp/physics/physics/cires_ugwp_initialize.F90', - 'FV3/ccpp/physics/physics/cires_ugwp_solvers.F90', - 'FV3/ccpp/physics/physics/cires_ugwp_utils.F90', - 'FV3/ccpp/physics/physics/cires_orowam2017.f', - 'FV3/ccpp/physics/physics/cires_vert_lsatdis.F90', - 'FV3/ccpp/physics/physics/cires_vert_orodis.F90', - 'FV3/ccpp/physics/physics/cires_vert_wmsdis.F90', - 'FV3/ccpp/physics/physics/namelist_soilveg.f', - 'FV3/ccpp/physics/physics/mfpblt.f', - 'FV3/ccpp/physics/physics/mfpbltq.f', - 'FV3/ccpp/physics/physics/mfscu.f', - 'FV3/ccpp/physics/physics/mfscuq.f', - 'FV3/ccpp/physics/physics/noahmp_tables.f90', - 'FV3/ccpp/physics/physics/num_parthds.F', - 'FV3/ccpp/physics/physics/ozne_def.f', - 'FV3/ccpp/physics/physics/ozinterp.f90', - 'FV3/ccpp/physics/physics/physcons.F90', - 'FV3/ccpp/physics/physics/physparam.f', - 'FV3/ccpp/physics/physics/radcons.f90', - 'FV3/ccpp/physics/physics/radiation_aerosols.f', - 'FV3/ccpp/physics/physics/radiation_astronomy.f', - 'FV3/ccpp/physics/physics/radiation_clouds.f', - 'FV3/ccpp/physics/physics/radiation_gases.f', - 'FV3/ccpp/physics/physics/radiation_surface.f', - 'FV3/ccpp/physics/physics/radlw_datatb.f', - 'FV3/ccpp/physics/physics/radlw_param.f', - 'FV3/ccpp/physics/physics/radsw_datatb.f', - 'FV3/ccpp/physics/physics/radsw_param.f', - 'FV3/ccpp/physics/physics/samfaerosols.F', - 'FV3/ccpp/physics/physics/sfcsub.F', - 'FV3/ccpp/physics/physics/sflx.f', - 'FV3/ccpp/physics/physics/set_soilveg.f', - 'FV3/ccpp/physics/physics/flake.F90', - 'FV3/ccpp/physics/physics/surface_perturbation.F90', - 'FV3/ccpp/physics/physics/cu_gf_deep.F90', - 'FV3/ccpp/physics/physics/cu_gf_sh.F90', - 'FV3/ccpp/physics/physics/tridi.f', - 'FV3/ccpp/physics/physics/wv_saturation.F', - 'FV3/ccpp/physics/physics/module_sf_ruclsm.F90', - 'FV3/ccpp/physics/physics/namelist_soilveg_ruc.F90', - 'FV3/ccpp/physics/physics/set_soilveg_ruc.F90', - 'FV3/ccpp/physics/physics/module_soil_pre.F90', - # RRTMGP - 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_gas_optics.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_reorder.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_fluxes.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_util_array.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_optical_props.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_kind.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_lw.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_sw.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_config.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_source_functions.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/kernels/mo_optical_props_kernels.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_compute_bc.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_fluxes_byband.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_fluxes_byband_kernels.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_fluxes_bygpoint.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_heating_rates.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90', - 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90', - 'FV3/ccpp/physics/physics/rrtmg_lw_cloud_optics.F90' , - 'FV3/ccpp/physics/physics/rrtmg_sw_cloud_optics.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_aux.F90' , - # derived data type definitions - 'FV3/gfsphysics/GFS_layer/GFS_typedefs.F90', - 'FV3/gfsphysics/CCPP_layer/CCPP_typedefs.F90', - ] - # Add all physics scheme files relative to basedir SCHEME_FILES = [ # Relative path to source (from where ccpp_prebuild.py is called) : [ list of physics sets in which scheme may be called ]; @@ -300,25 +180,24 @@ # HAFSFER_HIRES 'FV3/ccpp/physics/physics/mp_fer_hires.F90', # RRTMGP - 'FV3/ccpp/physics/physics/rrtmgp_lw_gas_optics.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_lw_cloud_optics.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_sw_gas_optics.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_sw_cloud_optics.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_sw_aerosol_optics.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_lw_rte.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_sw_rte.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_lw_aerosol_optics.F90' , - 'FV3/ccpp/physics/physics/GFS_rrtmgp_setup.F90' , - 'FV3/ccpp/physics/physics/GFS_rrtmgp_pre.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_lw_pre.F90' , - 'FV3/ccpp/physics/physics/GFS_rrtmgp_sw_pre.F90' , - 'FV3/ccpp/physics/physics/GFS_rrtmgp_lw_post.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_lw_cloud_sampling.F90' , - 'FV3/ccpp/physics/physics/rrtmgp_sw_cloud_sampling.F90' , - 'FV3/ccpp/physics/physics/GFS_cloud_diagnostics.F90' , - 'FV3/ccpp/physics/physics/mo_cloud_sampling.F90' , - 'FV3/ccpp/physics/physics/GFS_rrtmgp_gfdlmp_pre.F90' , - 'FV3/ccpp/physics/physics/GFS_rrtmgp_zhaocarr_pre.F90' , + 'FV3/ccpp/physics/physics/rrtmgp_lw_gas_optics.F90', + 'FV3/ccpp/physics/physics/rrtmgp_lw_cloud_optics.F90', + 'FV3/ccpp/physics/physics/rrtmgp_sw_gas_optics.F90', + 'FV3/ccpp/physics/physics/rrtmgp_sw_cloud_optics.F90', + 'FV3/ccpp/physics/physics/rrtmgp_sw_aerosol_optics.F90', + 'FV3/ccpp/physics/physics/rrtmgp_lw_rte.F90', + 'FV3/ccpp/physics/physics/rrtmgp_sw_rte.F90', + 'FV3/ccpp/physics/physics/rrtmgp_lw_aerosol_optics.F90', + 'FV3/ccpp/physics/physics/GFS_rrtmgp_setup.F90', + 'FV3/ccpp/physics/physics/GFS_rrtmgp_pre.F90', + 'FV3/ccpp/physics/physics/rrtmgp_lw_pre.F90', + 'FV3/ccpp/physics/physics/GFS_rrtmgp_sw_pre.F90', + 'FV3/ccpp/physics/physics/GFS_rrtmgp_lw_post.F90', + 'FV3/ccpp/physics/physics/rrtmgp_lw_cloud_sampling.F90', + 'FV3/ccpp/physics/physics/rrtmgp_sw_cloud_sampling.F90', + 'FV3/ccpp/physics/physics/GFS_cloud_diagnostics.F90', + 'FV3/ccpp/physics/physics/GFS_rrtmgp_gfdlmp_pre.F90', + 'FV3/ccpp/physics/physics/GFS_rrtmgp_zhaocarr_pre.F90', 'FV3/ccpp/physics/physics/GFS_rrtmgp_sw_post.F90' ] @@ -336,13 +215,6 @@ SCHEMES_CMAKEFILE = '{build_dir}/ccpp/physics/CCPP_SCHEMES.cmake' SCHEMES_SOURCEFILE = '{build_dir}/ccpp/physics/CCPP_SCHEMES.sh' -# CCPP host cap in which to insert the ccpp_field_add statements; -# determines the directory to place ccpp_{modules,fields}.inc -TARGET_FILES = [ - 'FV3/atmos_cubed_sphere/driver/fvGFS/atmosphere.F90', - 'FV3/ccpp/driver/CCPP_Driver.F90', - ] - # Auto-generated makefile/cmakefile snippets that contain all caps CAPS_MAKEFILE = '{build_dir}/ccpp/physics/CCPP_CAPS.mk' CAPS_CMAKEFILE = '{build_dir}/ccpp/physics/CCPP_CAPS.cmake' @@ -453,12 +325,6 @@ #'subroutine_name_2' : [ 'var1', 'var3'], } -# Names of Fortran include files in the host model cap (do not change); -# both files will be written to the directory of each target file, only -# used by the dynamic builds -MODULE_INCLUDE_FILE = 'ccpp_modules_{set}.inc' -FIELDS_INCLUDE_FILE = 'ccpp_fields_{set}.inc' - # Directory where to write static API to STATIC_API_DIR = '{build_dir}/ccpp/physics' STATIC_API_SRCFILE = '{build_dir}/ccpp/physics/CCPP_STATIC_API.sh' @@ -471,17 +337,3 @@ # LaTeX document containing the provided vs requested CCPP variables LATEX_VARTABLE_FILE = '{build_dir}/ccpp/framework/doc/DevelopersGuide/CCPP_VARIABLES_FV3.tex' - - -############################################################################### -# Template code to generate include files # -############################################################################### - -# Name of the CCPP data structure in the host model cap; -# in the case of FV3, this is a 2-dimensional array with -# the number of blocks as the first and the number of -# OpenMP threads as the second dimension; nb is the loop -# index for the current block, nt for the current thread. -# Internally, the model uses an associate construct to -# reference cdata(nb,nt) with cdata (recommended). -CCPP_DATA_STRUCTURE = 'cdata' diff --git a/ccpp/framework b/ccpp/framework index 209f1c92d..836558713 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 209f1c92d99b7d4cc63e0d41c652fcfd730bd9fa +Subproject commit 8365587133b40b1faa2831ac395bf098c3dac4a6 diff --git a/ccpp/physics b/ccpp/physics index 4c17ff716..0808cc2e8 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 4c17ff716a92d8ac0261d6cc2365bbd7a752b74a +Subproject commit 0808cc2e8938ba66003b46746858143a9d75addb diff --git a/gfsphysics/CCPP_layer/CCPP_data.meta b/gfsphysics/CCPP_layer/CCPP_data.meta index e3f1249e5..70c783820 100644 --- a/gfsphysics/CCPP_layer/CCPP_data.meta +++ b/gfsphysics/CCPP_layer/CCPP_data.meta @@ -1,3 +1,8 @@ +[ccpp-table-properties] + name = CCPP_data + type = module + dependencies = ../../ccpp/framework/src/ccpp_types.F90,CCPP_typedefs.F90,../GFS_layer/GFS_typedefs.F90 + [ccpp-arg-table] name = CCPP_data type = module diff --git a/gfsphysics/CCPP_layer/CCPP_typedefs.meta b/gfsphysics/CCPP_layer/CCPP_typedefs.meta index d38fb8631..868dccebd 100644 --- a/gfsphysics/CCPP_layer/CCPP_typedefs.meta +++ b/gfsphysics/CCPP_layer/CCPP_typedefs.meta @@ -1,3 +1,8 @@ +[ccpp-table-properties] + name = CCPP_interstitial_type + type = ddt + dependencies = + [ccpp-arg-table] name = CCPP_interstitial_type type = ddt @@ -334,6 +339,11 @@ type = integer ######################################################################## +[ccpp-table-properties] + name = CCPP_typedefs + type = module + dependencies = ../../ccpp/physics/physics/machine.F + [ccpp-arg-table] name = CCPP_typedefs type = module diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 4d3140d24..429170059 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -7101,6 +7101,9 @@ subroutine interstitial_phys_reset (Interstitial, Model) ! end subroutine interstitial_phys_reset + ! DH* 20200901: this routine is no longer used by CCPP's GFS_debug.F90. When new variables are + ! added to the GFS_interstitial_type, it is best to add the variable to both interstitial_print + ! below and to GFS_interstitialtoscreen in ccpp/physics/physics/GFS_debug.F90 subroutine interstitial_print(Interstitial, Model, mpirank, omprank, blkno) ! implicit none diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index dab6a5c17..84ba83e86 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -1,8 +1,8 @@ -[ccpp-arg-table] - name = GFS_init_type +[ccpp-table-properties] + name = GFS_statein_type type = ddt + dependencies = -######################################################################## [ccpp-arg-table] name = GFS_statein_type type = ddt @@ -263,6 +263,11 @@ kind = kind_phys ######################################################################## +[ccpp-table-properties] + name = GFS_stateout_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_stateout_type type = ddt @@ -439,6 +444,11 @@ kind = kind_phys ######################################################################## +[ccpp-table-properties] + name = GFS_sfcprop_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_sfcprop_type type = ddt @@ -680,6 +690,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) [hice] standard_name = sea_ice_thickness long_name = sea ice thickness @@ -785,6 +796,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [z_c] standard_name = sub_layer_cooling_thickness long_name = sub-layer cooling thickness @@ -792,6 +804,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [c_0] standard_name = coefficient_c_0 long_name = coefficient 1 to calculate d(Tz)/d(Ts) @@ -799,6 +812,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [c_d] standard_name = coefficient_c_d long_name = coefficient 2 to calculate d(Tz)/d(Ts) @@ -806,6 +820,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [w_0] standard_name = coefficient_w_0 long_name = coefficient 3 to calculate d(Tz)/d(Ts) @@ -813,6 +828,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [w_d] standard_name = coefficient_w_d long_name = coefficient 4 to calculate d(Tz)/d(Ts) @@ -820,6 +836,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [xt] standard_name = diurnal_thermocline_layer_heat_content long_name = heat content in diurnal thermocline layer @@ -827,6 +844,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [xs] standard_name = sea_water_salinity long_name = salinity content in diurnal thermocline layer @@ -834,6 +852,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [xu] standard_name = diurnal_thermocline_layer_x_current long_name = u-current content in diurnal thermocline layer @@ -841,6 +860,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [xv] standard_name = diurnal_thermocline_layer_y_current long_name = v-current content in diurnal thermocline layer @@ -848,6 +868,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [xz] standard_name = diurnal_thermocline_layer_thickness long_name = diurnal thermocline layer thickness @@ -855,6 +876,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [zm] standard_name = ocean_mixed_layer_thickness long_name = mixed layer thickness @@ -862,6 +884,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [xtts] standard_name = sensitivity_of_dtl_heat_content_to_surface_temperature long_name = d(xt)/d(ts) @@ -869,6 +892,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [xzts] standard_name = sensitivity_of_dtl_thickness_to_surface_temperature long_name = d(xz)/d(ts) @@ -876,6 +900,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [d_conv] standard_name = free_convection_layer_thickness long_name = thickness of free convection layer (FCL) @@ -883,6 +908,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [ifd] standard_name = index_of_dtlm_start long_name = index to start dtlm run or not @@ -890,6 +916,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [dt_cool] standard_name = sub_layer_cooling_amount long_name = sub-layer cooling amount @@ -897,6 +924,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [qrain] standard_name = sensible_heat_flux_due_to_rainfall long_name = sensible heat flux due to rainfall @@ -904,6 +932,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_nsstm_run > 0) [snowxy] standard_name = number_of_snow_layers long_name = number of snow layers @@ -911,6 +940,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [tvxy] standard_name = vegetation_temperature long_name = vegetation temperature @@ -918,6 +948,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [tgxy] standard_name = ground_temperature_for_noahmp long_name = ground temperature for noahmp @@ -925,6 +956,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [canicexy] standard_name = canopy_intercepted_ice_mass long_name = canopy intercepted ice mass @@ -932,6 +964,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [canliqxy] standard_name = canopy_intercepted_liquid_water long_name = canopy intercepted liquid water @@ -939,6 +972,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [eahxy] standard_name = canopy_air_vapor_pressure long_name = canopy air vapor pressure @@ -946,6 +980,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [tahxy] standard_name = canopy_air_temperature long_name = canopy air temperature @@ -953,6 +988,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [cmxy] standard_name = surface_drag_coefficient_for_momentum_for_noahmp long_name = surface drag coefficient for momentum for noahmp @@ -960,6 +996,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [chxy] standard_name = surface_drag_coefficient_for_heat_and_moisture_for_noahmp long_name = surface exchange coeff heat & moisture for noahmp @@ -967,6 +1004,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [fwetxy] standard_name = area_fraction_of_wet_canopy long_name = area fraction of canopy that is wetted/snowed @@ -974,6 +1012,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [sneqvoxy] standard_name = snow_mass_at_previous_time_step long_name = snow mass at previous time step @@ -981,6 +1020,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [alboldxy] standard_name = snow_albedo_at_previous_time_step long_name = snow albedo at previous time step @@ -988,6 +1028,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [qsnowxy] standard_name = snow_precipitation_rate_at_surface long_name = snow precipitation rate at surface @@ -995,6 +1036,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [wslakexy] standard_name = lake_water_storage long_name = lake water storage @@ -1002,6 +1044,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [zwtxy] standard_name = water_table_depth long_name = water table depth @@ -1009,6 +1052,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [waxy] standard_name = water_storage_in_aquifer long_name = water storage in aquifer @@ -1016,6 +1060,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [wtxy] standard_name = water_storage_in_aquifer_and_saturated_soil long_name = water storage in aquifer and saturated soil @@ -1023,6 +1068,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [tsnoxy] standard_name = snow_temperature long_name = snow_temperature @@ -1030,6 +1076,7 @@ dimensions = (horizontal_dimension, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [zsnsoxy] standard_name = layer_bottom_depth_from_snow_surface long_name = depth from the top of the snow surface at the bottom of the layer @@ -1037,6 +1084,7 @@ dimensions = (horizontal_dimension, lower_bound_of_snow_vertical_dimension_for_land_surface_model:soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [snicexy] standard_name = snow_layer_ice long_name = snow layer ice @@ -1044,6 +1092,7 @@ dimensions = (horizontal_dimension, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [snliqxy] standard_name = snow_layer_liquid_water long_name = snow layer liquid water @@ -1051,6 +1100,7 @@ dimensions = (horizontal_dimension, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [lfmassxy] standard_name = leaf_mass long_name = leaf mass @@ -1058,6 +1108,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [rtmassxy] standard_name = fine_root_mass long_name = fine root mass @@ -1065,6 +1116,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [stmassxy] standard_name = stem_mass long_name = stem mass @@ -1072,6 +1124,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [woodxy] standard_name = wood_mass long_name = wood mass including woody roots @@ -1079,6 +1132,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [stblcpxy] standard_name = slow_soil_pool_mass_content_of_carbon long_name = stable carbon in deep soil @@ -1086,6 +1140,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [fastcpxy] standard_name = fast_soil_pool_mass_content_of_carbon long_name = short-lived carbon in shallow soil @@ -1093,6 +1148,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [xlaixy] standard_name = leaf_area_index long_name = leaf area index @@ -1100,6 +1156,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme .or. (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .and. flag_for_reading_leaf_area_index_from_input)) [xsaixy] standard_name = stem_area_index long_name = stem area index @@ -1107,6 +1164,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [taussxy] standard_name = nondimensional_snow_age long_name = non-dimensional snow age @@ -1114,6 +1172,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [smoiseq] standard_name = equilibrium_soil_water_content long_name = equilibrium soil water content @@ -1121,6 +1180,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [smcwtdxy] standard_name = soil_water_content_between_soil_bottom_and_water_table long_name = soil water content between the bottom of the soil and the water table @@ -1128,6 +1188,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [deeprechxy] standard_name = water_table_recharge_when_deep long_name = recharge to or from the water table when deep @@ -1135,6 +1196,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [rechxy] standard_name = water_table_recharge_when_shallow long_name = recharge to or from the water table when shallow @@ -1142,6 +1204,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [wetness] standard_name = normalized_soil_wetness_for_land_surface_model long_name = normalized soil wetness for lsm @@ -1149,6 +1212,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [sh2o] standard_name = volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model long_name = volume fraction of unfrozen soil moisture for lsm @@ -1156,6 +1220,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [keepsmfr] standard_name = volume_fraction_of_frozen_soil_moisture_for_land_surface_model long_name = volume fraction of frozen soil moisture for lsm @@ -1163,6 +1228,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [smois] standard_name = volume_fraction_of_soil_moisture_for_land_surface_model long_name = volumetric fraction of soil moisture for lsm @@ -1170,6 +1236,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [tslb] standard_name = soil_temperature_for_land_surface_model long_name = soil temperature for land surface model @@ -1177,6 +1244,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [zs] standard_name = depth_of_soil_levels_for_land_surface_model long_name = depth of soil levels for land surface model @@ -1184,6 +1252,7 @@ dimensions = (soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [clw_surf] standard_name = cloud_condensed_water_mixing_ratio_at_surface long_name = moist cloud water mixing ratio at surface @@ -1191,6 +1260,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [qwv_surf] standard_name = water_vapor_mixing_ratio_at_surface long_name = water vapor mixing ratio at surface @@ -1198,6 +1268,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [cndm_surf] standard_name = surface_condensation_mass long_name = surface condensation mass @@ -1205,6 +1276,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [flag_frsoil] standard_name = flag_for_frozen_soil_physics long_name = flag for frozen soil physics (RUC) @@ -1212,6 +1284,7 @@ dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [rhofr] standard_name = density_of_frozen_precipitation long_name = density of frozen precipitation @@ -1219,6 +1292,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [tsnow] standard_name = snow_temperature_bottom_first_layer long_name = snow temperature at the bottom of the first snow layer @@ -1226,6 +1300,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [snowfallac] standard_name = total_accumulated_snowfall long_name = run-total snow accumulation on the ground @@ -1233,6 +1308,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [acsnow] standard_name = accumulated_water_equivalent_of_frozen_precip long_name = snow water equivalent of run-total frozen precip @@ -1240,6 +1316,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [ustm] standard_name = surface_friction_velocity_drag long_name = friction velocity isolated for momentum only @@ -1247,6 +1324,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [zol] standard_name = surface_stability_parameter long_name = monin obukhov surface stability parameter @@ -1254,6 +1332,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [mol] standard_name = theta_star long_name = temperature flux divided by ustar (temperature scale) @@ -1261,6 +1340,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [rmol] standard_name = reciprocal_of_obukhov_length long_name = one over obukhov length @@ -1268,6 +1348,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [flhc] standard_name = surface_exchange_coefficient_for_heat long_name = surface exchange coefficient for heat @@ -1275,6 +1356,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [flqc] standard_name = surface_exchange_coefficient_for_moisture long_name = surface exchange coefficient for moisture @@ -1282,6 +1364,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [chs2] standard_name = surface_exchange_coefficient_for_heat_at_2m long_name = exchange coefficient for heat at 2 meters @@ -1289,6 +1372,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [cqs2] standard_name = surface_exchange_coefficient_for_moisture_at_2m long_name = exchange coefficient for moisture at 2 meters @@ -1296,6 +1380,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [lh] standard_name = surface_latent_heat long_name = latent heating at the surface (pos = up) @@ -1303,6 +1388,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnsfclay) [evap] standard_name = kinematic_surface_upward_latent_heat_flux long_name = kinematic surface upward latent heat flux @@ -1331,6 +1417,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [rainncprv] standard_name = lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep long_name = explicit rainfall from previous timestep @@ -1338,6 +1425,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [iceprv] standard_name = lwe_thickness_of_ice_amount_from_previous_timestep long_name = ice amount from previous timestep @@ -1345,6 +1433,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [snowprv] standard_name = lwe_thickness_of_snow_amount_from_previous_timestep long_name = snow amount from previous timestep @@ -1352,6 +1441,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [graupelprv] standard_name = lwe_thickness_of_graupel_amount_from_previous_timestep long_name = graupel amount from previous timestep @@ -1359,6 +1449,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [draincprv] standard_name = convective_precipitation_rate_from_previous_timestep long_name = convective precipitation rate from previous timestep @@ -1366,6 +1457,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [drainncprv] standard_name = explicit_rainfall_rate_from_previous_timestep long_name = explicit rainfall rate previous timestep @@ -1373,6 +1465,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [diceprv] standard_name = ice_precipitation_rate_from_previous_timestep long_name = ice precipitation rate from previous timestep @@ -1380,6 +1473,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [dsnowprv] standard_name = snow_precipitation_rate_from_previous_timestep long_name = snow precipitation rate from previous timestep @@ -1387,6 +1481,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [dgraupelprv] standard_name = graupel_precipitation_rate_from_previous_timestep long_name = graupel precipitation rate from previous timestep @@ -1394,6 +1489,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [alvsf] standard_name = mean_vis_albedo_with_strong_cosz_dependency long_name = mean vis albedo with strong cosz dependency @@ -1424,6 +1520,11 @@ kind = kind_phys ######################################################################## +[ccpp-table-properties] + name = GFS_coupling_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_coupling_type type = ddt @@ -1511,6 +1612,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling .or. flag_for_stochastic_physics_perturbations .or. flag_for_chemistry_coupling .or. flag_for_global_cellular_automata) [rainc_cpl] standard_name = lwe_thickness_of_convective_precipitation_amount_for_coupling long_name = total convective precipitation @@ -1525,6 +1627,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling .or. flag_for_stochastic_physics_perturbations .or. flag_for_chemistry_coupling .or. flag_for_global_cellular_automata) [dusfc_cpl] standard_name = cumulative_surface_x_momentum_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc x momentum flux multiplied by timestep @@ -1532,6 +1635,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dvsfc_cpl] standard_name = cumulative_surface_y_momentum_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc y momentum flux multiplied by timestep @@ -1539,6 +1643,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dtsfc_cpl] standard_name = cumulative_surface_upward_sensible_heat_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc sensible heat flux multiplied by timestep @@ -1546,6 +1651,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dqsfc_cpl] standard_name = cumulative_surface_upward_latent_heat_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc latent heat flux multiplied by timestep @@ -1553,6 +1659,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dlwsfc_cpl] standard_name = cumulative_surface_downwelling_longwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc downward lw flux mulitplied by timestep @@ -1560,6 +1667,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dswsfc_cpl] standard_name = cumulative_surface_downwelling_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc downward sw flux multiplied by timestep @@ -1567,6 +1675,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dnirbm_cpl] standard_name = cumulative_surface_downwelling_direct_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc nir beam downward sw flux multiplied by timestep @@ -1574,6 +1683,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dnirdf_cpl] standard_name = cumulative_surface_downwelling_diffuse_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc nir diff downward sw flux multiplied by timestep @@ -1581,6 +1691,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dvisbm_cpl] standard_name = cumulative_surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc uv+vis beam dnwd sw flux multiplied by timestep @@ -1588,6 +1699,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dvisdf_cpl] standard_name = cumulative_surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative sfc uv+vis diff dnwd sw flux multiplied by timestep @@ -1595,6 +1707,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nlwsfc_cpl] standard_name = cumulative_surface_net_downward_longwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative net downward lw flux multiplied by timestep @@ -1602,6 +1715,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nswsfc_cpl] standard_name = cumulative_surface_net_downward_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative net downward sw flux multiplied by timestep @@ -1609,6 +1723,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nnirbm_cpl] standard_name = cumulative_surface_net_downward_direct_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative net nir beam downward sw flux multiplied by timestep @@ -1616,6 +1731,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nnirdf_cpl] standard_name = cumulative_surface_net_downward_diffuse_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative net nir diff downward sw flux multiplied by timestep @@ -1623,6 +1739,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nvisbm_cpl] standard_name = cumulative_surface_net_downward_direct_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative net uv+vis beam downward sw rad flux multiplied by timestep @@ -1630,6 +1747,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nvisdf_cpl] standard_name = cumulative_surface_net_downward_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep long_name = cumulative net uv+vis diff downward sw rad flux multiplied by timestep @@ -1637,6 +1755,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dusfci_cpl] standard_name = instantaneous_surface_x_momentum_flux_for_coupling long_name = instantaneous sfc x momentum flux @@ -1644,6 +1763,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dvsfci_cpl] standard_name = instantaneous_surface_y_momentum_flux_for_coupling long_name = instantaneous sfc y momentum flux @@ -1651,6 +1771,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dtsfci_cpl] standard_name = instantaneous_surface_upward_sensible_heat_flux_for_coupling long_name = instantaneous sfc sensible heat flux @@ -1658,6 +1779,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dqsfci_cpl] standard_name = instantaneous_surface_upward_latent_heat_flux_for_coupling long_name = instantaneous sfc latent heat flux @@ -1665,6 +1787,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dlwsfci_cpl] standard_name = instantaneous_surface_downwelling_longwave_flux_for_coupling long_name = instantaneous sfc downward lw flux @@ -1672,6 +1795,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dswsfci_cpl] standard_name = instantaneous_surface_downwelling_shortwave_flux_for_coupling long_name = instantaneous sfc downward sw flux @@ -1679,6 +1803,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dnirbmi_cpl] standard_name = instantaneous_surface_downwelling_direct_near_infrared_shortwave_flux_for_coupling long_name = instantaneous sfc nir beam downward sw flux @@ -1686,6 +1811,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dnirdfi_cpl] standard_name = instantaneous_surface_downwelling_diffuse_near_infrared_shortwave_flux_for_coupling long_name = instantaneous sfc nir diff downward sw flux @@ -1693,6 +1819,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dvisbmi_cpl] standard_name = instantaneous_surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_for_coupling long_name = instantaneous sfc uv+vis beam downward sw flux @@ -1700,6 +1827,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dvisdfi_cpl] standard_name = instantaneous_surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling long_name = instantaneous sfc uv+vis diff downward sw flux @@ -1707,6 +1835,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nlwsfci_cpl] standard_name = instantaneous_surface_net_downward_longwave_flux_for_coupling long_name = instantaneous net sfc downward lw flux @@ -1714,6 +1843,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nswsfci_cpl] standard_name = instantaneous_surface_net_downward_shortwave_flux_for_coupling long_name = instantaneous net sfc downward sw flux @@ -1721,6 +1851,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nnirbmi_cpl] standard_name = instantaneous_surface_net_downward_direct_near_infrared_shortwave_flux_for_coupling long_name = instantaneous net nir beam sfc downward sw flux @@ -1728,6 +1859,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nnirdfi_cpl] standard_name = instantaneous_surface_net_downward_diffuse_near_infrared_shortwave_flux_for_coupling long_name = instantaneous net nir diff sfc downward sw flux @@ -1735,6 +1867,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nvisbmi_cpl] standard_name = instantaneous_surface_net_downward_direct_ultraviolet_and_visible_shortwave_flux_for_coupling long_name = instantaneous net uv+vis beam downward sw flux @@ -1742,6 +1875,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [nvisdfi_cpl] standard_name = instantaneous_surface_net_downward_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling long_name = instantaneous net uv+vis diff downward sw flux @@ -1749,6 +1883,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [t2mi_cpl] standard_name = instantaneous_temperature_at_2m_for_coupling long_name = instantaneous T2m @@ -1756,6 +1891,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [q2mi_cpl] standard_name = instantaneous_specific_humidity_at_2m_for_coupling long_name = instantaneous Q2m @@ -1763,6 +1899,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [u10mi_cpl] standard_name = instantaneous_x_wind_at_10m_for_coupling long_name = instantaneous U10m @@ -1770,6 +1907,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling .or. flag_for_wave_coupling) [v10mi_cpl] standard_name = instantaneous_y_wind_at_10m_for_coupling long_name = instantaneous V10m @@ -1777,6 +1915,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling .or. flag_for_wave_coupling) [tsfci_cpl] standard_name = instantaneous_surface_skin_temperature_for_coupling long_name = instantaneous sfc temperature @@ -1784,6 +1923,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [psurfi_cpl] standard_name = instantaneous_surface_air_pressure_for_coupling long_name = instantaneous sfc pressure @@ -1791,6 +1931,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [ulwsfcin_cpl] standard_name = surface_upwelling_longwave_flux_for_coupling long_name = surface upwelling LW flux for coupling @@ -1798,6 +1939,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dusfcin_cpl] standard_name = surface_x_momentum_flux_for_coupling long_name = sfc x momentum flux for coupling @@ -1805,6 +1947,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dvsfcin_cpl] standard_name = surface_y_momentum_flux_for_coupling long_name = sfc y momentum flux for coupling @@ -1812,6 +1955,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dtsfcin_cpl] standard_name = surface_upward_sensible_heat_flux_for_coupling long_name = sfc sensible heat flux input @@ -1819,6 +1963,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [dqsfcin_cpl] standard_name = surface_upward_latent_heat_flux_for_coupling long_name = sfc latent heat flux input for coupling @@ -1826,6 +1971,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [hsnoin_cpl] standard_name = surface_snow_thickness_for_coupling long_name = sfc snow depth in meters over sea ice for coupling @@ -1840,6 +1986,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling) [ca_deep] standard_name = fraction_of_cellular_automata_for_deep_convection long_name = fraction of cellular automata for deep convection @@ -1847,6 +1994,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_cellular_automata) [vfact_ca] standard_name = vertical_weight_for_ca long_name = vertical weight for ca @@ -1861,6 +2009,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_cellular_automata) [condition] standard_name = physics_field_for_coupling long_name = physics_field_for_coupling @@ -1875,6 +2024,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_stochastic_shum_option) [sppt_wts] standard_name = weights_for_stochastic_sppt_perturbation long_name = weights for stochastic sppt perturbation @@ -1882,6 +2032,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_stochastic_physics_perturbations .or. flag_for_global_cellular_automata) [skebu_wts] standard_name = weights_for_stochastic_skeb_perturbation_of_x_wind long_name = weights for stochastic skeb perturbation of x wind @@ -1889,6 +2040,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_stochastic_skeb_option) [skebv_wts] standard_name = weights_for_stochastic_skeb_perturbation_of_y_wind long_name = weights for stochastic skeb perturbation of y wind @@ -1896,6 +2048,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_stochastic_skeb_option) [sfc_wts] standard_name = weights_for_stochastic_surface_physics_perturbation long_name = weights for stochastic surface physics perturbation @@ -1903,6 +2056,7 @@ dimensions = (horizontal_dimension,number_of_land_surface_variables_perturbed) type = real kind = kind_phys + active = (index_for_stochastic_land_surface_perturbation_type .ne. 0) [dqdti] standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection long_name = instantaneous moisture tendency due to convection @@ -1910,6 +2064,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_chemistry_coupling) [nwfa2d] standard_name = tendency_of_water_friendly_aerosols_at_surface long_name = instantaneous water-friendly sfc aerosol source @@ -1933,6 +2088,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_chemistry_coupling) [dkt] standard_name = instantaneous_atmosphere_heat_diffusivity long_name = instantaneous atmospheric heat diffusivity @@ -1940,6 +2096,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_chemistry_coupling) [qci_conv] standard_name = convective_cloud_condesate_after_rainout long_name = convective cloud condesate after rainout @@ -1947,7 +2104,13 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) ######################################################################## +[ccpp-table-properties] + name = GFS_control_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_control_type type = ddt @@ -4329,6 +4492,11 @@ type = logical ######################################################################## +[ccpp-table-properties] + name = GFS_grid_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_grid_type type = ddt @@ -4381,8 +4549,20 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys +[xlon_d] + standard_name = longitude_in_degree + long_name = longitude in degree east + units = degree_east + dimensions = (horizontal_dimension) + type = real + kind = kind_phys ######################################################################## +[ccpp-table-properties] + name = GFS_tbd_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_tbd_type type = ddt @@ -4392,12 +4572,14 @@ units = none dimensions = (horizontal_dimension) type = integer + active = (flag_for_lw_clouds_without_sub_grid_approximation == 2 .or. flag_for_sw_clouds_without_sub_grid_approximation == 2) [icsdlw] standard_name = seed_random_numbers_lw long_name = random seeds for sub-column cloud generators lw units = none dimensions = (horizontal_dimension) type = integer + active = (flag_for_lw_clouds_without_sub_grid_approximation == 2 .or. flag_for_sw_clouds_without_sub_grid_approximation == 2) [ozpl] standard_name = ozone_forcing long_name = ozone forcing data @@ -4487,6 +4669,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_stochastic_physics_perturbations .or. flag_for_global_cellular_automata) [drain_cpl] standard_name = tendency_of_lwe_thickness_of_precipitation_amount_for_coupling long_name = change in rain_cpl (coupling_type) @@ -4494,6 +4677,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling .or. flag_for_chemistry_coupling) [dsnow_cpl] standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling long_name = change in show_cpl (coupling_type) @@ -4501,6 +4685,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_flux_coupling .or. flag_for_chemistry_coupling) [phy_fctd] standard_name = cloud_base_mass_flux long_name = cloud base mass flux for CS convection @@ -4508,6 +4693,7 @@ dimensions = (horizontal_dimension,number_of_cloud_types_CS) type = real kind = kind_phys + active = (number_of_cloud_types_CS > 0 .and. flag_for_Chikira_Sugiyama_deep_convection) [phy_f2d(:,1)] standard_name = surface_air_pressure_two_time_steps_back long_name = surface air pressure two time steps back @@ -4641,6 +4827,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme .or. flag_for_mass_flux_deep_convection_scheme == flag_for_ntiedtke_deep_convection_scheme) [forceq] standard_name = moisture_tendency_due_to_dynamics long_name = moisture tendency due to dynamics only @@ -4648,6 +4835,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme .or. flag_for_mass_flux_deep_convection_scheme == flag_for_ntiedtke_deep_convection_scheme) [prevst] standard_name = temperature_from_previous_timestep long_name = temperature from previous time step @@ -4655,6 +4843,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme .or. flag_for_mass_flux_deep_convection_scheme == flag_for_ntiedtke_deep_convection_scheme) [prevsq] standard_name = moisture_from_previous_timestep long_name = moisture from previous time step @@ -4662,12 +4851,14 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme .or. flag_for_mass_flux_deep_convection_scheme == flag_for_ntiedtke_deep_convection_scheme) [cactiv] standard_name = conv_activity_counter long_name = convective activity memory units = none dimensions = (horizontal_dimension) type = integer + active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme) [CLDFRA_BL] standard_name = subgrid_cloud_fraction_pbl long_name = subgrid cloud fraction from PBL scheme @@ -4675,6 +4866,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [QC_BL] standard_name = subgrid_cloud_water_mixing_ratio_pbl long_name = subgrid cloud water mixing ratio from PBL scheme @@ -4682,6 +4874,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [QI_BL] standard_name = subgrid_cloud_ice_mixing_ratio_pbl long_name = subgrid cloud ice mixing ratio from PBL scheme @@ -4689,6 +4882,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [el_pbl] standard_name = mixing_length long_name = mixing length in meters @@ -4696,6 +4890,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [Sh3D] standard_name = stability_function_for_heat long_name = stability function for heat @@ -4703,6 +4898,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [qke] standard_name = tke_at_mass_points long_name = 2 x tke at mass points @@ -4710,6 +4906,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [tsq] standard_name = t_prime_squared long_name = temperature fluctuation squared @@ -4717,6 +4914,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [qsq] standard_name = q_prime_squared long_name = water vapor fluctuation squared @@ -4724,6 +4922,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [cov] standard_name = t_prime_q_prime long_name = covariance of temperature and moisture @@ -4731,6 +4930,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [phy_myj_qsfc] standard_name = surface_specific_humidity_for_MYJ_schemes long_name = surface air saturation specific humidity for MYJ schemes @@ -4738,6 +4938,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_thz0] standard_name = potential_temperature_at_viscous_sublayer_top long_name = potential temperature at viscous sublayer top over water @@ -4745,6 +4946,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_qz0] standard_name = specific_humidity_at_viscous_sublayer_top long_name = specific humidity at_viscous sublayer top over water @@ -4752,6 +4954,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_uz0] standard_name = u_wind_component_at_viscous_sublayer_top long_name = u wind component at viscous sublayer top over water @@ -4759,6 +4962,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_vz0] standard_name = v_wind_component_at_viscous_sublayer_top long_name = v wind component at viscous sublayer top over water @@ -4766,6 +4970,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_z0base] standard_name = baseline_surface_roughness_length long_name = baseline surface roughness length for momentum in meter @@ -4773,6 +4978,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_akhs] standard_name = heat_exchange_coefficient_for_MYJ_schemes long_name = surface heat exchange_coefficient for MYJ schemes @@ -4780,6 +4986,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_akms] standard_name = momentum_exchange_coefficient_for_MYJ_schemes long_name = surface momentum exchange_coefficient for MYJ schemes @@ -4787,6 +4994,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_chkqlm] standard_name = surface_layer_evaporation_switch long_name = surface layer evaporation switch @@ -4794,6 +5002,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_elflx] standard_name = kinematic_surface_latent_heat_flux long_name = kinematic surface latent heat flux @@ -4801,6 +5010,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_a1u] standard_name = weight_for_momentum_at_viscous_sublayer_top long_name = weight for momentum at viscous layer top @@ -4808,6 +5018,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_a1t] standard_name = weight_for_potental_temperature_at_viscous_sublayer_top long_name = weight for potental temperature at viscous layer top @@ -4815,6 +5026,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) [phy_myj_a1q] standard_name = weight_for_specific_humidity_at_viscous_sublayer_top long_name = weight for Specfic Humidity at viscous layer top @@ -4822,8 +5034,14 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_myjsfc .or. do_myjpbl) ######################################################################## +[ccpp-table-properties] + name = GFS_cldprop_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_cldprop_type type = ddt @@ -4850,6 +5068,11 @@ kind = kind_phys ######################################################################## +[ccpp-table-properties] + name = GFS_radtend_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_radtend_type type = ddt @@ -4937,6 +5160,11 @@ kind = kind_phys ######################################################################## +[ccpp-table-properties] + name = GFS_diag_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_diag_type type = ddt @@ -5057,6 +5285,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dvsfc_ls] standard_name = integrated_y_momentum_flux_from_large_scale_gwd long_name = integrated y momentum flux from large scale gwd @@ -5064,6 +5293,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dusfc_bl] standard_name = integrated_x_momentum_flux_from_blocking_drag long_name = integrated x momentum flux from blocking drag @@ -5071,6 +5301,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dvsfc_bl] standard_name = integrated_y_momentum_flux_from_blocking_drag long_name = integrated y momentum flux from blocking drag @@ -5078,6 +5309,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dusfc_ss] standard_name = integrated_x_momentum_flux_from_small_scale_gwd long_name = integrated x momentum flux from small scale gwd @@ -5085,6 +5317,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dvsfc_ss] standard_name = integrated_y_momentum_flux_from_small_scale_gwd long_name = integrated y momentum flux from small scale gwd @@ -5092,6 +5325,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dusfc_fd] standard_name = integrated_x_momentum_flux_from_form_drag long_name = integrated x momentum flux from form drag @@ -5099,6 +5333,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dvsfc_fd] standard_name = integrated_y_momentum_flux_from_form_drag long_name = integrated y momentum flux from form drag @@ -5106,6 +5341,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dtaux2d_ls] standard_name = x_momentum_tendency_from_large_scale_gwd long_name = x momentum tendency from large scale gwd @@ -5113,6 +5349,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dtauy2d_ls] standard_name = y_momentum_tendency_from_large_scale_gwd long_name = y momentum tendency from large scale gwd @@ -5120,6 +5357,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dtaux2d_bl] standard_name = x_momentum_tendency_from_blocking_drag long_name = x momentum tendency from blocking drag @@ -5127,6 +5365,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dtauy2d_bl] standard_name = y_momentum_tendency_from_blocking_drag long_name = y momentum tendency from blocking drag @@ -5134,6 +5373,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dtaux2d_ss] standard_name = x_momentum_tendency_from_small_scale_gwd long_name = x momentum tendency from small scale gwd @@ -5141,12 +5381,14 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dtauy2d_ss] standard_name = y_momentum_tendency_from_small_scale_gwd long_name = y momentum tendency from small scale gwd units = m s-2 dimensions = (horizontal_dimension,vertical_dimension) type = real + active = (gwd_opt == 33) kind = kind_phys [dtaux2d_fd] standard_name = x_momentum_tendency_from_form_drag @@ -5155,6 +5397,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [dtauy2d_fd] standard_name = y_momentum_tendency_from_form_drag long_name = y momentum tendency from form drag @@ -5162,6 +5405,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (gwd_opt == 33) [totprcp] standard_name = accumulated_lwe_thickness_of_precipitation_amount long_name = accumulated total precipitation @@ -5225,6 +5469,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [gflux] standard_name = cumulative_surface_ground_heat_flux_multiplied_by_timestep long_name = cumulative groud conductive heat flux multiplied by timestep @@ -5589,6 +5834,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (.not. flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme) [tdomr] standard_name = dominant_rain_type long_name = dominant rain type @@ -5708,6 +5954,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_diagnostics_3D) [dv3dt(:,:,1)] standard_name = cumulative_change_in_y_wind_due_to_PBL long_name = cumulative change in y wind due to PBL @@ -5764,6 +6011,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_diagnostics_3D) [dt3dt(:,:,1)] standard_name = cumulative_change_in_temperature_due_to_longwave_radiation long_name = cumulative change in temperature due to longwave radiation @@ -5841,6 +6089,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_diagnostics_3D) [dq3dt(:,:,1)] standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL long_name = cumulative change in water vapor specific humidity due to PBL @@ -5932,6 +6181,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D) [refdmax] standard_name = maximum_reflectivity_at_1km_agl_over_maximum_hourly_time_interval long_name = maximum reflectivity at 1km agl over maximum hourly time interval @@ -6034,6 +6284,7 @@ dimensions = (horizonal_dimension,number_of_dust_bins_for_diagnostics) type = real kind = kind_phys + active = (number_of_dust_bins_for_diagnostics > 0) [ssem] standard_name = instantaneous_seasalt_emission_flux long_name = instantaneous sea salt emission flux @@ -6041,6 +6292,7 @@ dimensions = (horizonal_dimension,number_of_seasalt_bins_for_diagnostics) type = real kind = kind_phys + active = (number_of_seasalt_bins_for_diagnostics > 0) [sedim] standard_name = instantaneous_sedimentation long_name = instantaneous sedimentation @@ -6048,6 +6300,7 @@ dimensions = (horizonal_dimension,number_of_chemical_tracers_for_diagnostics) type = real kind = kind_phys + active = (number_of_chemical_tracers_for_diagnostics > 0) [drydep] standard_name = instantaneous_dry_deposition long_name = instantaneous dry deposition @@ -6055,6 +6308,7 @@ dimensions = (horizonal_dimension,number_of_chemical_tracers_for_diagnostics) type = real kind = kind_phys + active = (number_of_chemical_tracers_for_diagnostics > 0) [wetdpl] standard_name = instantaneous_large_scale_wet_deposition long_name = instantaneous large-scale wet deposition @@ -6062,6 +6316,7 @@ dimensions = (horizonal_dimension,number_of_chemical_tracers_for_diagnostics) type = real kind = kind_phys + active = (number_of_chemical_tracers_for_diagnostics > 0) [wetdpc] standard_name = instantaneous_convective_scale_wet_deposition long_name = instantaneous convective-scale wet deposition @@ -6069,6 +6324,7 @@ dimensions = (horizonal_dimension,number_of_chemical_tracers_for_diagnostics) type = real kind = kind_phys + active = (number_of_chemical_tracers_for_diagnostics > 0) [abem] standard_name = instantaneous_anthopogenic_and_biomass_burning_emissions long_name = instantaneous anthopogenic and biomass burning emissions for black carbon, organic carbon, and sulfur dioxide @@ -6090,6 +6346,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [edmf_w] standard_name = emdf_updraft_vertical_velocity long_name = updraft vertical velocity from mass flux scheme @@ -6097,6 +6354,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [edmf_qt] standard_name = emdf_updraft_total_water long_name = updraft total water from mass flux scheme @@ -6104,6 +6362,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [edmf_thl] standard_name = emdf_updraft_theta_l long_name = updraft theta-l from mass flux scheme @@ -6111,6 +6370,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [edmf_ent] standard_name = emdf_updraft_entrainment_rate long_name = updraft entranment rate from mass flux scheme @@ -6118,6 +6378,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [edmf_qc] standard_name = emdf_updraft_cloud_water long_name = updraft cloud water from mass flux scheme @@ -6125,6 +6386,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [sub_thl] standard_name = theta_subsidence_tendency long_name = updraft theta subsidence tendency @@ -6132,6 +6394,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [sub_sqv] standard_name = water_vapor_subsidence_tendency long_name = updraft water vapor subsidence tendency @@ -6139,6 +6402,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [det_thl] standard_name = theta_detrainment_tendency long_name = updraft theta detrainment tendency @@ -6146,6 +6410,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [det_sqv] standard_name = water_vapor_detrainment_tendency long_name = updraft water vapor detrainment tendency @@ -6153,12 +6418,14 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf .and. (mynn_output_flag .ne. 0)) [nupdraft] standard_name = number_of_plumes long_name = number of plumes per grid column units = count dimensions = (horizontal_dimension) type = integer + active = (do_mynnedmf) [maxMF] standard_name = maximum_mass_flux long_name = maximum mass flux within a column @@ -6166,6 +6433,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [ktop_shallow] standard_name = k_level_of_highest_reaching_plume long_name = k-level of highest reaching plume @@ -6178,6 +6446,7 @@ units = count dimensions = (horizontal_dimension) type = integer + active = (do_mynnedmf) [exch_h] standard_name = atmosphere_heat_diffusivity_for_mynnpbl long_name = diffusivity for heat for MYNN PBL (defined for all mass levels) @@ -6185,6 +6454,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [exch_m] standard_name = atmosphere_momentum_diffusivity_for_mynnpbl long_name = diffusivity for momentum for MYNN PBL (defined for all mass levels) @@ -6192,6 +6462,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (do_mynnedmf) [zmtb] standard_name = time_integral_of_height_of_mountain_blocking long_name = time integral of height of mountain blocking drag @@ -6248,6 +6519,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (diag_ugwp_flag) [du3dt_ogw] standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag long_name = time integral of change in x wind due to orographic gw drag @@ -6255,6 +6527,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (diag_ugwp_flag) [du3dt_tms] standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag long_name = time integral of change in x wind due to TOFD @@ -6262,6 +6535,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (diag_ugwp_flag) [du3dt_ngw] standard_name = time_integral_of_change_in_x_wind_due_to_nonstationary_gravity_wave long_name = time integral of change in x wind due to NGW @@ -6269,6 +6543,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (diag_ugwp_flag) [dv3dt_ngw] standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave long_name = time integral of change in y wind due to NGW @@ -6276,6 +6551,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (diag_ugwp_flag) [aux2d] standard_name = auxiliary_2d_arrays long_name = auxiliary 2d arrays to output (for debugging) @@ -6283,6 +6559,7 @@ dimensions = (horizontal_dimension,number_of_3d_auxiliary_arrays) type = real kind = kind_phys + active = (number_of_2d_auxiliary_arrays > 0) [aux3d] standard_name = auxiliary_3d_arrays long_name = auxiliary 3d arrays to output (for debugging) @@ -6290,9 +6567,15 @@ dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_auxiliary_arrays) type = real kind = kind_phys + active = (number_of_2d_auxiliary_arrays > 0) ######################################################################## +[ccpp-table-properties] + name = GFS_interstitial_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_interstitial_type type = ddt @@ -6303,6 +6586,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [qc_r] standard_name = cloud_liquid_water_mixing_ratio long_name = the ratio of the mass of liquid water to the mass of dry air @@ -6310,6 +6594,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [qr_r] standard_name = cloud_rain_water_mixing_ratio long_name = the ratio of the mass rain water to the mass of dry air @@ -6317,6 +6602,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [qi_r] standard_name = cloud_ice_mixing_ratio long_name = the ratio of the mass of ice to the mass of dry air @@ -6324,6 +6610,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [qs_r] standard_name = cloud_snow_mixing_ratio long_name = the ratio of the mass of snow to mass of dry air @@ -6331,6 +6618,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [qg_r] standard_name = mass_weighted_rime_factor_mixing_ratio long_name = the ratio of the mass of rime factor to mass of dry air @@ -6338,6 +6626,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [f_ice] standard_name = fraction_of_ice_water_cloud long_name = fraction of ice water cloud @@ -6345,6 +6634,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [f_rain] standard_name = fraction_of_rain_water_cloud long_name = fraction of rain water cloud @@ -6352,6 +6642,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [f_rimef] standard_name = rime_factor long_name = rime factor @@ -6359,6 +6650,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [cwm] standard_name = total_cloud_condensate_mixing_ratio_updated_by_physics long_name = total cloud condensate mixing ratio (except water vapor) updated by physics @@ -6366,6 +6658,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme) [adjsfculw_ocean] standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial) @@ -6548,6 +6841,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [clcn] standard_name = convective_cloud_volume_fraction long_name = convective cloud volume fraction @@ -6555,6 +6849,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [cldf] standard_name = cloud_area_fraction long_name = fraction of grid box area in which updrafts occur @@ -6695,6 +6990,7 @@ dimensions = (horizontal_dimension,4) type = real kind = kind_phys + active = (gwd_opt == 3 .or. gwd_opt == 33) [cmm_ocean] standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ocean long_name = momentum exchange coefficient over ocean @@ -6723,6 +7019,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [cnv_fice] standard_name = ice_fraction_in_convective_tower long_name = ice fraction in convective tower @@ -6730,6 +7027,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [cnv_mfd] standard_name = detrained_mass_flux long_name = detrained mass flux @@ -6737,6 +7035,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [cnv_ndrop] standard_name = number_concentration_of_cloud_liquid_water_particles_for_detrainment long_name = droplet number concentration in convective detrainment @@ -6744,6 +7043,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [cnv_nice] standard_name = number_concentration_of_ice_crystals_for_detrainment long_name = crystal number concentration in convective detrainment @@ -6751,6 +7051,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [cnvc] standard_name = convective_cloud_cover long_name = convective cloud cover @@ -7486,6 +7787,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_gfdl_microphysics_scheme .or. flag_for_microphysics_scheme == flag_for_thompson_microphysics_scheme) [gwdcu] standard_name = tendency_of_x_wind_due_to_convective_gravity_wave_drag long_name = zonal wind tendency due to convective gravity wave drag @@ -7590,6 +7892,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_gfdl_microphysics_scheme .or. flag_for_microphysics_scheme == flag_for_thompson_microphysics_scheme) [dry] standard_name = flag_nonzero_land_surface_fraction long_name = flag indicating presence of some land surface area fraction @@ -7771,6 +8074,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [ncpi] standard_name = local_ice_number_concentration long_name = number concentration of ice local to physics @@ -7778,6 +8082,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_shoc) [ncpl] standard_name = local_condesed_water_number_concentration long_name = number concentration of condensed water local to physics @@ -7785,6 +8090,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_shoc) [ncpr] standard_name = local_rain_number_concentration long_name = number concentration of rain local to physics @@ -7792,6 +8098,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [ncps] standard_name = local_snow_number_concentration long_name = number concentration of snow local to physics @@ -7799,6 +8106,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [ncstrac] standard_name = number_of_tracers_for_CS long_name = number of convectively transported tracers in Chikira-Sugiyama deep convection scheme @@ -7891,6 +8199,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 3 .or. gwd_opt == 33) [oa4ss] standard_name = asymmetry_of_subgrid_orography_small_scale long_name = asymmetry of subgrid orography small scale @@ -7898,6 +8207,7 @@ dimensions = (horizontal_dimension,4) type = real kind = kind_phys + active = (gwd_opt == 3 .or. gwd_opt == 33) [oc] standard_name = convexity_of_subgrid_orography long_name = convexity of subgrid orography @@ -7912,6 +8222,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (gwd_opt == 3 .or. gwd_opt == 33) [olyr] standard_name = ozone_concentration_at_layer_for_radiation long_name = ozone concentration layer @@ -7978,6 +8289,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [qgl] standard_name = local_graupel_mixing_ratio long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) local to physics @@ -7985,6 +8297,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme .or. flag_for_shoc) [qicn] standard_name = mass_fraction_of_convective_cloud_ice long_name = mass fraction of convective cloud ice water @@ -7992,6 +8305,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [qlcn] standard_name = mass_fraction_of_convective_cloud_liquid_water long_name = mass fraction of convective cloud liquid water @@ -7999,6 +8313,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [qlyr] standard_name = water_vapor_specific_humidity_at_layer_for_radiation long_name = specific humidity layer @@ -8013,6 +8328,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme .or. flag_for_shoc) [qsnw] standard_name = local_snow_water_mixing_ratio long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) local to physics @@ -8020,6 +8336,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme .or. flag_for_shoc) [prcpmp] standard_name = lwe_thickness_of_explicit_precipitation_amount long_name = explicit precipitation (rain, ice, snow, graupel, ...) on physics timestep @@ -8089,6 +8406,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_gfdl_microphysics_scheme .or. flag_for_microphysics_scheme == flag_for_thompson_microphysics_scheme) [rainp] standard_name = tendency_of_rain_water_mixing_ratio_due_to_microphysics long_name = tendency of rain water mixing ratio due to microphysics @@ -8330,6 +8648,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_gfdl_microphysics_scheme .or. flag_for_microphysics_scheme == flag_for_thompson_microphysics_scheme) [snowmt] standard_name = surface_snow_melt long_name = snow melt during timestep @@ -8378,6 +8697,7 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys + active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme) [theta] standard_name = angle_from_east_of_maximum_subgrid_orographic_variations long_name = angle with_respect to east of maximum subgrid orographic variations @@ -8590,6 +8910,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme) [wcbmax] standard_name = maximum_updraft_velocity_at_cloud_base long_name = maximum updraft velocity at cloud base @@ -8808,6 +9129,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa long_name = air pressure level @@ -8816,6 +9138,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [t_lay] standard_name = air_temperature_at_layer_for_RRTMGP long_name = air temperature layer @@ -8824,6 +9147,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [t_lev] standard_name = air_temperature_at_interface_for_RRTMGP long_name = air temperature layer @@ -8832,6 +9156,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [tv_lay] standard_name = virtual_temperature long_name = layer virtual temperature @@ -8840,6 +9165,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [relhum] standard_name = relative_humidity long_name = layer relative humidity @@ -8847,6 +9173,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [deltaZ] standard_name = layer_thickness long_name = layer_thickness @@ -8854,6 +9181,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [tracer] standard_name = chemical_tracers long_name = chemical tracers @@ -8861,6 +9189,7 @@ dimensions = (horizontal_dimension,vertical_dimension,number_of_tracers) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [cloud_overlap_param] standard_name = cloud_overlap_param long_name = cloud overlap parameter @@ -8868,6 +9197,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [precip_overlap_param] standard_name = precip_overlap_param long_name = precipitation overlap parameter @@ -8875,6 +9205,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [ipsdsw0] standard_name = initial_permutation_seed_sw long_name = initial seed for McICA SW @@ -8910,6 +9241,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [fluxlwDOWN_allsky] standard_name = RRTMGP_lw_flux_profile_downward_allsky long_name = RRTMGP downward longwave all-sky flux profile @@ -8918,6 +9250,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [fluxlwUP_clrsky] standard_name = RRTMGP_lw_flux_profile_upward_clrsky long_name = RRTMGP upward longwave clr-sky flux profile @@ -8926,6 +9259,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [fluxlwDOWN_clrsky] standard_name = RRTMGP_lw_flux_profile_downward_clrsky long_name = RRTMGP downward longwave clr-sky flux profile @@ -8933,6 +9267,7 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [sktp1r] standard_name = surface_skin_temperature_at_previous_time_step long_name = surface skin temperature at previous time step @@ -8962,6 +9297,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [fluxswDOWN_allsky] standard_name = RRTMGP_sw_flux_profile_downward_allsky long_name = RRTMGP downward shortwave all-sky flux profile @@ -8970,6 +9306,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [fluxswUP_clrsky] standard_name = RRTMGP_sw_flux_profile_upward_clrsky long_name = RRTMGP upward shortwave clr-sky flux profile @@ -8978,6 +9315,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [fluxswDOWN_clrsky] standard_name = RRTMGP_sw_flux_profile_downward_clrsky long_name = RRTMGP downward shortwave clr-sky flux profile @@ -8986,6 +9324,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [flxprf_lw] standard_name = RRTMGP_lw_fluxes long_name = lw fluxes total sky / csk and up / down at levels @@ -8993,6 +9332,7 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = proflw_type optional = T + active = (flag_for_rrtmgp_radiation_scheme) [flxprf_sw] standard_name = RRTMGP_sw_fluxes long_name = sw fluxes total sky / csk and up / down at levels @@ -9000,6 +9340,7 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = profsw_type optional = T + active = (flag_for_rrtmgp_radiation_scheme) [aerosolslw] standard_name = RRTMGP_aerosol_optical_properties_for_longwave_bands_01_16 long_name = aerosol optical properties for longwave bands 01-16 @@ -9008,6 +9349,7 @@ type = real kind = kind_phys optional = F + active = (flag_for_rrtmgp_radiation_scheme) [aerosolslw(:,:,:,1)] standard_name = RRTMGP_aerosol_optical_depth_for_longwave_bands_01_16 long_name = aerosol optical depth for longwave bands 01-16 @@ -9036,6 +9378,7 @@ dimensions = (horizontal_dimension,vertical_dimension, number_of_sw_bands_rrtmgp, number_of_aerosol_output_fields_for_shortwave_radiation) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [aerosolssw(:,:,:,1)] standard_name = RRTMGP_aerosol_optical_depth_for_shortwave_bands_01_16 long_name = aerosol optical depth for shortwave bands 01-16 @@ -9063,12 +9406,14 @@ units = none dimensions = (horizontal_dimension) type = integer + active = (flag_for_rrtmgp_radiation_scheme) [icseed_sw] standard_name = seed_random_numbers_sw_for_RRTMGP long_name = seed for random number generation for shortwave radiation units = none dimensions = (horizontal_dimension) type = integer + active = (flag_for_rrtmgp_radiation_scheme) [precip_frac] standard_name = precipitation_fraction_by_layer long_name = precipitation fraction in each layer @@ -9076,6 +9421,7 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [sw_gas_props] standard_name = coefficients_for_sw_gas_optics long_name = DDT containing spectral information for RRTMGP SW radiation scheme @@ -9191,6 +9537,7 @@ dimensions = (number_of_lw_bands_rrtmgp,horizontal_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [sec_diff_byband] standard_name = secant_of_diffusivity_angle_each_RRTMGP_LW_band long_name = secant of diffusivity angle in each RRTMGP LW band @@ -9198,6 +9545,7 @@ dimensions = (number_of_lw_bands_rrtmgp,horizontal_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [sfc_alb_nir_dir] standard_name = surface_albedo_nearIR_direct long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir) @@ -9205,6 +9553,7 @@ dimensions = (number_of_sw_bands_rrtmgp,horizontal_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [sfc_alb_nir_dif] standard_name = surface_albedo_nearIR_diffuse long_name = near-IR (diffuse) surface albedo (sfc_alb_nir_dif) @@ -9212,6 +9561,7 @@ dimensions = (number_of_sw_bands_rrtmgp,horizontal_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [sfc_alb_uvvis_dir] standard_name = surface_albedo_uvvis_dir long_name = UVVIS (direct) surface albedo (sfc_alb_uvvis_dir) @@ -9219,6 +9569,7 @@ dimensions = (number_of_sw_bands_rrtmgp,horizontal_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [sfc_alb_uvvis_dif] standard_name = surface_albedo_uvvis_dif long_name = UVVIS (diffuse) surface albedo (sfc_alb_uvvis_dif) @@ -9226,6 +9577,7 @@ dimensions = (number_of_sw_bands_rrtmgp,horizontal_dimension) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [toa_src_lw] standard_name = toa_incident_lw_flux_by_spectral_point long_name = TOA longwave incident flux at each spectral points @@ -9233,6 +9585,7 @@ dimensions = (horizontal_dimension,number_of_lw_spectral_points_rrtmgp) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [toa_src_sw] standard_name = toa_incident_sw_flux_by_spectral_point long_name = TOA shortwave incident flux at each spectral points @@ -9240,6 +9593,7 @@ dimensions = (horizontal_dimension,number_of_sw_spectral_points_rrtmgp) type = real kind = kind_phys + active = (flag_for_rrtmgp_radiation_scheme) [active_gases_array] standard_name = list_of_active_gases_used_by_RRTMGP long_name = list of active gases used by RRTMGP @@ -9247,8 +9601,14 @@ dimensions = (number_of_active_gases_used_by_RRTMGP) type = character kind = len=128 + active = (flag_for_rrtmgp_radiation_scheme) ######################################################################## +[ccpp-table-properties] + name = GFS_data_type + type = ddt + dependencies = + [ccpp-arg-table] name = GFS_data_type type = ddt @@ -9308,6 +9668,14 @@ type = GFS_diag_type ######################################################################## +[ccpp-table-properties] + name = GFS_typedefs + type = module + relative_path = ../../ccpp/physics/physics + dependencies = machine.F,physcons.F90,radlw_param.f,radsw_param.f,GFDL_parse_tracers.F90 + dependencies = rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_optical_props.F90,rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90 + dependencies = rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_rte_config.F90,rte-rrtmgp/rte/mo_source_functions.F90 + [ccpp-arg-table] name = GFS_typedefs type = module From 034d8f27fe5486babef746a24236feb93e04d1f4 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 4 Sep 2020 07:16:41 -0600 Subject: [PATCH 07/13] Update .gitmodules for code review and testing --- .gitmodules | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/.gitmodules b/.gitmodules index bdc0ffbf1..179e9fc05 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,9 +4,13 @@ branch = gsd/develop [submodule "ccpp/framework"] path = ccpp/framework - url = https://github.com/NOAA-GSD/ccpp-framework - branch = gsd/develop + #url = https://github.com/NOAA-GSD/ccpp-framework + #branch = gsd/develop + url = https://github.com/climbfuji/ccpp-framework + branch = update_gsd_develop_from_master_20200903 [submodule "ccpp/physics"] path = ccpp/physics - url = https://github.com/NOAA-GSD/ccpp-physics - branch = gsd/develop + #url = https://github.com/NOAA-GSD/ccpp-physics + #branch = gsd/develop + url = https://github.com/climbfuji/ccpp-physics + branch = update_gsd_develop_from_master_20200903 \ No newline at end of file From 9b224af504352282857c5531b134d3bba81a164b Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 4 Sep 2020 08:53:29 -0600 Subject: [PATCH 08/13] Update submodule pointer for ccpp-physics --- ccpp/physics | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/physics b/ccpp/physics index 5e8635f54..8f8dd2e8e 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 5e8635f54f480568694867683fa57dee32777c5f +Subproject commit 8f8dd2e8e00145027568e3e34b8bd5dc2fe680ec From 3bceaff452e61b87757ccbe475269197709feede Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Tue, 15 Sep 2020 06:06:56 -0600 Subject: [PATCH 09/13] Python 3 bugfix in ccpp-framework (update submodule pointer only) (#171) --- ccpp/framework | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ccpp/framework b/ccpp/framework index 836558713..f06e053db 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit 8365587133b40b1faa2831ac395bf098c3dac4a6 +Subproject commit f06e053db04eaea602d43d6221081ba54fb6cc95 From 6bc61df3c363f9134a46439ff4a5a4a803daafb1 Mon Sep 17 00:00:00 2001 From: Jun Wang <37633869+junwang-noaa@users.noreply.github.com> Date: Wed, 16 Sep 2020 12:26:50 -0400 Subject: [PATCH 10/13] support one step s2s cold start (#168) * set up dycore_data at atmos_init * fix syntax error in atmos_model.F90 * put in initial fields in fv3 export fields at init * add state_diagnose from Denise * fix state diagnose on write tasks Co-authored-by: Jun Wang Co-authored-by: Denise.Worthen --- atmos_model.F90 | 17 ++++-- cpl/module_cap_cpl.F90 | 123 ++++++++++++++++++++++++++++++++------- cpl/module_cplfields.F90 | 4 +- fv3_cap.F90 | 44 +++++++++++--- 4 files changed, 154 insertions(+), 34 deletions(-) diff --git a/atmos_model.F90 b/atmos_model.F90 index 35b2c4ceb..0499c3c56 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -743,6 +743,15 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) fv3Clock = mpp_clock_id( 'FV3 Dycore ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) endif +!--- get bottom layer data from dynamical core for coupling + call atmosphere_get_bottom_layer (Atm_block, DYCORE_Data) + + !if in coupled mode, set up coupled fields + if (IPD_Control%cplflx .or. IPD_Control%cplwav) then + if (mpp_pe() == mpp_root_pe()) print *,'COUPLING: IPD layer' + call setup_exportdata(ierr) + endif + #ifdef CCPP ! Set flag for first time step of time integration IPD_Control%first_time_step = .true. @@ -911,8 +920,6 @@ subroutine update_atmos_model_state (Atmos) !if in coupled mode, set up coupled fields if (IPD_Control%cplflx .or. IPD_Control%cplwav) then -! if (mpp_pe() == mpp_root_pe()) print *,'COUPLING: IPD layer' -!jw call setup_exportdata(IPD_Control, IPD_Data, Atm_block) call setup_exportdata(rc) endif @@ -2016,7 +2023,7 @@ subroutine setup_exportdata (rc) integer :: j, i, ix, nb, isc, iec, jsc, jec, idx real(IPD_kind_phys) :: rtime, rtimek ! -! if (mpp_pe() == mpp_root_pe()) print *,'enter setup_exportdata' + if (mpp_pe() == mpp_root_pe()) print *,'enter setup_exportdata' isc = IPD_control%isc iec = IPD_control%isc+IPD_control%nx-1 @@ -2579,6 +2586,7 @@ subroutine setup_exportdata (rc) ! bottom layer temperature (t) idx = queryfieldlist(exportFieldsList,'inst_temp_height_lowest') + if (mpp_pe() == mpp_root_pe()) print *,'cpl, in get inst_temp_height_lowest' if (idx > 0 ) then !$omp parallel do default(shared) private(i,j,nb,ix) do j=jsc,jec @@ -2592,6 +2600,7 @@ subroutine setup_exportdata (rc) endif enddo enddo + if (mpp_pe() == mpp_root_pe()) print *,'cpl, in get inst_temp_height_lowest=',exportData(isc,jsc,idx) endif ! bottom layer specific humidity (q) @@ -2728,7 +2737,7 @@ subroutine setup_exportdata (rc) IPD_Data(nb)%coupling%snow_cpl(ix) = zero enddo enddo - if (mpp_pe() == mpp_root_pe()) print *,'zeroing coupling fields at kdt= ',IPD_Control%kdt + if (mpp_pe() == mpp_root_pe()) print *,'zeroing coupling accumulated fields at kdt= ',IPD_Control%kdt endif !cplflx ! if (mpp_pe() == mpp_root_pe()) print *,'end of setup_exportdata' diff --git a/cpl/module_cap_cpl.F90 b/cpl/module_cap_cpl.F90 index 82980612b..f5427c791 100644 --- a/cpl/module_cap_cpl.F90 +++ b/cpl/module_cap_cpl.F90 @@ -13,7 +13,7 @@ module module_cap_cpl public clock_cplIntval public realizeConnectedInternCplField public realizeConnectedCplFields - public Dump_cplFields + public diagnose_cplFields ! contains @@ -193,9 +193,11 @@ subroutine realizeConnectedCplFields(state, grid, end select call NUOPC_Realize(state, field=field, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! -- zero out field call ESMF_FieldFill(field, dataFillScheme="const", const1=0._ESMF_KIND_R8, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + ! -- save field fieldList(item) = field call ESMF_LogWrite('realizeConnectedCplFields '//trim(state_tag)//' Field '//trim(fieldNames(item)) & @@ -213,13 +215,14 @@ end subroutine realizeConnectedCplFields !----------------------------------------------------------------------------- - subroutine Dump_cplFields(gcomp, importState, exportstate, clock_fv3, & - statewrite_flag, state_tag, timestr) + subroutine diagnose_cplFields(gcomp, importState, exportstate, clock_fv3, & + statewrite_flag, stdiagnose_flag, state_tag, timestr) type(ESMF_GridComp), intent(in) :: gcomp type(ESMF_State) :: importState, exportstate type(ESMF_Clock),intent(in) :: clock_fv3 logical, intent(in) :: statewrite_flag + integer, intent(in) :: stdiagnose_flag character(len=*), intent(in) :: state_tag !< Import or export. character(len=*), intent(in) :: timestr !< Import or export. integer :: timeslice = 1 @@ -241,32 +244,39 @@ subroutine Dump_cplFields(gcomp, importState, exportstate, clock_fv3, & unit=nuopcMsg) ! call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO) - ! Dumping Fields out - if (statewrite_flag) then + if(trim(state_tag) .eq. 'import')then + call ESMF_GridCompGet(gcomp, importState=importState, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - if(trim(state_tag) .eq. 'import')then - call ESMF_GridCompGet(gcomp, importState=importState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - ! replace with tiled field dumps - !call ESMFPP_RegridWriteState(importState, "fv3_cap_import_", timeslice, rc=rc) - write(filename,'(a,a,a)') 'fv3_cap_import_'//trim(timestr)//'_' + if(stdiagnose_flag > 0)then + call state_diagnose(importState, ':IS', rc=rc) + end if + + ! Dump Fields out + if (statewrite_flag) then + write(filename,'(A)') 'fv3_cap_import_'//trim(timestr)//'_' call State_RWFields_tiles(importState,trim(filename), timeslice, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return end if + end if - if(trim(state_tag) .eq. 'export')then - call ESMF_GridCompGet(gcomp, exportState=exportState, rc=rc) - if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return - ! replace with tiled field dumps - !call ESMFPP_RegridWriteState(exportState, "fv3_cap_export_", timeslice, rc=rc) - write(filename,'(a,a,a)') 'fv3_cap_export_'//trim(timestr)//'_' + if(trim(state_tag) .eq. 'export')then + call ESMF_GridCompGet(gcomp, exportState=exportState, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if(stdiagnose_flag > 0)then + call state_diagnose(exportState, ':ES', rc=rc) + end if + + ! Dump Fields out + if (statewrite_flag) then + write(filename,'(A)') 'fv3_cap_export_'//trim(timestr)//'_' call State_RWFields_tiles(exportState,trim(filename), timeslice, rc=rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return end if + end if - endif -! - end subroutine Dump_cplFields + end subroutine diagnose_cplFields !----------------------------------------------------------------------------- @@ -457,4 +467,77 @@ end subroutine State_RWFields_tiles !----------------------------------------------------------------------------- + subroutine state_diagnose(State,string, rc) + ! ---------------------------------------------- + ! Diagnose status of state + ! ---------------------------------------------- + type(ESMF_State), intent(inout) :: State + character(len=*), intent(in), optional :: string + integer, intent(out), optional :: rc + + ! local variables + integer :: i,j,n + integer :: itemCount + character(len=64) ,pointer :: itemNameList(:) + character(len=64) :: lstring + character(len=256) :: tmpstr + + type(ESMF_Field) :: lfield + type(ESMF_StateItem_Flag) :: itemType + real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) + real(ESMF_KIND_R8), pointer :: dataPtr3d(:,:,:) + integer :: lrc, dimCount + character(len=*),parameter :: subname='(FV3: state_diagnose)' + + lstring = '' + if (present(string)) then + lstring = trim(string) + endif + + call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO) + + call ESMF_StateGet(State, itemCount=itemCount, rc=lrc) + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + allocate(itemNameList(itemCount)) + + call ESMF_StateGet(State, itemNameList=itemNameList, rc=lrc) + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + do n = 1, itemCount + call ESMF_StateGet(State, itemName=trim(itemNameList(n)), itemType=itemType, rc=lrc) + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if(itemType == ESMF_STATEITEM_FIELD)then + call ESMF_StateGet(State, itemName=trim(itemNameList(n)), field=lfield, rc=lrc) + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + call ESMF_FieldGet(lfield, dimCount=dimcount, rc=lrc) + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + if(dimcount == 2)then + call ESMF_FieldGet(lfield, farrayPtr=dataPtr2d, rc=lrc) + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + write(tmpstr,'(A,3g14.7)') trim(subname)//' '//trim(lstring)//':'//trim(itemNameList(n))//' ', & + minval(dataPtr2d),maxval(dataPtr2d),sum(dataPtr2d) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=lrc) + else + call ESMF_FieldGet(lfield, farrayPtr=dataPtr3d, rc=lrc) + if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + + write(tmpstr,'(A,3g14.7)') trim(subname)//' '//trim(lstring)//':'//trim(itemNameList(n))//' ', & + minval(dataPtr3d),maxval(dataPtr3d),sum(dataPtr3d) + call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=lrc) + end if + end if + enddo + deallocate(itemNameList) + + if (present(rc)) rc = lrc + call ESMF_LogWrite(subname//' exit', ESMF_LOGMSG_INFO) + + end subroutine state_diagnose + + !----------------------------------------------------------------------------- + end module module_cap_cpl diff --git a/cpl/module_cplfields.F90 b/cpl/module_cplfields.F90 index 5e62755f9..3690731ea 100644 --- a/cpl/module_cplfields.F90 +++ b/cpl/module_cplfields.F90 @@ -201,6 +201,7 @@ subroutine fillExportFields(data_a2oi, rc) integer :: n,dimCount logical :: isCreated type(ESMF_TypeKind_Flag) :: datatype + character(len=ESMF_MAXSTR) :: fieldName real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: datar42d real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d @@ -212,8 +213,9 @@ subroutine fillExportFields(data_a2oi, rc) if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return if (isCreated) then ! set data - call ESMF_FieldGet(exportFields(n), dimCount=dimCount, typekind=datatype, rc=localrc) + call ESMF_FieldGet(exportFields(n), name=fieldname, dimCount=dimCount, typekind=datatype, rc=localrc) if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return + !print *,'in fillExportFields, field created n=',n,size(exportFields),'name=', trim(fieldname) if ( datatype == ESMF_TYPEKIND_R8) then if ( dimCount == 2) then call ESMF_FieldGet(exportFields(n),farrayPtr=datar82d,localDE=0, rc=localrc) diff --git a/fv3_cap.F90 b/fv3_cap.F90 index 0ff14e91f..29b7c361a 100644 --- a/fv3_cap.F90 +++ b/fv3_cap.F90 @@ -60,9 +60,10 @@ module fv3gfs_cap_mod nImportFields, importFields, & importFieldsList, importFieldTypes, & importFieldShare, importFieldsValid, & - queryFieldList + queryFieldList, fillExportFields, & + exportData use module_cap_cpl, only: realizeConnectedCplFields, & - clock_cplIntval, Dump_cplFields + clock_cplIntval, diagnose_cplFields implicit none @@ -92,6 +93,7 @@ module fv3gfs_cap_mod character(len=160) :: nuopcMsg integer :: timeslice = 0 integer :: fcstmype + integer :: dbug = 0 !----------------------------------------------------------------------- @@ -188,7 +190,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) character(len=10) :: value character(240) :: msgString - + logical :: isPresent, isSet character(len=*),parameter :: subname='(fv3gfs_cap:InitializeP0)' rc = ESMF_SUCCESS @@ -211,6 +213,15 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(msgString,'(A,l6)') trim(subname)//' cplprint_flag = ',cplprint_flag call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) + ! Read in cap debug flag + call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=value, isPresent=isPresent, isSet=isSet, rc=rc) + if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (isPresent .and. isSet) then + read(value,*) dbug + end if + write(msgString,'(A,i6)') trim(subname)//' dbug = ',dbug + call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc) + end subroutine !----------------------------------------------------------------------------- @@ -549,6 +560,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) rsthour = CurrTime - StartTime first_kdt = nint(rsthour/timeStep) + 1 endif + ! !####################################################################### ! set up fcst grid component @@ -560,7 +572,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! create fcst grid component fcstpe = .false. - num_pes_fcst = petcount - write_groups * wrttasks_per_group + if( quilting ) then + num_pes_fcst = petcount - write_groups * wrttasks_per_group + else + num_pes_fcst = petcount + endif allocate(fcstPetList(num_pes_fcst)) do j=1, num_pes_fcst fcstPetList(j) = j - 1 @@ -937,6 +953,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) importFields, rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return end if +!jw + call fillExportFields(exportData) endif end subroutine InitializeRealize @@ -1042,6 +1060,7 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_ClockGet(clock_fv3, currTime=currTime, timeStep=timeStep, rc=rc) call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc) call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc) + ! !----------------------------------------------------------------------------- !*** integration loop @@ -1066,8 +1085,12 @@ subroutine ModelAdvance(gcomp, rc) if ( cpl ) then ! assign import_data called during phase=1 - call Dump_cplFields(gcomp, importState, exportstate, clock_fv3, & - cplprint_flag, 'import', import_timestr) + if( dbug > 0 .or. cplprint_flag ) then + if( mype < num_pes_fcst ) then + call diagnose_cplFields(gcomp, importState, exportstate, clock_fv3, & + cplprint_flag, dbug, 'import', import_timestr) + endif + endif endif call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock_fv3, & @@ -1191,8 +1214,12 @@ subroutine ModelAdvance(gcomp, rc) ! !jw for coupled, check clock and dump import and export state if ( cpl ) then - call Dump_cplFields(gcomp, importState, exportstate, clock_fv3, & - cplprint_flag, 'export', export_timestr) + if( dbug > 0 .or. cplprint_flag ) then + if( mype < num_pes_fcst ) then + call diagnose_cplFields(gcomp, importState, exportstate, clock_fv3, & + cplprint_flag, dbug, 'export', export_timestr) + endif + end if endif if (mype==0) print *,'fv3_cap,end integrate,na=',na,' time=',mpi_wtime()- timeri @@ -1660,7 +1687,6 @@ subroutine atmos_model_finalize(gcomp, rc) end subroutine atmos_model_finalize - !####################################################################### ! ! From 9e1ba7c7448a8d009f39b5588e9498a7dbab1c60 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Sat, 26 Sep 2020 07:15:33 -0600 Subject: [PATCH 11/13] RRTMG cloud overlap method update (#157) Add two new interstitial variables to GFS_typedefs.{F90,meta} that are required for the RRTMG cloud overlap additions by @mjiacono (see NCAR/ccpp-physics#487). Other changes: * fix wrong metadata in GFS_typedefs.meta (optional and intent are not valid for host model variable tables) * note that RRTMG and RRTMGP use different interstitial variables for the decorrelation parameter alpha; this is because RRTMGP only works when the number of model levels is the same for radiation (levr) and other physics (levs), while RRTMG works with different numbers of levels; only the one in use gets allocated * replace GSL drag suite with CIRES UGWP/GFS GWD in ccpp/suites/suite_FV3_RRFS_v1beta.xml (cherry-picked from PR #173 for release/public-v2) --- ccpp/physics | 2 +- ccpp/suites/suite_FV3_RRFS_v1beta.xml | 3 ++- gfsphysics/GFS_layer/GFS_typedefs.F90 | 14 ++++++++++ gfsphysics/GFS_layer/GFS_typedefs.meta | 37 +++++++++++--------------- 4 files changed, 33 insertions(+), 23 deletions(-) diff --git a/ccpp/physics b/ccpp/physics index 0808cc2e8..f91d1bfde 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 0808cc2e8938ba66003b46746858143a9d75addb +Subproject commit f91d1bfde0bcdf69a8efe0917f49a4713e590bef diff --git a/ccpp/suites/suite_FV3_RRFS_v1beta.xml b/ccpp/suites/suite_FV3_RRFS_v1beta.xml index 3bff7b39d..c570483df 100644 --- a/ccpp/suites/suite_FV3_RRFS_v1beta.xml +++ b/ccpp/suites/suite_FV3_RRFS_v1beta.xml @@ -56,7 +56,8 @@ GFS_surface_generic_post mynnedmf_wrapper GFS_GWD_generic_pre - drag_suite + cires_ugwp + cires_ugwp_post GFS_GWD_generic_post rayleigh_damp GFS_suite_stateout_update diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 429170059..67d8a7668 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -657,6 +657,7 @@ module GFS_typedefs integer :: icliq_sw !< sw optical property for liquid clouds integer :: iovr_sw !< sw: max-random overlap clouds integer :: iovr_lw !< lw: max-random overlap clouds + integer :: iovr !< max-random overlap clouds for sw & lw (maximum of both) integer :: ictm !< ictm=0 => use data at initial cond time, if not !< available; use latest; no extrapolation. !< ictm=1 => use data at the forecast time, if not @@ -1681,6 +1682,7 @@ module GFS_typedefs real (kind=kind_phys), pointer :: adjvisdfd(:) => null() !< real (kind=kind_phys), pointer :: aerodp(:,:) => null() !< real (kind=kind_phys), pointer :: alb1d(:) => null() !< + real (kind=kind_phys), pointer :: alpha(:,:) => null() !< real (kind=kind_phys), pointer :: bexp1d(:) => null() !< real (kind=kind_phys), pointer :: cd(:) => null() !< real (kind=kind_phys), pointer :: cd_ice(:) => null() !< @@ -3683,6 +3685,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%icliq_sw = icliq_sw Model%iovr_sw = iovr_sw Model%iovr_lw = iovr_lw + Model%iovr = max(Model%iovr_sw,Model%iovr_lw) Model%ictm = ictm Model%isubc_sw = isubc_sw Model%isubc_lw = isubc_lw @@ -4838,6 +4841,7 @@ subroutine control_print(Model) print *, ' icliq_sw : ', Model%icliq_sw print *, ' iovr_sw : ', Model%iovr_sw print *, ' iovr_lw : ', Model%iovr_lw + print *, ' iovr : ', Model%iovr print *, ' ictm : ', Model%ictm print *, ' isubc_sw : ', Model%isubc_sw print *, ' isubc_lw : ', Model%isubc_lw @@ -6179,6 +6183,10 @@ subroutine interstitial_create (Interstitial, IM, Model) allocate (Interstitial%adjvisdfd (IM)) allocate (Interstitial%aerodp (IM,NSPC1)) allocate (Interstitial%alb1d (IM)) + if (.not. Model%do_RRTMGP) then + ! RRTMGP uses its own cloud_overlap_param + allocate (Interstitial%alpha (IM,Model%levr+LTP)) + end if allocate (Interstitial%bexp1d (IM)) allocate (Interstitial%cd (IM)) allocate (Interstitial%cd_ice (IM)) @@ -6718,6 +6726,9 @@ subroutine interstitial_rad_reset (Interstitial, Model) ! Interstitial%aerodp = clear_val Interstitial%alb1d = clear_val + if (.not. Model%do_RRTMGP) then + Interstitial%alpha = clear_val + end if Interstitial%cldsa = clear_val Interstitial%cldtaulw = clear_val Interstitial%cldtausw = clear_val @@ -7154,6 +7165,9 @@ subroutine interstitial_print(Interstitial, Model, mpirank, omprank, blkno) write (0,*) 'sum(Interstitial%adjvisdfd ) = ', sum(Interstitial%adjvisdfd ) write (0,*) 'sum(Interstitial%aerodp ) = ', sum(Interstitial%aerodp ) write (0,*) 'sum(Interstitial%alb1d ) = ', sum(Interstitial%alb1d ) + if (.not. Model%do_RRTMGP) then + write (0,*) 'sum(Interstitial%alpha ) = ', sum(Interstitial%alpha ) + end if write (0,*) 'sum(Interstitial%bexp1d ) = ', sum(Interstitial%bexp1d ) write (0,*) 'sum(Interstitial%cd ) = ', sum(Interstitial%cd ) write (0,*) 'sum(Interstitial%cd_ice ) = ', sum(Interstitial%cd_ice ) diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta index 84ba83e86..24bd57de7 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.meta +++ b/gfsphysics/GFS_layer/GFS_typedefs.meta @@ -2468,14 +2468,20 @@ units = flag dimensions = () type = integer +[iovr] + standard_name = flag_for_cloud_overlap_method_for_radiation + long_name = max-random overlap clouds + units = flag + dimensions = () + type = integer [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 = () type = integer [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 = () @@ -6750,6 +6756,13 @@ dimensions = (horizontal_dimension) type = real kind = kind_phys +[alpha] + standard_name = cloud_overlap_decorrelation_parameter + long_name = cloud overlap decorrelation parameter for RRTMG (but not for RRTMGP) + units = frac + dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation) + type = real + kind = kind_phys [bexp1d] standard_name = perturbation_of_soil_type_b_parameter long_name = perturbation of soil type "b" parameter @@ -9128,7 +9141,6 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [p_lev] standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa @@ -9137,7 +9149,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [t_lay] standard_name = air_temperature_at_layer_for_RRTMGP @@ -9146,7 +9157,6 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [t_lev] standard_name = air_temperature_at_interface_for_RRTMGP @@ -9155,7 +9165,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [tv_lay] standard_name = virtual_temperature @@ -9164,7 +9173,6 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [relhum] standard_name = relative_humidity @@ -9192,7 +9200,7 @@ active = (flag_for_rrtmgp_radiation_scheme) [cloud_overlap_param] standard_name = cloud_overlap_param - long_name = cloud overlap parameter + long_name = cloud overlap parameter for RRTMGP (but not for RRTMG) units = km dimensions = (horizontal_dimension,vertical_dimension) type = real @@ -9225,7 +9233,6 @@ dimensions = (horizontal_dimension,vertical_dimension) type = real kind = kind_phys - optional = F [cldtaulw] standard_name = RRTMGP_cloud_optical_depth_layers_at_10mu_band long_name = approx 10mu band layer cloud optical depth @@ -9240,7 +9247,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [fluxlwDOWN_allsky] standard_name = RRTMGP_lw_flux_profile_downward_allsky @@ -9249,7 +9255,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [fluxlwUP_clrsky] standard_name = RRTMGP_lw_flux_profile_upward_clrsky @@ -9258,7 +9263,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [fluxlwDOWN_clrsky] standard_name = RRTMGP_lw_flux_profile_downward_clrsky @@ -9296,7 +9300,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [fluxswDOWN_allsky] standard_name = RRTMGP_sw_flux_profile_downward_allsky @@ -9305,7 +9308,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [fluxswUP_clrsky] standard_name = RRTMGP_sw_flux_profile_upward_clrsky @@ -9314,7 +9316,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [fluxswDOWN_clrsky] standard_name = RRTMGP_sw_flux_profile_downward_clrsky @@ -9323,7 +9324,6 @@ dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [flxprf_lw] standard_name = RRTMGP_lw_fluxes @@ -9331,7 +9331,6 @@ units = W m-2 dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = proflw_type - optional = T active = (flag_for_rrtmgp_radiation_scheme) [flxprf_sw] standard_name = RRTMGP_sw_fluxes @@ -9339,7 +9338,6 @@ units = W m-2 dimensions = (horizontal_dimension,vertical_dimension_plus_one) type = profsw_type - optional = T active = (flag_for_rrtmgp_radiation_scheme) [aerosolslw] standard_name = RRTMGP_aerosol_optical_properties_for_longwave_bands_01_16 @@ -9348,7 +9346,6 @@ dimensions = (horizontal_dimension,vertical_dimension, number_of_lw_bands_rrtmgp,number_of_aerosol_output_fields_for_longwave_radiation) type = real kind = kind_phys - optional = F active = (flag_for_rrtmgp_radiation_scheme) [aerosolslw(:,:,:,1)] standard_name = RRTMGP_aerosol_optical_depth_for_longwave_bands_01_16 @@ -9939,5 +9936,3 @@ dimensions = () type = real kind = kind_phys - intent = in - optional = F From ab0e5ae33b24c191f201edb80361de799816a2d8 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Wed, 30 Sep 2020 13:29:46 -0600 Subject: [PATCH 12/13] CCPP tendencies bugfixes, global restart reproducibility, halo boundary update in dycore (#178) * contributions from @SMoorthi-emc to fix the global restart reproducibility and to keep compiling without CCPP * updates the submodule pointers for GFDL_atmos_cubed_sphere and ccpp-physics * bugfix in ccpp/CMakeLists.txt to correctly set AVX2 flags or not (discovered by Yunheng) * changes mod_name of non-phys tendencies in GFS_diagnostics.F90 to gfs_dyn from gfs_phys (from @grantfirl) --- atmos_cubed_sphere | 2 +- atmos_model.F90 | 21 ++--- ccpp/CMakeLists.txt | 12 +-- ccpp/driver/CCPP_driver.F90 | 12 +-- ccpp/physics | 2 +- .../suites/suite_FV3_GFS_2017_couplednsst.xml | 89 +++++++++++++++++++ .../suite_FV3_GFS_cpld_rasmgshocnsst.xml | 2 +- gfsphysics/GFS_layer/GFS_diagnostics.F90 | 10 +-- gfsphysics/GFS_layer/GFS_typedefs.F90 | 4 +- io/FV3GFS_io.F90 | 73 +++++++++------ 10 files changed, 169 insertions(+), 58 deletions(-) create mode 100644 ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 8b59ebc03..2ec76f886 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 8b59ebc039dafe1c20ed6dd21cb38ca564852b98 +Subproject commit 2ec76f886450b1c58d2f7eb18f0553a1e77fb831 diff --git a/atmos_model.F90 b/atmos_model.F90 index 0499c3c56..81589c386 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -99,13 +99,13 @@ module atmos_model_mod IPD_interstitial => GFS_interstitial use IPD_driver, only: IPD_initialize, IPD_initialize_rst use CCPP_driver, only: CCPP_step, non_uniform_blocks + +use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper #else use IPD_driver, only: IPD_initialize, IPD_initialize_rst, IPD_step use physics_abstraction_layer, only: time_vary_step, radiation_step1, physics_step1, physics_step2 #endif -use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper - use FV3GFS_io_mod, only: FV3GFS_restart_read, FV3GFS_restart_write, & FV3GFS_IPD_checksum, & FV3GFS_diag_register, FV3GFS_diag_output, & @@ -291,16 +291,16 @@ subroutine update_atmos_radiation_physics (Atmos) #ifdef CCPP call CCPP_step (step="time_vary", nblks=Atm_block%nblks, ierr=ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP time_vary step failed') + +!--- call stochastic physics pattern generation / cellular automata + call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) + if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') + #else Func1d => time_vary_step call IPD_step (IPD_Control, IPD_Data(:), IPD_Diag, IPD_Restart, IPD_func1d=Func1d) #endif -!--- call stochastic physics pattern generation / cellular automata - call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) - if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') - - !--- if coupled, assign coupled fields if( IPD_Control%cplflx .or. IPD_Control%cplwav ) then @@ -625,14 +625,15 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step) #ifdef CCPP call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, & IPD_Interstitial, commglobal, mpp_npes(), Init_parm) -#else - call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) -#endif !--- Initialize stochastic physics pattern generation / cellular automata for first time step call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr) if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed') +#else + call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) +#endif + Atmos%Diag => IPD_Diag Atm(mygrid)%flagstruct%do_skeb = IPD_Control%do_skeb diff --git a/ccpp/CMakeLists.txt b/ccpp/CMakeLists.txt index b1395b23b..750ae5c14 100644 --- a/ccpp/CMakeLists.txt +++ b/ccpp/CMakeLists.txt @@ -120,11 +120,13 @@ elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel") endif (LEGACY_INTEL) elseif (${CMAKE_BUILD_TYPE} MATCHES "Release") # Specify aggressive optimization flags (to be overwritten for individual files in ccpp-physics' CMakeLists.txt) - if (SIMDMULTIARCH) - set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -axSSE4.2,AVX,CORE-AVX2,CORE-AVX512") - else (SIMDMULTIARCH) - set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -xCORE-AVX2") - endif (SIMDMULTIARCH) + if (AVX2) + if (SIMDMULTIARCH) + set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -axSSE4.2,AVX,CORE-AVX2,CORE-AVX512") + else (SIMDMULTIARCH) + set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -xCORE-AVX2") + endif (SIMDMULTIARCH) + endif (AVX2) set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -debug minimal -fp-model source -qoverride-limits -qopt-prefetch=3") endif (${CMAKE_BUILD_TYPE} MATCHES "Debug") set (CMAKE_Fortran_FLAGS_DEFAULT_PREC "-i4 -real-size 64") diff --git a/ccpp/driver/CCPP_driver.F90 b/ccpp/driver/CCPP_driver.F90 index 8e45d9382..89c41672f 100644 --- a/ccpp/driver/CCPP_driver.F90 +++ b/ccpp/driver/CCPP_driver.F90 @@ -93,7 +93,7 @@ subroutine CCPP_step (step, nblks, ierr) end do end do - else if (trim(step)=="physics_init") then + else if (trim(step)=="physics_init") then ! Since the physics init steps are independent of the blocking structure, ! we can use cdata_domain here. Since we don't use threading on the outside, @@ -107,7 +107,7 @@ subroutine CCPP_step (step, nblks, ierr) return end if - else if (trim(step)=="time_vary") then + else if (trim(step)=="time_vary") then ! Since the time_vary steps only use data structures for all blocks (except the ! CCPP-internal variables ccpp_error_flag and ccpp_error_message, which are defined @@ -123,8 +123,8 @@ subroutine CCPP_step (step, nblks, ierr) return end if - ! Radiation and stochastic physics - else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then + ! Radiation and stochastic physics + else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then ! Set number of threads available to physics schemes to one, ! because threads are used on the outside for blocking @@ -162,8 +162,8 @@ subroutine CCPP_step (step, nblks, ierr) !$OMP end parallel if (ierr/=0) return - ! Finalize - else if (trim(step)=="finalize") then + ! Finalize + else if (trim(step)=="finalize") then ! Loop over blocks, don't use threading on the outside but allowing threading ! inside the finalization, similar to what is done for the initialization diff --git a/ccpp/physics b/ccpp/physics index f91d1bfde..6f12e1482 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit f91d1bfde0bcdf69a8efe0917f49a4713e590bef +Subproject commit 6f12e1482f7f1b2f99d9b6019d94486840c923c8 diff --git a/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml b/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml new file mode 100644 index 000000000..1aa7ca484 --- /dev/null +++ b/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml @@ -0,0 +1,89 @@ + + + + + + + GFS_time_vary_pre + GFS_rrtmg_setup + GFS_rad_time_vary + GFS_phys_time_vary + + + + + GFS_suite_interstitial_rad_reset + GFS_rrtmg_pre + rrtmg_sw_pre + rrtmg_sw + rrtmg_sw_post + rrtmg_lw_pre + rrtmg_lw + rrtmg_lw_post + GFS_rrtmg_post + + + + + GFS_suite_interstitial_phys_reset + GFS_suite_stateout_reset + get_prs_fv3 + GFS_suite_interstitial_1 + GFS_surface_generic_pre + GFS_surface_composites_pre + dcyc2t3 + GFS_surface_composites_inter + GFS_suite_interstitial_2 + + + + sfc_diff + GFS_surface_loop_control_part1 + lsm_noah + sfc_nst_pre + sfc_nst + sfc_nst_post + sfc_cice + sfc_sice + GFS_surface_loop_control_part2 + + + + GFS_surface_composites_post + sfc_diag + sfc_diag_post + GFS_surface_generic_post + GFS_PBL_generic_pre + hedmf + GFS_PBL_generic_post + GFS_GWD_generic_pre + cires_ugwp + cires_ugwp_post + GFS_GWD_generic_post + rayleigh_damp + GFS_suite_stateout_update + ozphys + get_phi_fv3 + GFS_suite_interstitial_3 + GFS_DCNV_generic_pre + samfdeepcnv + GFS_DCNV_generic_post + GFS_SCNV_generic_pre + samfshalcnv + GFS_SCNV_generic_post + GFS_suite_interstitial_4 + cnvc90 + GFS_MP_generic_pre + zhaocarr_gscond + zhaocarr_precpd + GFS_MP_generic_post + maximum_hourly_diagnostics + + + + + GFS_stochastics + + + + diff --git a/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml index 5b3b63528..a08956dfa 100644 --- a/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml +++ b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml @@ -1,6 +1,6 @@ - + diff --git a/gfsphysics/GFS_layer/GFS_diagnostics.F90 b/gfsphysics/GFS_layer/GFS_diagnostics.F90 index 1b6fabe96..adb624cca 100644 --- a/gfsphysics/GFS_layer/GFS_diagnostics.F90 +++ b/gfsphysics/GFS_layer/GFS_diagnostics.F90 @@ -2445,7 +2445,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%name = 'dt3dt_nophys' ExtDiag(idx)%desc = 'temperature tendency due to non-physics processes' ExtDiag(idx)%unit = 'K s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' + ExtDiag(idx)%mod_name = 'gfs_dyn' ExtDiag(idx)%time_avg = .TRUE. allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks @@ -2626,7 +2626,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%name = 'du3dt_nophys' ExtDiag(idx)%desc = 'u momentum tendency due to non-physics processes' ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' + ExtDiag(idx)%mod_name = 'gfs_dyn' ExtDiag(idx)%time_avg = .TRUE. allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks @@ -2638,7 +2638,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%name = 'dv3dt_nophys' ExtDiag(idx)%desc = 'v momentum tendency due to non-physics processes' ExtDiag(idx)%unit = 'm s-2' - ExtDiag(idx)%mod_name = 'gfs_phys' + ExtDiag(idx)%mod_name = 'gfs_dyn' ExtDiag(idx)%time_avg = .TRUE. allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks @@ -2785,7 +2785,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%name = 'dq3dt_nophys' ExtDiag(idx)%desc = 'water vapor specific humidity tendency due to non-physics processes' ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' + ExtDiag(idx)%mod_name = 'gfs_dyn' ExtDiag(idx)%time_avg = .TRUE. allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks @@ -2797,7 +2797,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop ExtDiag(idx)%name = 'dq3dt_o3nophys' ExtDiag(idx)%desc = 'ozone concentration tendency due to non-physics processes' ExtDiag(idx)%unit = 'kg kg-1 s-1' - ExtDiag(idx)%mod_name = 'gfs_phys' + ExtDiag(idx)%mod_name = 'gfs_dyn' ExtDiag(idx)%time_avg = .TRUE. allocate (ExtDiag(idx)%data(nblks)) do nb = 1,nblks diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90 index 67d8a7668..5fecfbfff 100644 --- a/gfsphysics/GFS_layer/GFS_typedefs.F90 +++ b/gfsphysics/GFS_layer/GFS_typedefs.F90 @@ -1551,9 +1551,9 @@ module GFS_typedefs #ifdef CCPP real (kind=kind_phys), pointer :: TRAIN (:,:) => null() !< accumulated stratiform T tendency (K s-1) #endif -#ifdef CCPP +!#ifdef CCPP real (kind=kind_phys), pointer :: cldfra (:,:) => null() !< instantaneous 3D cloud fraction -#endif +!#endif !--- MP quantities for 3D diagnositics real (kind=kind_phys), pointer :: refl_10cm(:,:) => null() !< instantaneous refl_10cm ! diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index e0898c3f6..458605c96 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -1077,16 +1077,16 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) if (Sfcprop(nb)%lakefrac(ix) > zero) then Sfcprop(nb)%oceanfrac(ix) = zero ! lake & ocean don't coexist in a cell - if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) then - Sfcprop(nb)%fice(ix) = zero - if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 - endif +! if (Sfcprop(nb)%fice(ix) < Model%min_lakeice) then +! Sfcprop(nb)%fice(ix) = zero +! if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 +! endif else Sfcprop(nb)%oceanfrac(ix) = one - Sfcprop(nb)%landfrac(ix) - if (Sfcprop(nb)%fice(ix) < Model%min_seaice) then - Sfcprop(nb)%fice(ix) = zero - if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 - endif +! if (Sfcprop(nb)%fice(ix) < Model%min_seaice) then +! Sfcprop(nb)%fice(ix) = zero +! if (Sfcprop(nb)%slmsk(ix) == 2) Sfcprop(nb)%slmsk(ix) = 0 +! endif endif ! !--- NSSTM variables @@ -1357,28 +1357,47 @@ subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) enddo enddo else + if( Model%phour < 1.e-7) then !$omp parallel do default(shared) private(nb, ix, tem) - do nb = 1, Atm_block%nblks - do ix = 1, Atm_block%blksz(nb) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) !--- specify tsfcl/zorll/zorli from existing variable tsfco/zorlo -! Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) -! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) -! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) -! Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) -! Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) - if (Sfcprop(nb)%slmsk(ix) == 1) then - Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) - Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) - else - tem = one - Sfcprop(nb)%fice(ix) - Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & - + Sfcprop(nb)%zorlo(ix) * tem - - Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & - + Sfcprop(nb)%tsfco(ix) * tem - endif +! Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) +! Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorli(ix) = Sfcprop(nb)%zorlo(ix) +! Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) + if (Sfcprop(nb)%slmsk(ix) == 1) then + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + else + tem = one - Sfcprop(nb)%fice(ix) + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%zorlo(ix) * tem + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%tsfco(ix) * tem + endif + enddo enddo - enddo + else +!$omp parallel do default(shared) private(nb, ix, tem) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + !--- specify tsfcl/zorll/zorli from existing variable tsfco/zorlo + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) + if (Sfcprop(nb)%slmsk(ix) == 1) then + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + else + tem = one - Sfcprop(nb)%fice(ix) + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%zorlo(ix) * tem + if (Sfcprop(nb)%fice(ix) > min(Model%min_seaice,Model%min_lakeice)) then + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) + endif + endif + enddo + enddo + endif endif ! if (Model%frac_grid) !#ifdef CCPP From 39fcfe1bbbe1ac4a3162107cbafcea62433a8102 Mon Sep 17 00:00:00 2001 From: Dom Heinzeller Date: Fri, 2 Oct 2020 08:45:21 -0600 Subject: [PATCH 13/13] Revert changes to .gitmodules and update submodule pointer for GFDL_atmos_cubed_sphere, ccpp-framework and ccpp-physics --- .gitmodules | 18 ++++++------------ atmos_cubed_sphere | 2 +- ccpp/framework | 2 +- ccpp/physics | 2 +- 4 files changed, 9 insertions(+), 15 deletions(-) diff --git a/.gitmodules b/.gitmodules index 73d426c1c..bdc0ffbf1 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,18 +1,12 @@ [submodule "atmos_cubed_sphere"] path = atmos_cubed_sphere - #url = https://github.com/NOAA-GSD/GFDL_atmos_cubed_sphere - #branch = gsd/develop - url = https://github.com/climbfuji/GFDL_atmos_cubed_sphere - branch = update_gsd_develop_from_master_20201001 + url = https://github.com/NOAA-GSD/GFDL_atmos_cubed_sphere + branch = gsd/develop [submodule "ccpp/framework"] path = ccpp/framework - #url = https://github.com/NOAA-GSD/ccpp-framework - #branch = gsd/develop - url = https://github.com/climbfuji/ccpp-framework - branch = update_gsd_develop_from_master_20200903 + url = https://github.com/NOAA-GSD/ccpp-framework + branch = gsd/develop [submodule "ccpp/physics"] path = ccpp/physics - #url = https://github.com/NOAA-GSD/ccpp-physics - #branch = gsd/develop - url = https://github.com/climbfuji/ccpp-physics - branch = update_gsd_develop_from_master_20200903 \ No newline at end of file + url = https://github.com/NOAA-GSD/ccpp-physics + branch = gsd/develop diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 7d52492c7..b446f3252 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 7d52492c7ea94d50afd9746a054b4ac608fedb54 +Subproject commit b446f3252c29e502fcb8090f57d844e329a31818 diff --git a/ccpp/framework b/ccpp/framework index e2b612a24..7b8df4baf 160000 --- a/ccpp/framework +++ b/ccpp/framework @@ -1 +1 @@ -Subproject commit e2b612a240ac9914ebbf66413796275e22d562ec +Subproject commit 7b8df4bafd592006f8445377ea9599e526714df4 diff --git a/ccpp/physics b/ccpp/physics index 27b1d58dd..9fae6f3ed 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit 27b1d58dd692482b5895b418c6b4f9133a5aed4b +Subproject commit 9fae6f3eda610f085f5dcebf657d20f73c9efb56