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