diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere
index e8896bc0f..b446f3252 160000
--- a/atmos_cubed_sphere
+++ b/atmos_cubed_sphere
@@ -1 +1 @@
-Subproject commit e8896bc0f582c7c825eaa198cbbb83c206a29d43
+Subproject commit b446f3252c29e502fcb8090f57d844e329a31818
diff --git a/atmos_model.F90 b/atmos_model.F90
index ec8e8a9a4..81589c386 100644
--- a/atmos_model.F90
+++ b/atmos_model.F90
@@ -99,13 +99,13 @@ module atmos_model_mod
IPD_interstitial => GFS_interstitial
use IPD_driver, only: IPD_initialize, IPD_initialize_rst
use CCPP_driver, only: CCPP_step, non_uniform_blocks
+
+use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper
#else
use IPD_driver, only: IPD_initialize, IPD_initialize_rst, IPD_step
use physics_abstraction_layer, only: time_vary_step, radiation_step1, physics_step1, physics_step2
#endif
-use stochastic_physics_wrapper_mod, only: stochastic_physics_wrapper
-
use FV3GFS_io_mod, only: FV3GFS_restart_read, FV3GFS_restart_write, &
FV3GFS_IPD_checksum, &
FV3GFS_diag_register, FV3GFS_diag_output, &
@@ -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
@@ -290,22 +291,29 @@ subroutine update_atmos_radiation_physics (Atmos)
#ifdef CCPP
call CCPP_step (step="time_vary", nblks=Atm_block%nblks, ierr=ierr)
if (ierr/=0) call mpp_error(FATAL, 'Call to CCPP time_vary step failed')
+
+!--- call stochastic physics pattern generation / cellular automata
+ call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr)
+ if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed')
+
#else
Func1d => time_vary_step
call IPD_step (IPD_Control, IPD_Data(:), IPD_Diag, IPD_Restart, IPD_func1d=Func1d)
#endif
-!--- call stochastic physics pattern generation / cellular automata
- call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block)
-
!--- 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
@@ -617,13 +625,15 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step)
#ifdef CCPP
call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, &
IPD_Interstitial, commglobal, mpp_npes(), Init_parm)
+
+!--- Initialize stochastic physics pattern generation / cellular automata for first time step
+ call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block, ierr)
+ if (ierr/=0) call mpp_error(FATAL, 'Call to stochastic_physics_wrapper failed')
+
#else
call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm)
#endif
-!--- Initialize stochastic physics pattern generation / cellular automata for first time step
- call stochastic_physics_wrapper(IPD_Control, IPD_Data, Atm_block)
-
Atmos%Diag => IPD_Diag
Atm(mygrid)%flagstruct%do_skeb = IPD_Control%do_skeb
@@ -682,8 +692,11 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step)
diag_time = Time - real_to_time_type(mod(int((first_kdt - 1)*dt_phys/3600.),6)*3600.0)
endif
if (Atmos%iau_offset > zero) then
- diag_time = Atmos%Time_init
- diag_time_fhzero = Atmos%Time
+ call get_time (Atmos%Time - Atmos%Time_init, sec)
+ if (sec < Atmos%iau_offset*3600) then
+ diag_time = Atmos%Time_init
+ diag_time_fhzero = Atmos%Time
+ endif
endif
!---- print version number to logfile ----
@@ -731,6 +744,15 @@ subroutine atmos_model_init (Atmos, Time_init, Time, Time_step)
fv3Clock = mpp_clock_id( 'FV3 Dycore ', flags=clock_flag_default, grain=CLOCK_COMPONENT )
endif
+!--- get bottom layer data from dynamical core for coupling
+ call atmosphere_get_bottom_layer (Atm_block, DYCORE_Data)
+
+ !if in coupled mode, set up coupled fields
+ if (IPD_Control%cplflx .or. IPD_Control%cplwav) then
+ if (mpp_pe() == mpp_root_pe()) print *,'COUPLING: IPD layer'
+ call setup_exportdata(ierr)
+ endif
+
#ifdef CCPP
! Set flag for first time step of time integration
IPD_Control%first_time_step = .true.
@@ -881,7 +903,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
@@ -899,8 +921,6 @@ subroutine update_atmos_model_state (Atmos)
!if in coupled mode, set up coupled fields
if (IPD_Control%cplflx .or. IPD_Control%cplwav) then
-! if (mpp_pe() == mpp_root_pe()) print *,'COUPLING: IPD layer'
-!jw call setup_exportdata(IPD_Control, IPD_Data, Atm_block)
call setup_exportdata(rc)
endif
@@ -1177,6 +1197,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 +1212,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 +1611,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 +1636,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 +1693,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 +1718,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 +1732,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 +1754,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 +1904,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 +1948,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 +1974,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 +1993,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
@@ -1977,7 +2024,7 @@ subroutine setup_exportdata (rc)
integer :: j, i, ix, nb, isc, iec, jsc, jec, idx
real(IPD_kind_phys) :: rtime, rtimek
!
-! if (mpp_pe() == mpp_root_pe()) print *,'enter setup_exportdata'
+ if (mpp_pe() == mpp_root_pe()) print *,'enter setup_exportdata'
isc = IPD_control%isc
iec = IPD_control%isc+IPD_control%nx-1
@@ -2540,6 +2587,7 @@ subroutine setup_exportdata (rc)
! bottom layer temperature (t)
idx = queryfieldlist(exportFieldsList,'inst_temp_height_lowest')
+ if (mpp_pe() == mpp_root_pe()) print *,'cpl, in get inst_temp_height_lowest'
if (idx > 0 ) then
!$omp parallel do default(shared) private(i,j,nb,ix)
do j=jsc,jec
@@ -2553,6 +2601,7 @@ subroutine setup_exportdata (rc)
endif
enddo
enddo
+ if (mpp_pe() == mpp_root_pe()) print *,'cpl, in get inst_temp_height_lowest=',exportData(isc,jsc,idx)
endif
! bottom layer specific humidity (q)
@@ -2689,7 +2738,7 @@ subroutine setup_exportdata (rc)
IPD_Data(nb)%coupling%snow_cpl(ix) = zero
enddo
enddo
- if (mpp_pe() == mpp_root_pe()) print *,'zeroing coupling fields at kdt= ',IPD_Control%kdt
+ if (mpp_pe() == mpp_root_pe()) print *,'zeroing coupling accumulated fields at kdt= ',IPD_Control%kdt
endif !cplflx
! if (mpp_pe() == mpp_root_pe()) print *,'end of setup_exportdata'
diff --git a/ccpp/CMakeLists.txt b/ccpp/CMakeLists.txt
index dd1c317e4..750ae5c14 100644
--- a/ccpp/CMakeLists.txt
+++ b/ccpp/CMakeLists.txt
@@ -82,11 +82,12 @@ set (CMAKE_Fortran_FLAGS_OPT "")
if (${CMAKE_Fortran_COMPILER_ID} MATCHES "GNU")
set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fcray-pointer -ffree-line-length-none -fno-range-check")
set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fbacktrace -cpp")
+ if(${CMAKE_Fortran_COMPILER_VERSION} VERSION_GREATER_EQUAL 10)
+ set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fallow-argument-mismatch")
+ endif()
if (${CMAKE_BUILD_TYPE} MATCHES "Debug")
- set (CMAKE_C_FLAGS "${CMAKE_C_FLAGS} -Wall")
- set (CMAKE_CXX_FLAGS "${CMAKE_CXX_FLAGS} -Wall")
set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fno-unsafe-math-optimizations -frounding-math -fsignaling-nans")
- set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffpe-trap=invalid,zero,overflow -fcheck=bounds -fbacktrace -fno-range-check -Wall")
+ set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -ffpe-trap=invalid,zero,overflow -fcheck=bounds -fbacktrace -fno-range-check")
elseif (${CMAKE_BUILD_TYPE} MATCHES "Bitforbit")
set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS}")
endif (${CMAKE_BUILD_TYPE} MATCHES "Debug")
@@ -119,11 +120,13 @@ elseif (${CMAKE_Fortran_COMPILER_ID} MATCHES "Intel")
endif (LEGACY_INTEL)
elseif (${CMAKE_BUILD_TYPE} MATCHES "Release")
# Specify aggressive optimization flags (to be overwritten for individual files in ccpp-physics' CMakeLists.txt)
- if (SIMDMULTIARCH)
- set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -axSSE4.2,AVX,CORE-AVX2,CORE-AVX512")
- else (SIMDMULTIARCH)
- set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -xCORE-AVX2")
- endif (SIMDMULTIARCH)
+ if (AVX2)
+ if (SIMDMULTIARCH)
+ set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -axSSE4.2,AVX,CORE-AVX2,CORE-AVX512")
+ else (SIMDMULTIARCH)
+ set (CMAKE_Fortran_FLAGS_OPT "-no-prec-div -no-prec-sqrt -xCORE-AVX2")
+ endif (SIMDMULTIARCH)
+ endif (AVX2)
set (CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -debug minimal -fp-model source -qoverride-limits -qopt-prefetch=3")
endif (${CMAKE_BUILD_TYPE} MATCHES "Debug")
set (CMAKE_Fortran_FLAGS_DEFAULT_PREC "-i4 -real-size 64")
diff --git a/ccpp/config/ccpp_prebuild_config.py b/ccpp/config/ccpp_prebuild_config.py
index 2c0da61da..daabe2df6 100755
--- a/ccpp/config/ccpp_prebuild_config.py
+++ b/ccpp/config/ccpp_prebuild_config.py
@@ -11,8 +11,10 @@
# Add all files with metadata tables on the host model side and in CCPP,
# relative to basedir = top-level directory of host model. This includes
-# kind and type definitions used in CCPP physics.
+# kind and type definitions used in CCPP physics. Also add any internal
+# dependencies of these files to the list.
VARIABLE_DEFINITION_FILES = [
+ # actual variable definition files
'FV3/ccpp/physics/physics/machine.F',
'FV3/ccpp/physics/physics/radsw_param.f',
'FV3/ccpp/physics/physics/radlw_param.f',
@@ -85,128 +87,6 @@
},
}
-# Add all physics scheme dependencies relative to basedir - note that the CCPP
-# rules stipulate that dependencies are not shared between the schemes!
-SCHEME_FILES_DEPENDENCIES = [
- 'FV3/ccpp/physics/physics/GFDL_parse_tracers.F90',
- 'FV3/ccpp/physics/physics/aer_cloud.F',
- 'FV3/ccpp/physics/physics/aerclm_def.F',
- 'FV3/ccpp/physics/physics/aerinterp.F90',
- 'FV3/ccpp/physics/physics/calpreciptype.f90',
- 'FV3/ccpp/physics/physics/cldwat2m_micro.F',
- 'FV3/ccpp/physics/physics/cldmacro.F',
- 'FV3/ccpp/physics/physics/date_def.f',
- 'FV3/ccpp/physics/physics/funcphys.f90',
- 'FV3/ccpp/physics/physics/gcycle.F90',
- 'FV3/ccpp/physics/physics/gfs_phy_tracer_config.F',
- 'FV3/ccpp/physics/physics/gocart_tracer_config_stub.f',
- 'FV3/ccpp/physics/physics/h2o_def.f',
- 'FV3/ccpp/physics/physics/h2ointerp.f90',
- 'FV3/ccpp/physics/physics/iccn_def.F',
- 'FV3/ccpp/physics/physics/iccninterp.F90',
- 'FV3/ccpp/physics/physics/iounitdef.f',
- 'FV3/ccpp/physics/physics/machine.F',
- 'FV3/ccpp/physics/physics/mersenne_twister.f',
- 'FV3/ccpp/physics/physics/mfpbl.f',
- 'FV3/ccpp/physics/physics/micro_mg_utils.F90',
- 'FV3/ccpp/physics/physics/micro_mg2_0.F90',
- 'FV3/ccpp/physics/physics/micro_mg3_0.F90',
- 'FV3/ccpp/physics/physics/module_bfmicrophysics.f',
- 'FV3/ccpp/physics/physics/multi_gases.F90',
- 'FV3/ccpp/physics/physics/module_gfdl_cloud_microphys.F90',
- 'FV3/ccpp/physics/physics/module_nst_model.f90',
- 'FV3/ccpp/physics/physics/module_nst_parameters.f90',
- 'FV3/ccpp/physics/physics/module_nst_water_prop.f90',
- 'FV3/ccpp/physics/physics/module_mp_radar.F90',
- 'FV3/ccpp/physics/physics/module_mp_thompson.F90',
- 'FV3/ccpp/physics/physics/module_mp_thompson_make_number_concentrations.F90',
- 'FV3/ccpp/physics/physics/module_MP_FER_HIRES.F90',
- 'FV3/ccpp/physics/physics/module_bl_mynn.F90',
- 'FV3/ccpp/physics/physics/module_sf_mynn.F90',
- 'FV3/ccpp/physics/physics/module_SF_JSFC.F90',
- 'FV3/ccpp/physics/physics/module_BL_MYJPBL.F90',
- 'FV3/ccpp/physics/physics/module_sf_noahmp_glacier.f90',
- 'FV3/ccpp/physics/physics/module_sf_noahmplsm.f90',
- 'FV3/ccpp/physics/physics/cires_ugwp_module.F90',
- 'FV3/ccpp/physics/physics/ugwp_driver_v0.F',
- 'FV3/ccpp/physics/physics/cires_ugwp_triggers.F90',
- 'FV3/ccpp/physics/physics/cires_ugwp_initialize.F90',
- 'FV3/ccpp/physics/physics/cires_ugwp_solvers.F90',
- 'FV3/ccpp/physics/physics/cires_ugwp_utils.F90',
- 'FV3/ccpp/physics/physics/cires_orowam2017.f',
- 'FV3/ccpp/physics/physics/cires_vert_lsatdis.F90',
- 'FV3/ccpp/physics/physics/cires_vert_orodis.F90',
- 'FV3/ccpp/physics/physics/cires_vert_wmsdis.F90',
- 'FV3/ccpp/physics/physics/namelist_soilveg.f',
- 'FV3/ccpp/physics/physics/mfpblt.f',
- 'FV3/ccpp/physics/physics/mfpbltq.f',
- 'FV3/ccpp/physics/physics/mfscu.f',
- 'FV3/ccpp/physics/physics/mfscuq.f',
- 'FV3/ccpp/physics/physics/noahmp_tables.f90',
- 'FV3/ccpp/physics/physics/num_parthds.F',
- 'FV3/ccpp/physics/physics/ozne_def.f',
- 'FV3/ccpp/physics/physics/ozinterp.f90',
- 'FV3/ccpp/physics/physics/physcons.F90',
- 'FV3/ccpp/physics/physics/physparam.f',
- 'FV3/ccpp/physics/physics/radcons.f90',
- 'FV3/ccpp/physics/physics/radiation_aerosols.f',
- 'FV3/ccpp/physics/physics/radiation_astronomy.f',
- 'FV3/ccpp/physics/physics/radiation_clouds.f',
- 'FV3/ccpp/physics/physics/radiation_gases.f',
- 'FV3/ccpp/physics/physics/radiation_surface.f',
- 'FV3/ccpp/physics/physics/radlw_datatb.f',
- 'FV3/ccpp/physics/physics/radlw_param.f',
- 'FV3/ccpp/physics/physics/radsw_datatb.f',
- 'FV3/ccpp/physics/physics/radsw_param.f',
- 'FV3/ccpp/physics/physics/samfaerosols.F',
- 'FV3/ccpp/physics/physics/sfcsub.F',
- 'FV3/ccpp/physics/physics/sflx.f',
- 'FV3/ccpp/physics/physics/set_soilveg.f',
- 'FV3/ccpp/physics/physics/flake.F90',
- 'FV3/ccpp/physics/physics/surface_perturbation.F90',
- 'FV3/ccpp/physics/physics/cu_gf_deep.F90',
- 'FV3/ccpp/physics/physics/cu_gf_sh.F90',
- 'FV3/ccpp/physics/physics/tridi.f',
- 'FV3/ccpp/physics/physics/wv_saturation.F',
- 'FV3/ccpp/physics/physics/module_sf_ruclsm.F90',
- 'FV3/ccpp/physics/physics/namelist_soilveg_ruc.F90',
- 'FV3/ccpp/physics/physics/set_soilveg_ruc.F90',
- 'FV3/ccpp/physics/physics/module_soil_pre.F90',
- # RRTMGP
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_gas_optics.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_constants.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_reorder.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/mo_rrtmgp_util_string.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/kernels/mo_gas_optics_kernels.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rrtmgp/kernels/mo_rrtmgp_util_reorder_kernels.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_fluxes.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_util_array.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_optical_props.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_kind.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_lw.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_sw.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_rte_config.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/mo_source_functions.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/kernels/mo_fluxes_broadband_kernels.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/kernels/mo_optical_props_kernels.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/rte/kernels/mo_rte_solver_kernels.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_compute_bc.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_fluxes_byband.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_fluxes_byband_kernels.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_fluxes_bygpoint.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_heating_rates.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/mo_rrtmgp_clr_all_sky.F90',
- 'FV3/ccpp/physics/physics/rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90',
- 'FV3/ccpp/physics/physics/rrtmg_lw_cloud_optics.F90' ,
- 'FV3/ccpp/physics/physics/rrtmg_sw_cloud_optics.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_aux.F90' ,
- # derived data type definitions
- 'FV3/gfsphysics/GFS_layer/GFS_typedefs.F90',
- 'FV3/gfsphysics/CCPP_layer/CCPP_typedefs.F90',
- ]
-
# Add all physics scheme files relative to basedir
SCHEME_FILES = [
# Relative path to source (from where ccpp_prebuild.py is called) : [ list of physics sets in which scheme may be called ];
@@ -301,25 +181,24 @@
# HAFSFER_HIRES
'FV3/ccpp/physics/physics/mp_fer_hires.F90',
# RRTMGP
- 'FV3/ccpp/physics/physics/rrtmgp_lw_gas_optics.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_lw_cloud_optics.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_sw_gas_optics.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_sw_cloud_optics.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_sw_aerosol_optics.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_lw_rte.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_sw_rte.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_lw_aerosol_optics.F90' ,
- 'FV3/ccpp/physics/physics/GFS_rrtmgp_setup.F90' ,
- 'FV3/ccpp/physics/physics/GFS_rrtmgp_pre.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_lw_pre.F90' ,
- 'FV3/ccpp/physics/physics/GFS_rrtmgp_sw_pre.F90' ,
- 'FV3/ccpp/physics/physics/GFS_rrtmgp_lw_post.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_lw_cloud_sampling.F90' ,
- 'FV3/ccpp/physics/physics/rrtmgp_sw_cloud_sampling.F90' ,
- 'FV3/ccpp/physics/physics/GFS_cloud_diagnostics.F90' ,
- 'FV3/ccpp/physics/physics/mo_cloud_sampling.F90' ,
- 'FV3/ccpp/physics/physics/GFS_rrtmgp_gfdlmp_pre.F90' ,
- 'FV3/ccpp/physics/physics/GFS_rrtmgp_zhaocarr_pre.F90' ,
+ 'FV3/ccpp/physics/physics/rrtmgp_lw_gas_optics.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_lw_cloud_optics.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_sw_gas_optics.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_sw_cloud_optics.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_sw_aerosol_optics.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_lw_rte.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_sw_rte.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_lw_aerosol_optics.F90',
+ 'FV3/ccpp/physics/physics/GFS_rrtmgp_setup.F90',
+ 'FV3/ccpp/physics/physics/GFS_rrtmgp_pre.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_lw_pre.F90',
+ 'FV3/ccpp/physics/physics/GFS_rrtmgp_sw_pre.F90',
+ 'FV3/ccpp/physics/physics/GFS_rrtmgp_lw_post.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_lw_cloud_sampling.F90',
+ 'FV3/ccpp/physics/physics/rrtmgp_sw_cloud_sampling.F90',
+ 'FV3/ccpp/physics/physics/GFS_cloud_diagnostics.F90',
+ 'FV3/ccpp/physics/physics/GFS_rrtmgp_gfdlmp_pre.F90',
+ 'FV3/ccpp/physics/physics/GFS_rrtmgp_zhaocarr_pre.F90',
'FV3/ccpp/physics/physics/GFS_rrtmgp_sw_post.F90'
]
@@ -337,13 +216,6 @@
SCHEMES_CMAKEFILE = '{build_dir}/ccpp/physics/CCPP_SCHEMES.cmake'
SCHEMES_SOURCEFILE = '{build_dir}/ccpp/physics/CCPP_SCHEMES.sh'
-# CCPP host cap in which to insert the ccpp_field_add statements;
-# determines the directory to place ccpp_{modules,fields}.inc
-TARGET_FILES = [
- 'FV3/atmos_cubed_sphere/driver/fvGFS/atmosphere.F90',
- 'FV3/ccpp/driver/CCPP_Driver.F90',
- ]
-
# Auto-generated makefile/cmakefile snippets that contain all caps
CAPS_MAKEFILE = '{build_dir}/ccpp/physics/CCPP_CAPS.mk'
CAPS_CMAKEFILE = '{build_dir}/ccpp/physics/CCPP_CAPS.cmake'
@@ -454,12 +326,6 @@
#'subroutine_name_2' : [ 'var1', 'var3'],
}
-# Names of Fortran include files in the host model cap (do not change);
-# both files will be written to the directory of each target file, only
-# used by the dynamic builds
-MODULE_INCLUDE_FILE = 'ccpp_modules_{set}.inc'
-FIELDS_INCLUDE_FILE = 'ccpp_fields_{set}.inc'
-
# Directory where to write static API to
STATIC_API_DIR = '{build_dir}/ccpp/physics'
STATIC_API_SRCFILE = '{build_dir}/ccpp/physics/CCPP_STATIC_API.sh'
@@ -472,17 +338,3 @@
# LaTeX document containing the provided vs requested CCPP variables
LATEX_VARTABLE_FILE = '{build_dir}/ccpp/framework/doc/DevelopersGuide/CCPP_VARIABLES_FV3.tex'
-
-
-###############################################################################
-# Template code to generate include files #
-###############################################################################
-
-# Name of the CCPP data structure in the host model cap;
-# in the case of FV3, this is a 2-dimensional array with
-# the number of blocks as the first and the number of
-# OpenMP threads as the second dimension; nb is the loop
-# index for the current block, nt for the current thread.
-# Internally, the model uses an associate construct to
-# reference cdata(nb,nt) with cdata (recommended).
-CCPP_DATA_STRUCTURE = 'cdata'
diff --git a/ccpp/driver/CCPP_driver.F90 b/ccpp/driver/CCPP_driver.F90
index 8e45d9382..89c41672f 100644
--- a/ccpp/driver/CCPP_driver.F90
+++ b/ccpp/driver/CCPP_driver.F90
@@ -93,7 +93,7 @@ subroutine CCPP_step (step, nblks, ierr)
end do
end do
- else if (trim(step)=="physics_init") then
+ else if (trim(step)=="physics_init") then
! Since the physics init steps are independent of the blocking structure,
! we can use cdata_domain here. Since we don't use threading on the outside,
@@ -107,7 +107,7 @@ subroutine CCPP_step (step, nblks, ierr)
return
end if
- else if (trim(step)=="time_vary") then
+ else if (trim(step)=="time_vary") then
! Since the time_vary steps only use data structures for all blocks (except the
! CCPP-internal variables ccpp_error_flag and ccpp_error_message, which are defined
@@ -123,8 +123,8 @@ subroutine CCPP_step (step, nblks, ierr)
return
end if
- ! Radiation and stochastic physics
- else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then
+ ! Radiation and stochastic physics
+ else if (trim(step)=="radiation" .or. trim(step)=="physics" .or. trim(step)=="stochastics") then
! Set number of threads available to physics schemes to one,
! because threads are used on the outside for blocking
@@ -162,8 +162,8 @@ subroutine CCPP_step (step, nblks, ierr)
!$OMP end parallel
if (ierr/=0) return
- ! Finalize
- else if (trim(step)=="finalize") then
+ ! Finalize
+ else if (trim(step)=="finalize") then
! Loop over blocks, don't use threading on the outside but allowing threading
! inside the finalization, similar to what is done for the initialization
diff --git a/ccpp/framework b/ccpp/framework
index 0b84becf3..7b8df4baf 160000
--- a/ccpp/framework
+++ b/ccpp/framework
@@ -1 +1 @@
-Subproject commit 0b84becf3ca7f541b37fc9cf8d11a45aa2b14407
+Subproject commit 7b8df4bafd592006f8445377ea9599e526714df4
diff --git a/ccpp/physics b/ccpp/physics
index e424f0ac6..9fae6f3ed 160000
--- a/ccpp/physics
+++ b/ccpp/physics
@@ -1 +1 @@
-Subproject commit e424f0ac6e480c08d72653c6f5bfa0063f41b4f0
+Subproject commit 9fae6f3eda610f085f5dcebf657d20f73c9efb56
diff --git a/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml b/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml
new file mode 100644
index 000000000..1aa7ca484
--- /dev/null
+++ b/ccpp/suites/suite_FV3_GFS_2017_couplednsst.xml
@@ -0,0 +1,89 @@
+
+
+
+
+
+
+ GFS_time_vary_pre
+ GFS_rrtmg_setup
+ GFS_rad_time_vary
+ GFS_phys_time_vary
+
+
+
+
+ GFS_suite_interstitial_rad_reset
+ GFS_rrtmg_pre
+ rrtmg_sw_pre
+ rrtmg_sw
+ rrtmg_sw_post
+ rrtmg_lw_pre
+ rrtmg_lw
+ rrtmg_lw_post
+ GFS_rrtmg_post
+
+
+
+
+ GFS_suite_interstitial_phys_reset
+ GFS_suite_stateout_reset
+ get_prs_fv3
+ GFS_suite_interstitial_1
+ GFS_surface_generic_pre
+ GFS_surface_composites_pre
+ dcyc2t3
+ GFS_surface_composites_inter
+ GFS_suite_interstitial_2
+
+
+
+ sfc_diff
+ GFS_surface_loop_control_part1
+ lsm_noah
+ sfc_nst_pre
+ sfc_nst
+ sfc_nst_post
+ sfc_cice
+ sfc_sice
+ GFS_surface_loop_control_part2
+
+
+
+ GFS_surface_composites_post
+ sfc_diag
+ sfc_diag_post
+ GFS_surface_generic_post
+ GFS_PBL_generic_pre
+ hedmf
+ GFS_PBL_generic_post
+ GFS_GWD_generic_pre
+ cires_ugwp
+ cires_ugwp_post
+ GFS_GWD_generic_post
+ rayleigh_damp
+ GFS_suite_stateout_update
+ ozphys
+ get_phi_fv3
+ GFS_suite_interstitial_3
+ GFS_DCNV_generic_pre
+ samfdeepcnv
+ GFS_DCNV_generic_post
+ GFS_SCNV_generic_pre
+ samfshalcnv
+ GFS_SCNV_generic_post
+ GFS_suite_interstitial_4
+ cnvc90
+ GFS_MP_generic_pre
+ zhaocarr_gscond
+ zhaocarr_precpd
+ GFS_MP_generic_post
+ maximum_hourly_diagnostics
+
+
+
+
+ GFS_stochastics
+
+
+
+
diff --git a/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml b/ccpp/suites/suite_FV3_GFS_cpld_rasmgshocnsst.xml
new file mode 100644
index 000000000..a08956dfa
--- /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/ccpp/suites/suite_FV3_RRFS_v1beta.xml b/ccpp/suites/suite_FV3_RRFS_v1beta.xml
index 3bff7b39d..c570483df 100644
--- a/ccpp/suites/suite_FV3_RRFS_v1beta.xml
+++ b/ccpp/suites/suite_FV3_RRFS_v1beta.xml
@@ -56,7 +56,8 @@
GFS_surface_generic_post
mynnedmf_wrapper
GFS_GWD_generic_pre
- drag_suite
+ cires_ugwp
+ cires_ugwp_post
GFS_GWD_generic_post
rayleigh_damp
GFS_suite_stateout_update
diff --git a/cpl/module_cap_cpl.F90 b/cpl/module_cap_cpl.F90
index 82980612b..f5427c791 100644
--- a/cpl/module_cap_cpl.F90
+++ b/cpl/module_cap_cpl.F90
@@ -13,7 +13,7 @@ module module_cap_cpl
public clock_cplIntval
public realizeConnectedInternCplField
public realizeConnectedCplFields
- public Dump_cplFields
+ public diagnose_cplFields
!
contains
@@ -193,9 +193,11 @@ subroutine realizeConnectedCplFields(state, grid,
end select
call NUOPC_Realize(state, field=field, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
! -- zero out field
call ESMF_FieldFill(field, dataFillScheme="const", const1=0._ESMF_KIND_R8, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
! -- save field
fieldList(item) = field
call ESMF_LogWrite('realizeConnectedCplFields '//trim(state_tag)//' Field '//trim(fieldNames(item)) &
@@ -213,13 +215,14 @@ end subroutine realizeConnectedCplFields
!-----------------------------------------------------------------------------
- subroutine Dump_cplFields(gcomp, importState, exportstate, clock_fv3, &
- statewrite_flag, state_tag, timestr)
+ subroutine diagnose_cplFields(gcomp, importState, exportstate, clock_fv3, &
+ statewrite_flag, stdiagnose_flag, state_tag, timestr)
type(ESMF_GridComp), intent(in) :: gcomp
type(ESMF_State) :: importState, exportstate
type(ESMF_Clock),intent(in) :: clock_fv3
logical, intent(in) :: statewrite_flag
+ integer, intent(in) :: stdiagnose_flag
character(len=*), intent(in) :: state_tag !< Import or export.
character(len=*), intent(in) :: timestr !< Import or export.
integer :: timeslice = 1
@@ -241,32 +244,39 @@ subroutine Dump_cplFields(gcomp, importState, exportstate, clock_fv3, &
unit=nuopcMsg)
! call ESMF_LogWrite(nuopcMsg, ESMF_LOGMSG_INFO)
- ! Dumping Fields out
- if (statewrite_flag) then
+ if(trim(state_tag) .eq. 'import')then
+ call ESMF_GridCompGet(gcomp, importState=importState, rc=rc)
+ if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
- if(trim(state_tag) .eq. 'import')then
- call ESMF_GridCompGet(gcomp, importState=importState, rc=rc)
- if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
- ! replace with tiled field dumps
- !call ESMFPP_RegridWriteState(importState, "fv3_cap_import_", timeslice, rc=rc)
- write(filename,'(a,a,a)') 'fv3_cap_import_'//trim(timestr)//'_'
+ if(stdiagnose_flag > 0)then
+ call state_diagnose(importState, ':IS', rc=rc)
+ end if
+
+ ! Dump Fields out
+ if (statewrite_flag) then
+ write(filename,'(A)') 'fv3_cap_import_'//trim(timestr)//'_'
call State_RWFields_tiles(importState,trim(filename), timeslice, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
end if
+ end if
- if(trim(state_tag) .eq. 'export')then
- call ESMF_GridCompGet(gcomp, exportState=exportState, rc=rc)
- if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
- ! replace with tiled field dumps
- !call ESMFPP_RegridWriteState(exportState, "fv3_cap_export_", timeslice, rc=rc)
- write(filename,'(a,a,a)') 'fv3_cap_export_'//trim(timestr)//'_'
+ if(trim(state_tag) .eq. 'export')then
+ call ESMF_GridCompGet(gcomp, exportState=exportState, rc=rc)
+ if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
+ if(stdiagnose_flag > 0)then
+ call state_diagnose(exportState, ':ES', rc=rc)
+ end if
+
+ ! Dump Fields out
+ if (statewrite_flag) then
+ write(filename,'(A)') 'fv3_cap_export_'//trim(timestr)//'_'
call State_RWFields_tiles(exportState,trim(filename), timeslice, rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
end if
+ end if
- endif
-!
- end subroutine Dump_cplFields
+ end subroutine diagnose_cplFields
!-----------------------------------------------------------------------------
@@ -457,4 +467,77 @@ end subroutine State_RWFields_tiles
!-----------------------------------------------------------------------------
+ subroutine state_diagnose(State,string, rc)
+ ! ----------------------------------------------
+ ! Diagnose status of state
+ ! ----------------------------------------------
+ type(ESMF_State), intent(inout) :: State
+ character(len=*), intent(in), optional :: string
+ integer, intent(out), optional :: rc
+
+ ! local variables
+ integer :: i,j,n
+ integer :: itemCount
+ character(len=64) ,pointer :: itemNameList(:)
+ character(len=64) :: lstring
+ character(len=256) :: tmpstr
+
+ type(ESMF_Field) :: lfield
+ type(ESMF_StateItem_Flag) :: itemType
+ real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:)
+ real(ESMF_KIND_R8), pointer :: dataPtr3d(:,:,:)
+ integer :: lrc, dimCount
+ character(len=*),parameter :: subname='(FV3: state_diagnose)'
+
+ lstring = ''
+ if (present(string)) then
+ lstring = trim(string)
+ endif
+
+ call ESMF_LogWrite(subname//' called', ESMF_LOGMSG_INFO)
+
+ call ESMF_StateGet(State, itemCount=itemCount, rc=lrc)
+ if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+ allocate(itemNameList(itemCount))
+
+ call ESMF_StateGet(State, itemNameList=itemNameList, rc=lrc)
+ if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
+ do n = 1, itemCount
+ call ESMF_StateGet(State, itemName=trim(itemNameList(n)), itemType=itemType, rc=lrc)
+ if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
+ if(itemType == ESMF_STATEITEM_FIELD)then
+ call ESMF_StateGet(State, itemName=trim(itemNameList(n)), field=lfield, rc=lrc)
+ if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
+ call ESMF_FieldGet(lfield, dimCount=dimcount, rc=lrc)
+ if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
+ if(dimcount == 2)then
+ call ESMF_FieldGet(lfield, farrayPtr=dataPtr2d, rc=lrc)
+ if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
+ write(tmpstr,'(A,3g14.7)') trim(subname)//' '//trim(lstring)//':'//trim(itemNameList(n))//' ', &
+ minval(dataPtr2d),maxval(dataPtr2d),sum(dataPtr2d)
+ call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=lrc)
+ else
+ call ESMF_FieldGet(lfield, farrayPtr=dataPtr3d, rc=lrc)
+ if (ESMF_LogFoundError(rcToCheck=lrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
+ write(tmpstr,'(A,3g14.7)') trim(subname)//' '//trim(lstring)//':'//trim(itemNameList(n))//' ', &
+ minval(dataPtr3d),maxval(dataPtr3d),sum(dataPtr3d)
+ call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO, rc=lrc)
+ end if
+ end if
+ enddo
+ deallocate(itemNameList)
+
+ if (present(rc)) rc = lrc
+ call ESMF_LogWrite(subname//' exit', ESMF_LOGMSG_INFO)
+
+ end subroutine state_diagnose
+
+ !-----------------------------------------------------------------------------
+
end module module_cap_cpl
diff --git a/cpl/module_cplfields.F90 b/cpl/module_cplfields.F90
index 5e62755f9..3690731ea 100644
--- a/cpl/module_cplfields.F90
+++ b/cpl/module_cplfields.F90
@@ -201,6 +201,7 @@ subroutine fillExportFields(data_a2oi, rc)
integer :: n,dimCount
logical :: isCreated
type(ESMF_TypeKind_Flag) :: datatype
+ character(len=ESMF_MAXSTR) :: fieldName
real(kind=ESMF_KIND_R4), dimension(:,:), pointer :: datar42d
real(kind=ESMF_KIND_R8), dimension(:,:), pointer :: datar82d
@@ -212,8 +213,9 @@ subroutine fillExportFields(data_a2oi, rc)
if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return
if (isCreated) then
! set data
- call ESMF_FieldGet(exportFields(n), dimCount=dimCount, typekind=datatype, rc=localrc)
+ call ESMF_FieldGet(exportFields(n), name=fieldname, dimCount=dimCount, typekind=datatype, rc=localrc)
if (ESMF_LogFoundError(rcToCheck=localrc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__, rcToReturn=rc)) return
+ !print *,'in fillExportFields, field created n=',n,size(exportFields),'name=', trim(fieldname)
if ( datatype == ESMF_TYPEKIND_R8) then
if ( dimCount == 2) then
call ESMF_FieldGet(exportFields(n),farrayPtr=datar82d,localDE=0, rc=localrc)
diff --git a/fv3_cap.F90 b/fv3_cap.F90
index d0d55b47a..29b7c361a 100644
--- a/fv3_cap.F90
+++ b/fv3_cap.F90
@@ -60,9 +60,10 @@ module fv3gfs_cap_mod
nImportFields, importFields, &
importFieldsList, importFieldTypes, &
importFieldShare, importFieldsValid, &
- queryFieldList
+ queryFieldList, fillExportFields, &
+ exportData
use module_cap_cpl, only: realizeConnectedCplFields, &
- clock_cplIntval, Dump_cplFields
+ clock_cplIntval, diagnose_cplFields
implicit none
@@ -92,6 +93,7 @@ module fv3gfs_cap_mod
character(len=160) :: nuopcMsg
integer :: timeslice = 0
integer :: fcstmype
+ integer :: dbug = 0
!-----------------------------------------------------------------------
@@ -188,7 +190,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc)
character(len=10) :: value
character(240) :: msgString
-
+ logical :: isPresent, isSet
character(len=*),parameter :: subname='(fv3gfs_cap:InitializeP0)'
rc = ESMF_SUCCESS
@@ -211,6 +213,15 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc)
write(msgString,'(A,l6)') trim(subname)//' cplprint_flag = ',cplprint_flag
call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc)
+ ! Read in cap debug flag
+ call NUOPC_CompAttributeGet(gcomp, name='dbug_flag', value=value, isPresent=isPresent, isSet=isSet, rc=rc)
+ if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+ if (isPresent .and. isSet) then
+ read(value,*) dbug
+ end if
+ write(msgString,'(A,i6)') trim(subname)//' dbug = ',dbug
+ call ESMF_LogWrite(trim(msgString), ESMF_LOGMSG_INFO, rc=rc)
+
end subroutine
!-----------------------------------------------------------------------------
@@ -247,7 +258,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
integer,dimension(:), allocatable :: petList, originPetList, targetPetList
character(20) :: cwrtcomp
character(160) :: msg
- integer :: isrctermprocessing
+ integer :: isrcTermProcessing
character(len=*),parameter :: subname='(fv3_cap:InitializeAdvertise)'
integer nfmout, nfsout , nfmout_hf, nfsout_hf
@@ -344,8 +355,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
label ='app_domain:',rc=rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+ CALL ESMF_ConfigGetAttribute(config=CF,value=isrcTermProcessing, default=0, &
+ label ='isrcTermProcessing:',rc=rc)
+ if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
if(mype == 0) print *,'af nems config,quilting=',quilting,'write_groups=', &
- write_groups,wrttasks_per_group,'calendar=',trim(calendar),'calendar_type=',calendar_type
+ write_groups,wrttasks_per_group,'calendar=',trim(calendar),'calendar_type=',calendar_type, &
+ 'isrcTermProcessing=', isrcTermProcessing
!
CALL ESMF_ConfigGetAttribute(config=CF,value=num_files, &
label ='num_files:',rc=rc)
@@ -544,6 +560,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
rsthour = CurrTime - StartTime
first_kdt = nint(rsthour/timeStep) + 1
endif
+
!
!#######################################################################
! set up fcst grid component
@@ -555,7 +572,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
! create fcst grid component
fcstpe = .false.
- num_pes_fcst = petcount - write_groups * wrttasks_per_group
+ if( quilting ) then
+ num_pes_fcst = petcount - write_groups * wrttasks_per_group
+ else
+ num_pes_fcst = petcount
+ endif
allocate(fcstPetList(num_pes_fcst))
do j=1, num_pes_fcst
fcstPetList(j) = j - 1
@@ -733,11 +754,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
! this is a Store() for the first wrtComp -> must do the Store()
timewri = mpi_wtime()
- isrctermprocessing = 1
call ESMF_FieldBundleRegridStore(fcstFB(j), wrtFB(j,i), &
regridMethod=regridmethod, routehandle=routehandle(j,i), &
unmappedaction=ESMF_UNMAPPEDACTION_IGNORE, &
- srcTermProcessing=isrctermprocessing, rc=rc)
+ srcTermProcessing=isrcTermProcessing, rc=rc)
! if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
if (rc /= ESMF_SUCCESS) then
@@ -799,6 +819,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
alarm_output_hf_ring = startTime + (nhf+1_ESMF_KIND_I4)*output_interval_hf
if(iau_offset > 0) then
alarm_output_hf_ring = startTime + IAU_offsetTI
+ if( currtime > alarm_output_hf_ring ) then
+ alarm_output_hf_ring = startTime + (nhf+1_ESMF_KIND_I4)*output_interval_hf
+ endif
endif
alarm_output_hf = ESMF_AlarmCreate(clock_fv3,name='ALARM_OUTPUT_HF', &
ringTime =alarm_output_hf_ring, &
@@ -819,6 +842,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc)
alarm_output_ring = startTime + (nrg+1_ESMF_KIND_I4) * output_interval
if(iau_offset > 0) then
alarm_output_ring = startTime + IAU_offsetTI
+ if( currtime > alarm_output_ring ) then
+ alarm_output_ring = startTime + (nrg+1_ESMF_KIND_I4) * output_interval
+ endif
endif
endif
@@ -927,6 +953,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc)
importFields, rc)
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
end if
+!jw
+ call fillExportFields(exportData)
endif
end subroutine InitializeRealize
@@ -1032,6 +1060,7 @@ subroutine ModelAdvance(gcomp, rc)
call ESMF_ClockGet(clock_fv3, currTime=currTime, timeStep=timeStep, rc=rc)
call ESMF_TimeGet(currTime, timestring=import_timestr, rc=rc)
call ESMF_TimeGet(currTime+timestep, timestring=export_timestr, rc=rc)
+
!
!-----------------------------------------------------------------------------
!*** integration loop
@@ -1056,8 +1085,12 @@ subroutine ModelAdvance(gcomp, rc)
if ( cpl ) then
! assign import_data called during phase=1
- call Dump_cplFields(gcomp, importState, exportstate, clock_fv3, &
- cplprint_flag, 'import', import_timestr)
+ if( dbug > 0 .or. cplprint_flag ) then
+ if( mype < num_pes_fcst ) then
+ call diagnose_cplFields(gcomp, importState, exportstate, clock_fv3, &
+ cplprint_flag, dbug, 'import', import_timestr)
+ endif
+ endif
endif
call ESMF_GridCompRun(fcstComp, exportState=fcstState, clock=clock_fv3, &
@@ -1120,6 +1153,10 @@ subroutine ModelAdvance(gcomp, rc)
timerhi = mpi_wtime()
! if (mype == 0 .or. mype == lead_wrttask(1)) print *,' aft fcst run alarm is on, na=',na,'mype=',mype
+
+ call ESMF_VMEpochEnter(epoch=ESMF_VMEpoch_Buffer, rc=rc)
+ if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+
do i=1, FBCount
!
! get fcst fieldbundle
@@ -1127,13 +1164,15 @@ subroutine ModelAdvance(gcomp, rc)
call ESMF_FieldBundleRegrid(fcstFB(i), wrtFB(i,n_group), &
routehandle=routehandle(i, n_group), &
termorderflag=(/ESMF_TERMORDER_SRCSEQ/), rc=rc)
- timerh = mpi_wtime()
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
!
!end FBcount
- enddo
-! if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, &
-! ' time=', timerh- timerhi
+ enddo
+ call ESMF_VMEpochExit(rc=rc)
+ if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
+ timerh = mpi_wtime()
+ if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, &
+ ' time=', timerh- timerhi
! if(mype==0 .or. mype==lead_wrttask(1)) print *,'on wrt bf wrt run, na=',na
call ESMF_LogWrite('Model Advance: before wrtcomp run ', ESMF_LOGMSG_INFO, rc=rc)
@@ -1175,8 +1214,12 @@ subroutine ModelAdvance(gcomp, rc)
!
!jw for coupled, check clock and dump import and export state
if ( cpl ) then
- call Dump_cplFields(gcomp, importState, exportstate, clock_fv3, &
- cplprint_flag, 'export', export_timestr)
+ if( dbug > 0 .or. cplprint_flag ) then
+ if( mype < num_pes_fcst ) then
+ call diagnose_cplFields(gcomp, importState, exportstate, clock_fv3, &
+ cplprint_flag, dbug, 'export', export_timestr)
+ endif
+ end if
endif
if (mype==0) print *,'fv3_cap,end integrate,na=',na,' time=',mpi_wtime()- timeri
@@ -1410,17 +1453,20 @@ subroutine ModelAdvance_phase2(gcomp, rc)
output: IF(lalarm .or. na==first_kdt ) then
timerhi = mpi_wtime()
+ call ESMF_VMEpochEnter(epoch=ESMF_VMEpoch_Buffer, rc=rc)
+ if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
do i=1, FBCount
!
! get fcst fieldbundle
!
call ESMF_FieldBundleRegrid(fcstFB(i), wrtFB(i,n_group), &
routehandle=routehandle(i, n_group), rc=rc)
- timerh = mpi_wtime()
if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
!
!end FBcount
enddo
+ call ESMF_VMEpochExit(rc=rc)
+ if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return
if (mype == 0 .or. mype == lead_wrttask(n_group)) print *,'aft fieldbundleregrid,na=',na, &
' time=', timerh- timerhi
@@ -1641,7 +1687,6 @@ subroutine atmos_model_finalize(gcomp, rc)
end subroutine atmos_model_finalize
-
!#######################################################################
!
!
diff --git a/gfsphysics/CCPP_layer/CCPP_data.meta b/gfsphysics/CCPP_layer/CCPP_data.meta
index e3f1249e5..70c783820 100644
--- a/gfsphysics/CCPP_layer/CCPP_data.meta
+++ b/gfsphysics/CCPP_layer/CCPP_data.meta
@@ -1,3 +1,8 @@
+[ccpp-table-properties]
+ name = CCPP_data
+ type = module
+ dependencies = ../../ccpp/framework/src/ccpp_types.F90,CCPP_typedefs.F90,../GFS_layer/GFS_typedefs.F90
+
[ccpp-arg-table]
name = CCPP_data
type = module
diff --git a/gfsphysics/CCPP_layer/CCPP_typedefs.meta b/gfsphysics/CCPP_layer/CCPP_typedefs.meta
index d38fb8631..868dccebd 100644
--- a/gfsphysics/CCPP_layer/CCPP_typedefs.meta
+++ b/gfsphysics/CCPP_layer/CCPP_typedefs.meta
@@ -1,3 +1,8 @@
+[ccpp-table-properties]
+ name = CCPP_interstitial_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = CCPP_interstitial_type
type = ddt
@@ -334,6 +339,11 @@
type = integer
########################################################################
+[ccpp-table-properties]
+ name = CCPP_typedefs
+ type = module
+ dependencies = ../../ccpp/physics/physics/machine.F
+
[ccpp-arg-table]
name = CCPP_typedefs
type = module
diff --git a/gfsphysics/GFS_layer/GFS_diagnostics.F90 b/gfsphysics/GFS_layer/GFS_diagnostics.F90
index ed2e5d51a..adb624cca 100644
--- a/gfsphysics/GFS_layer/GFS_diagnostics.F90
+++ b/gfsphysics/GFS_layer/GFS_diagnostics.F90
@@ -1937,6 +1937,17 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop
ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%refl_10cm(:,:)
enddo
+ idx = idx + 1
+ ExtDiag(idx)%axes = 3
+ ExtDiag(idx)%name = 'cldfra'
+ ExtDiag(idx)%desc = 'Instantaneous 3D Cloud Fraction'
+ ExtDiag(idx)%unit = 'frac'
+ ExtDiag(idx)%mod_name = 'gfs_phys'
+ allocate (ExtDiag(idx)%data(nblks))
+ do nb = 1,nblks
+ ExtDiag(idx)%data(nb)%var3 => IntDiag(nb)%cldfra(:,:)
+ enddo
+
idx = idx + 1
ExtDiag(idx)%axes = 3
ExtDiag(idx)%name = 'cnvw'
@@ -2434,7 +2445,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop
ExtDiag(idx)%name = 'dt3dt_nophys'
ExtDiag(idx)%desc = 'temperature tendency due to non-physics processes'
ExtDiag(idx)%unit = 'K s-1'
- ExtDiag(idx)%mod_name = 'gfs_phys'
+ ExtDiag(idx)%mod_name = 'gfs_dyn'
ExtDiag(idx)%time_avg = .TRUE.
allocate (ExtDiag(idx)%data(nblks))
do nb = 1,nblks
@@ -2615,7 +2626,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop
ExtDiag(idx)%name = 'du3dt_nophys'
ExtDiag(idx)%desc = 'u momentum tendency due to non-physics processes'
ExtDiag(idx)%unit = 'm s-2'
- ExtDiag(idx)%mod_name = 'gfs_phys'
+ ExtDiag(idx)%mod_name = 'gfs_dyn'
ExtDiag(idx)%time_avg = .TRUE.
allocate (ExtDiag(idx)%data(nblks))
do nb = 1,nblks
@@ -2627,7 +2638,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop
ExtDiag(idx)%name = 'dv3dt_nophys'
ExtDiag(idx)%desc = 'v momentum tendency due to non-physics processes'
ExtDiag(idx)%unit = 'm s-2'
- ExtDiag(idx)%mod_name = 'gfs_phys'
+ ExtDiag(idx)%mod_name = 'gfs_dyn'
ExtDiag(idx)%time_avg = .TRUE.
allocate (ExtDiag(idx)%data(nblks))
do nb = 1,nblks
@@ -2774,7 +2785,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop
ExtDiag(idx)%name = 'dq3dt_nophys'
ExtDiag(idx)%desc = 'water vapor specific humidity tendency due to non-physics processes'
ExtDiag(idx)%unit = 'kg kg-1 s-1'
- ExtDiag(idx)%mod_name = 'gfs_phys'
+ ExtDiag(idx)%mod_name = 'gfs_dyn'
ExtDiag(idx)%time_avg = .TRUE.
allocate (ExtDiag(idx)%data(nblks))
do nb = 1,nblks
@@ -2786,7 +2797,7 @@ subroutine GFS_externaldiag_populate (ExtDiag, Model, Statein, Stateout, Sfcprop
ExtDiag(idx)%name = 'dq3dt_o3nophys'
ExtDiag(idx)%desc = 'ozone concentration tendency due to non-physics processes'
ExtDiag(idx)%unit = 'kg kg-1 s-1'
- ExtDiag(idx)%mod_name = 'gfs_phys'
+ ExtDiag(idx)%mod_name = 'gfs_dyn'
ExtDiag(idx)%time_avg = .TRUE.
allocate (ExtDiag(idx)%data(nblks))
do nb = 1,nblks
diff --git a/gfsphysics/GFS_layer/GFS_driver.F90 b/gfsphysics/GFS_layer/GFS_driver.F90
index 4abde43d0..e32ec4c26 100644
--- a/gfsphysics/GFS_layer/GFS_driver.F90
+++ b/gfsphysics/GFS_layer/GFS_driver.F90
@@ -633,6 +633,7 @@ subroutine GFS_time_vary_step (Model, Statein, Stateout, Sfcprop, Coupling, &
if (mod(Model%kdt,Model%nscyc) == 1) THEN
call gcycle (nblks, Model, Grid(:), Sfcprop(:), Cldprop(:))
endif
+ ! if not updating surface params through fcast, perturb params once at start of fcast
endif
!--- determine if diagnostics buckets need to be cleared
diff --git a/gfsphysics/GFS_layer/GFS_physics_driver.F90 b/gfsphysics/GFS_layer/GFS_physics_driver.F90
index 14911d13f..899955f03 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
!
!===============================================================================
@@ -658,6 +660,7 @@ subroutine GFS_physics_driver &
real :: pshltr,QCQ,rh02
real(kind=kind_phys), allocatable, dimension(:,:) :: den
+ real(kind=kind_phys) :: lndp_vgf
!! Initialize local variables (for debugging purposes only,
!! because the corresponding variables Interstitial(nt)%...
!! are reset to zero every time).
@@ -809,8 +812,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 +837,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.
@@ -905,34 +929,28 @@ subroutine GFS_physics_driver &
! alb1d(i) = zero
vegf1d(i) = zero
enddo
- if (Model%do_sfcperts) then
- if (Model%pertz0(1) > zero) then
- z01d(:) = Model%pertz0(1) * Coupling%sfc_wts(:,1)
-! if (me == 0) print*,'Coupling%sfc_wts(:,1) min and max',minval(Coupling%sfc_wts(:,1)),maxval(Coupling%sfc_wts(:,1))
-! if (me == 0) print*,'z01d min and max ',minval(z01d),maxval(z01d)
- endif
- if (Model%pertzt(1) > zero) then
- zt1d(:) = Model%pertzt(1) * Coupling%sfc_wts(:,2)
- endif
- if (Model%pertshc(1) > zero) then
- bexp1d(:) = Model%pertshc(1) * Coupling%sfc_wts(:,3)
- endif
- if (Model%pertlai(1) > zero) then
- xlai1d(:) = Model%pertlai(1) * Coupling%sfc_wts(:,4)
- endif
-! --- do the albedo percentile calculation in GFS_radiation_driver instead --- !
-! if (Model%pertalb(1) > zero) then
-! do i=1,im
-! call cdfnor(Coupling%sfc_wts(i,5),cdfz)
-! alb1d(i) = cdfz
-! enddo
-! endif
- if (Model%pertvegf(1) > zero) then
- do i=1,im
- call cdfnor(Coupling%sfc_wts(i,6),cdfz)
- vegf1d(i) = cdfz
- enddo
- endif
+ lndp_vgf=-999.
+
+ if (Model%lndp_type==1) then
+ do k =1,Model%n_var_lndp
+ select case(Model%lndp_var_list(k))
+ case ('rz0')
+ z01d(:) = Model%lndp_prt_list(k)* Coupling%sfc_wts(:,k)
+ case ('rzt')
+ zt1d(:) = Model%lndp_prt_list(k)* Coupling%sfc_wts(:,k)
+ case ('shc')
+ bexp1d(:) = Model%lndp_prt_list(k) * Coupling%sfc_wts(:,k)
+ case ('lai')
+ xlai1d(:) = Model%lndp_prt_list(k)* Coupling%sfc_wts(:,k)
+ case ('vgf')
+! note that the pertrubed vegfrac is being used in sfc_drv, but not sfc_diff
+ do i=1,im
+ call cdfnor(Coupling%sfc_wts(i,k),cdfz)
+ vegf1d(i) = cdfz
+ enddo
+ lndp_vgf = Model%lndp_prt_list(k)
+ end select
+ enddo
endif
!*## CCPP ##
!
@@ -1010,15 +1028,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 +1056,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 +1124,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 +1220,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 +1245,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 +1261,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 +1523,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 +1536,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 +1569,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 +1605,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 +1616,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 +1635,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 +1678,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 +1690,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 +1706,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 +1734,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 +1795,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 +1809,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
@@ -1794,6 +1851,7 @@ subroutine GFS_physics_driver &
! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr)
!## CCPP ##* sfc_drv.f/lsm_noah_run
+
call sfc_drv &
! --- inputs:
(im, lsoil, Statein%pgr, &
@@ -1805,7 +1863,8 @@ subroutine GFS_physics_driver &
Sfcprop%shdmin, Sfcprop%shdmax, Sfcprop%snoalb, &
Radtend%sfalb, flag_iter, flag_guess, Model%lheatstrg, &
Model%isot, Model%ivegsrc, &
- bexp1d, xlai1d, vegf1d, Model%pertvegf, &
+ bexp1d, xlai1d, vegf1d,lndp_vgf, &
+
! --- input/output:
weasd3(:,1), snowd3(:,1), tsfc3(:,1), tprcp3(:,1), &
Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, &
@@ -1817,10 +1876,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 +1960,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 +1983,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 +2026,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 +2043,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 +2053,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 +2076,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 +2118,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 +2163,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 +2177,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 +2222,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 +2348,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 +2403,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 +2431,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 +2464,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 +2497,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 +2507,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 +2974,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 +3002,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 +3222,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 +3488,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 +3505,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 +3574,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 +3585,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 +3612,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 +3739,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 +4009,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 +4041,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 +4061,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 +4363,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 +4512,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 +4564,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 +5247,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 +5302,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 +5318,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 +5414,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 +5431,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 +5485,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 +5513,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 +5549,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 +5697,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 +5765,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 +5782,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 +5798,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 +5912,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 +5925,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 +5960,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 +5978,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..da5078f7b 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,19 @@ 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) :: lndp_alb
real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtausw
real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+ltp) :: cldtaulw
+ 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 +1299,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 +1343,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 +1361,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,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,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)
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 +1469,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 +1492,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 +1520,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 +1543,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 +1561,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 +1591,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 +1627,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 +1637,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 +1655,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 +1696,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 +1705,7 @@ subroutine GFS_radiation_driver &
endif
else ! neither of the other two cases
- cldcov = 0.0
+ cldcov = zero
endif
!
@@ -1698,17 +1728,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 +1769,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
@@ -1818,14 +1848,17 @@ subroutine GFS_radiation_driver &
! perturbation size
! --- turn vegetation fraction pattern into percentile pattern
alb1d(:) = 0.
- if (Model%do_sfcperts) then
- if (Model%pertalb(1) > 0.) then
- do i=1,im
- call cdfnor(Coupling%sfc_wts(i,5),cdfz)
- alb1d(i) = cdfz
- enddo
+ lndp_alb = -999.
+ if (Model%lndp_type ==1) then
+ do k =1,Model%n_var_lndp
+ if (Model%lndp_var_list(k) == 'alb') then
+ do i=1,im
+ call cdfnor(Coupling%sfc_wts(i,k),alb1d(i))
+ lndp_alb = Model%lndp_prt_list(k)
+ enddo
+ endif
+ enddo
endif
- endif
! mg, sfc-perts
!*## CCPP ##
@@ -1842,21 +1875,21 @@ subroutine GFS_radiation_driver &
Sfcprop%alnsf, Sfcprop%alvwf, Sfcprop%alnwf, &
Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, &
Sfcprop%tisfc, IM, &
- alb1d, Model%pertalb, & ! mg, sfc-perts
+ alb1d, lndp_alb, & ! mg, sfc-perts
sfcalb) ! --- outputs
!> -# Approximate mean surface albedo from vis- and nir- diffuse values.
- 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 +1919,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 +1931,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 +1955,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 +1998,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 +2034,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 +2046,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 +2103,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 +2163,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 +2178,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_restart.F90 b/gfsphysics/GFS_layer/GFS_restart.F90
index 52b3d7b83..eada1fc3d 100644
--- a/gfsphysics/GFS_layer/GFS_restart.F90
+++ b/gfsphysics/GFS_layer/GFS_restart.F90
@@ -263,9 +263,12 @@ subroutine GFS_restart_populate (Restart, Model, Statein, Stateout, Sfcprop, &
enddo
endif
#ifdef CCPP
+ if (Model%lrefres) then
+ num = Model%ntot3d+1
+ else
+ num = Model%ntot3d
+ endif
!--- RAP/HRRR-specific variables, 3D
- num = Model%ntot3d
-
! GF
if (Model%imfdeepcnv == Model%imfdeepcnv_gf) then
num = num + 1
diff --git a/gfsphysics/GFS_layer/GFS_typedefs.F90 b/gfsphysics/GFS_layer/GFS_typedefs.F90
index 0924b2589..7b8e90240 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)
@@ -515,7 +517,6 @@ module GFS_typedefs
real (kind=kind_phys), pointer :: skebu_wts (:,:) => null() !
real (kind=kind_phys), pointer :: skebv_wts (:,:) => null() !
real (kind=kind_phys), pointer :: sfc_wts (:,:) => null() ! mg, sfc-perts
- integer :: nsfcpert=6 !< number of sfc perturbations
!--- aerosol surface emissions for Thompson microphysics
real (kind=kind_phys), pointer :: nwfa2d (:) => null() !< instantaneous water-friendly sfc aerosol source
@@ -656,6 +657,7 @@ module GFS_typedefs
integer :: icliq_sw !< sw optical property for liquid clouds
integer :: iovr_sw !< sw: max-random overlap clouds
integer :: iovr_lw !< lw: max-random overlap clouds
+ integer :: iovr !< max-random overlap clouds for sw & lw (maximum of both)
integer :: ictm !< ictm=0 => use data at initial cond time, if not
!< available; use latest; no extrapolation.
!< ictm=1 => use data at the forecast time, if not
@@ -1043,14 +1045,14 @@ module GFS_typedefs
logical :: do_shum
logical :: do_skeb
integer :: skeb_npass
- logical :: do_sfcperts
- integer :: nsfcpert=6
- real(kind=kind_phys) :: pertz0(5) ! mg, sfc-perts
- real(kind=kind_phys) :: pertzt(5) ! mg, sfc-perts
- real(kind=kind_phys) :: pertshc(5) ! mg, sfc-perts
- real(kind=kind_phys) :: pertlai(5) ! mg, sfc-perts
- real(kind=kind_phys) :: pertalb(5) ! mg, sfc-perts
- real(kind=kind_phys) :: pertvegf(5) ! mg, sfc-perts
+ integer :: lndp_type
+ integer :: n_var_lndp
+ character(len=3) :: lndp_var_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def
+ real(kind=kind_phys) :: lndp_prt_list(6) ! dimension here must match n_var_max_lndp in stochy_nml_def
+ ! also previous code had dimension 5 for each pert, to allow
+ ! multiple patterns. It wasn't fully coded (and wouldn't have worked
+ ! with nlndp>1, so I just dropped it). If we want to code it properly,
+ ! we'd need to make this dim(6,5).
!--- tracer handling
character(len=32), pointer :: tracer_names(:) !< array of initialized tracers from dynamic core
integer :: ntrac !< number of tracers
@@ -1549,7 +1551,9 @@ module GFS_typedefs
#ifdef CCPP
real (kind=kind_phys), pointer :: TRAIN (:,:) => null() !< accumulated stratiform T tendency (K s-1)
#endif
-
+!#ifdef CCPP
+ real (kind=kind_phys), pointer :: cldfra (:,:) => null() !< instantaneous 3D cloud fraction
+!#endif
!--- MP quantities for 3D diagnositics
real (kind=kind_phys), pointer :: refl_10cm(:,:) => null() !< instantaneous refl_10cm
!
@@ -1678,6 +1682,7 @@ module GFS_typedefs
real (kind=kind_phys), pointer :: adjvisdfd(:) => null() !<
real (kind=kind_phys), pointer :: aerodp(:,:) => null() !<
real (kind=kind_phys), pointer :: alb1d(:) => null() !<
+ real (kind=kind_phys), pointer :: alpha(:,:) => null() !<
real (kind=kind_phys), pointer :: bexp1d(:) => null() !<
real (kind=kind_phys), pointer :: cd(:) => null() !<
real (kind=kind_phys), pointer :: cd_ice(:) => null() !<
@@ -1944,6 +1949,8 @@ module GFS_typedefs
real (kind=kind_phys), pointer :: uustar_ocean(:) => null() !<
real (kind=kind_phys), pointer :: vdftra(:,:,:) => null() !<
real (kind=kind_phys), pointer :: vegf1d(:) => null() !<
+ real (kind=kind_phys) :: lndp_vgf !<
+
integer, pointer :: vegtype(:) => null() !<
real (kind=kind_phys), pointer :: w_upi(:,:) => null() !<
real (kind=kind_phys), pointer :: wcbmax(:) => null() !<
@@ -2227,6 +2234,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 +2254,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 +2627,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 +2642,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 +2654,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
@@ -2792,9 +2803,9 @@ subroutine coupling_create (Coupling, IM, Model)
Coupling%skebv_wts = clear_val
endif
- !--- stochastic physics option
- if (Model%do_sfcperts) then
- allocate (Coupling%sfc_wts (IM,Model%nsfcpert))
+ !--- stochastic land perturbation option
+ if (Model%lndp_type .NE. 0) then
+ allocate (Coupling%sfc_wts (IM,Model%n_var_lndp))
Coupling%sfc_wts = clear_val
endif
@@ -3306,15 +3317,9 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, &
logical :: use_zmtnblck = .false.
logical :: do_shum = .false.
logical :: do_skeb = .false.
- integer :: skeb_npass = 11
- logical :: do_sfcperts = .false. ! mg, sfc-perts
- integer :: nsfcpert = 6 ! mg, sfc-perts
- real(kind=kind_phys) :: pertz0 = -999.
- real(kind=kind_phys) :: pertzt = -999.
- real(kind=kind_phys) :: pertshc = -999.
- real(kind=kind_phys) :: pertlai = -999.
- real(kind=kind_phys) :: pertalb = -999.
- real(kind=kind_phys) :: pertvegf = -999.
+ integer :: skeb_npass = 11
+ integer :: lndp_type = 0
+ integer :: n_var_lndp = 0
!--- aerosol scavenging factors
character(len=20) :: fscav_aero(20) = 'default'
@@ -3391,7 +3396,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, &
do_deep, jcap, &
cs_parm, flgmin, cgwf, ccwf, cdmbgwd, sup, ctei_rm, crtrh, &
dlqf, rbcr, shoc_parm, psauras, prauras, wminras, &
- do_sppt, do_shum, do_skeb, do_sfcperts, &
+ do_sppt, do_shum, do_skeb, lndp_type, n_var_lndp, &
!--- Rayleigh friction
prslrd0, ral_ts, ldiag_ugwp, do_ugwp, do_tofd, &
! --- Ferrier-Aligo
@@ -3680,6 +3685,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, &
Model%icliq_sw = icliq_sw
Model%iovr_sw = iovr_sw
Model%iovr_lw = iovr_lw
+ Model%iovr = max(Model%iovr_sw,Model%iovr_lw)
Model%ictm = ictm
Model%isubc_sw = isubc_sw
Model%isubc_lw = isubc_lw
@@ -3994,21 +4000,15 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, &
Model%e0fac = e0fac
!--- stochastic physics options
- ! do_sppt, do_shum, do_skeb and do_sfcperts are namelist variables in group
+ ! do_sppt, do_shum, do_skeb and lndp_type are namelist variables in group
! physics that are parsed here and then compared in init_stochastic_physics
! to the stochastic physics namelist parametersto ensure consistency.
Model%do_sppt = do_sppt
Model%use_zmtnblck = use_zmtnblck
Model%do_shum = do_shum
Model%do_skeb = do_skeb
- Model%do_sfcperts = do_sfcperts ! mg, sfc-perts
- Model%nsfcpert = nsfcpert ! mg, sfc-perts
- Model%pertz0 = pertz0
- Model%pertzt = pertzt
- Model%pertshc = pertshc
- Model%pertlai = pertlai
- Model%pertalb = pertalb
- Model%pertvegf = pertvegf
+ Model%lndp_type = lndp_type
+ Model%n_var_lndp = n_var_lndp
!--- cellular automata options
Model%nca = nca
@@ -4836,6 +4836,7 @@ subroutine control_print(Model)
print *, ' icliq_sw : ', Model%icliq_sw
print *, ' iovr_sw : ', Model%iovr_sw
print *, ' iovr_lw : ', Model%iovr_lw
+ print *, ' iovr : ', Model%iovr
print *, ' ictm : ', Model%ictm
print *, ' isubc_sw : ', Model%isubc_sw
print *, ' isubc_lw : ', Model%isubc_lw
@@ -5062,7 +5063,8 @@ subroutine control_print(Model)
print *, ' do_sppt : ', Model%do_sppt
print *, ' do_shum : ', Model%do_shum
print *, ' do_skeb : ', Model%do_skeb
- print *, ' do_sfcperts : ', Model%do_sfcperts
+ print *, ' lndp_type : ', Model%lndp_type
+ print *, ' n_var_lndp : ', Model%n_var_lndp
print *, ' '
print *, 'cellular automata'
print *, ' nca : ', Model%nca
@@ -5602,6 +5604,10 @@ subroutine diag_create (Diag, IM, Model)
end if
#endif
+#ifdef CCPP
+ allocate (Diag%cldfra (IM,Model%levs))
+#endif
+
allocate (Diag%ca_deep (IM))
allocate (Diag%ca_turb (IM))
allocate (Diag%ca_shal (IM))
@@ -5919,6 +5925,10 @@ subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center)
Diag%TRAIN = zero
end if
#endif
+#ifdef CCPP
+ Diag%cldfra = zero
+#endif
+
Diag%totprcpb = zero
Diag%cnvprcpb = zero
Diag%toticeb = zero
@@ -6168,6 +6178,10 @@ subroutine interstitial_create (Interstitial, IM, Model)
allocate (Interstitial%adjvisdfd (IM))
allocate (Interstitial%aerodp (IM,NSPC1))
allocate (Interstitial%alb1d (IM))
+ if (.not. Model%do_RRTMGP) then
+ ! RRTMGP uses its own cloud_overlap_param
+ allocate (Interstitial%alpha (IM,Model%levr+LTP))
+ end if
allocate (Interstitial%bexp1d (IM))
allocate (Interstitial%cd (IM))
allocate (Interstitial%cd_ice (IM))
@@ -6707,6 +6721,9 @@ subroutine interstitial_rad_reset (Interstitial, Model)
!
Interstitial%aerodp = clear_val
Interstitial%alb1d = clear_val
+ if (.not. Model%do_RRTMGP) then
+ Interstitial%alpha = clear_val
+ end if
Interstitial%cldsa = clear_val
Interstitial%cldtaulw = clear_val
Interstitial%cldtausw = clear_val
@@ -6994,6 +7011,7 @@ subroutine interstitial_phys_reset (Interstitial, Model)
Interstitial%uustar_ocean = huge
Interstitial%vdftra = clear_val
Interstitial%vegf1d = clear_val
+ Interstitial%lndp_vgf = clear_val
Interstitial%vegtype = 0
Interstitial%wcbmax = clear_val
Interstitial%weasd_ice = huge
@@ -7089,6 +7107,9 @@ subroutine interstitial_phys_reset (Interstitial, Model)
!
end subroutine interstitial_phys_reset
+ ! DH* 20200901: this routine is no longer used by CCPP's GFS_debug.F90. When new variables are
+ ! added to the GFS_interstitial_type, it is best to add the variable to both interstitial_print
+ ! below and to GFS_interstitialtoscreen in ccpp/physics/physics/GFS_debug.F90
subroutine interstitial_print(Interstitial, Model, mpirank, omprank, blkno)
!
implicit none
@@ -7139,6 +7160,9 @@ subroutine interstitial_print(Interstitial, Model, mpirank, omprank, blkno)
write (0,*) 'sum(Interstitial%adjvisdfd ) = ', sum(Interstitial%adjvisdfd )
write (0,*) 'sum(Interstitial%aerodp ) = ', sum(Interstitial%aerodp )
write (0,*) 'sum(Interstitial%alb1d ) = ', sum(Interstitial%alb1d )
+ if (.not. Model%do_RRTMGP) then
+ write (0,*) 'sum(Interstitial%alpha ) = ', sum(Interstitial%alpha )
+ end if
write (0,*) 'sum(Interstitial%bexp1d ) = ', sum(Interstitial%bexp1d )
write (0,*) 'sum(Interstitial%cd ) = ', sum(Interstitial%cd )
write (0,*) 'sum(Interstitial%cd_ice ) = ', sum(Interstitial%cd_ice )
diff --git a/gfsphysics/GFS_layer/GFS_typedefs.meta b/gfsphysics/GFS_layer/GFS_typedefs.meta
index 1c1ecc0c7..24bd57de7 100644
--- a/gfsphysics/GFS_layer/GFS_typedefs.meta
+++ b/gfsphysics/GFS_layer/GFS_typedefs.meta
@@ -1,8 +1,8 @@
-[ccpp-arg-table]
- name = GFS_init_type
+[ccpp-table-properties]
+ name = GFS_statein_type
type = ddt
+ dependencies =
-########################################################################
[ccpp-arg-table]
name = GFS_statein_type
type = ddt
@@ -263,6 +263,11 @@
kind = kind_phys
########################################################################
+[ccpp-table-properties]
+ name = GFS_stateout_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_stateout_type
type = ddt
@@ -439,6 +444,11 @@
kind = kind_phys
########################################################################
+[ccpp-table-properties]
+ name = GFS_sfcprop_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_sfcprop_type
type = ddt
@@ -540,6 +550,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
@@ -666,6 +690,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme)
[hice]
standard_name = sea_ice_thickness
long_name = sea ice thickness
@@ -771,6 +796,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[z_c]
standard_name = sub_layer_cooling_thickness
long_name = sub-layer cooling thickness
@@ -778,6 +804,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[c_0]
standard_name = coefficient_c_0
long_name = coefficient 1 to calculate d(Tz)/d(Ts)
@@ -785,6 +812,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[c_d]
standard_name = coefficient_c_d
long_name = coefficient 2 to calculate d(Tz)/d(Ts)
@@ -792,6 +820,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[w_0]
standard_name = coefficient_w_0
long_name = coefficient 3 to calculate d(Tz)/d(Ts)
@@ -799,6 +828,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[w_d]
standard_name = coefficient_w_d
long_name = coefficient 4 to calculate d(Tz)/d(Ts)
@@ -806,6 +836,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[xt]
standard_name = diurnal_thermocline_layer_heat_content
long_name = heat content in diurnal thermocline layer
@@ -813,6 +844,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[xs]
standard_name = sea_water_salinity
long_name = salinity content in diurnal thermocline layer
@@ -820,6 +852,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[xu]
standard_name = diurnal_thermocline_layer_x_current
long_name = u-current content in diurnal thermocline layer
@@ -827,6 +860,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[xv]
standard_name = diurnal_thermocline_layer_y_current
long_name = v-current content in diurnal thermocline layer
@@ -834,6 +868,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[xz]
standard_name = diurnal_thermocline_layer_thickness
long_name = diurnal thermocline layer thickness
@@ -841,6 +876,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[zm]
standard_name = ocean_mixed_layer_thickness
long_name = mixed layer thickness
@@ -848,6 +884,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[xtts]
standard_name = sensitivity_of_dtl_heat_content_to_surface_temperature
long_name = d(xt)/d(ts)
@@ -855,6 +892,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[xzts]
standard_name = sensitivity_of_dtl_thickness_to_surface_temperature
long_name = d(xz)/d(ts)
@@ -862,6 +900,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[d_conv]
standard_name = free_convection_layer_thickness
long_name = thickness of free convection layer (FCL)
@@ -869,6 +908,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[ifd]
standard_name = index_of_dtlm_start
long_name = index to start dtlm run or not
@@ -876,6 +916,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[dt_cool]
standard_name = sub_layer_cooling_amount
long_name = sub-layer cooling amount
@@ -883,6 +924,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[qrain]
standard_name = sensible_heat_flux_due_to_rainfall
long_name = sensible heat flux due to rainfall
@@ -890,6 +932,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_nsstm_run > 0)
[snowxy]
standard_name = number_of_snow_layers
long_name = number of snow layers
@@ -897,6 +940,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[tvxy]
standard_name = vegetation_temperature
long_name = vegetation temperature
@@ -904,6 +948,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[tgxy]
standard_name = ground_temperature_for_noahmp
long_name = ground temperature for noahmp
@@ -911,6 +956,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[canicexy]
standard_name = canopy_intercepted_ice_mass
long_name = canopy intercepted ice mass
@@ -918,6 +964,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[canliqxy]
standard_name = canopy_intercepted_liquid_water
long_name = canopy intercepted liquid water
@@ -925,6 +972,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[eahxy]
standard_name = canopy_air_vapor_pressure
long_name = canopy air vapor pressure
@@ -932,6 +980,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[tahxy]
standard_name = canopy_air_temperature
long_name = canopy air temperature
@@ -939,6 +988,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[cmxy]
standard_name = surface_drag_coefficient_for_momentum_for_noahmp
long_name = surface drag coefficient for momentum for noahmp
@@ -946,6 +996,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[chxy]
standard_name = surface_drag_coefficient_for_heat_and_moisture_for_noahmp
long_name = surface exchange coeff heat & moisture for noahmp
@@ -953,6 +1004,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[fwetxy]
standard_name = area_fraction_of_wet_canopy
long_name = area fraction of canopy that is wetted/snowed
@@ -960,6 +1012,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[sneqvoxy]
standard_name = snow_mass_at_previous_time_step
long_name = snow mass at previous time step
@@ -967,6 +1020,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[alboldxy]
standard_name = snow_albedo_at_previous_time_step
long_name = snow albedo at previous time step
@@ -974,6 +1028,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[qsnowxy]
standard_name = snow_precipitation_rate_at_surface
long_name = snow precipitation rate at surface
@@ -981,6 +1036,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[wslakexy]
standard_name = lake_water_storage
long_name = lake water storage
@@ -988,6 +1044,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[zwtxy]
standard_name = water_table_depth
long_name = water table depth
@@ -995,6 +1052,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[waxy]
standard_name = water_storage_in_aquifer
long_name = water storage in aquifer
@@ -1002,6 +1060,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[wtxy]
standard_name = water_storage_in_aquifer_and_saturated_soil
long_name = water storage in aquifer and saturated soil
@@ -1009,6 +1068,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[tsnoxy]
standard_name = snow_temperature
long_name = snow_temperature
@@ -1016,6 +1076,7 @@
dimensions = (horizontal_dimension, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[zsnsoxy]
standard_name = layer_bottom_depth_from_snow_surface
long_name = depth from the top of the snow surface at the bottom of the layer
@@ -1023,6 +1084,7 @@
dimensions = (horizontal_dimension, lower_bound_of_snow_vertical_dimension_for_land_surface_model:soil_vertical_dimension_for_land_surface_model)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[snicexy]
standard_name = snow_layer_ice
long_name = snow layer ice
@@ -1030,6 +1092,7 @@
dimensions = (horizontal_dimension, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[snliqxy]
standard_name = snow_layer_liquid_water
long_name = snow layer liquid water
@@ -1037,6 +1100,7 @@
dimensions = (horizontal_dimension, lower_bound_of_snow_vertical_dimension_for_land_surface_model:0)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[lfmassxy]
standard_name = leaf_mass
long_name = leaf mass
@@ -1044,6 +1108,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[rtmassxy]
standard_name = fine_root_mass
long_name = fine root mass
@@ -1051,6 +1116,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[stmassxy]
standard_name = stem_mass
long_name = stem mass
@@ -1058,6 +1124,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[woodxy]
standard_name = wood_mass
long_name = wood mass including woody roots
@@ -1065,6 +1132,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[stblcpxy]
standard_name = slow_soil_pool_mass_content_of_carbon
long_name = stable carbon in deep soil
@@ -1072,6 +1140,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[fastcpxy]
standard_name = fast_soil_pool_mass_content_of_carbon
long_name = short-lived carbon in shallow soil
@@ -1079,6 +1148,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[xlaixy]
standard_name = leaf_area_index
long_name = leaf area index
@@ -1086,6 +1156,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme .or. (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .and. flag_for_reading_leaf_area_index_from_input))
[xsaixy]
standard_name = stem_area_index
long_name = stem area index
@@ -1093,6 +1164,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[taussxy]
standard_name = nondimensional_snow_age
long_name = non-dimensional snow age
@@ -1100,6 +1172,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[smoiseq]
standard_name = equilibrium_soil_water_content
long_name = equilibrium soil water content
@@ -1107,6 +1180,7 @@
dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[smcwtdxy]
standard_name = soil_water_content_between_soil_bottom_and_water_table
long_name = soil water content between the bottom of the soil and the water table
@@ -1114,6 +1188,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[deeprechxy]
standard_name = water_table_recharge_when_deep
long_name = recharge to or from the water table when deep
@@ -1121,6 +1196,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[rechxy]
standard_name = water_table_recharge_when_shallow
long_name = recharge to or from the water table when shallow
@@ -1128,6 +1204,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[wetness]
standard_name = normalized_soil_wetness_for_land_surface_model
long_name = normalized soil wetness for lsm
@@ -1135,6 +1212,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[sh2o]
standard_name = volume_fraction_of_unfrozen_soil_moisture_for_land_surface_model
long_name = volume fraction of unfrozen soil moisture for lsm
@@ -1142,6 +1220,7 @@
dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[keepsmfr]
standard_name = volume_fraction_of_frozen_soil_moisture_for_land_surface_model
long_name = volume fraction of frozen soil moisture for lsm
@@ -1149,6 +1228,7 @@
dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[smois]
standard_name = volume_fraction_of_soil_moisture_for_land_surface_model
long_name = volumetric fraction of soil moisture for lsm
@@ -1156,6 +1236,7 @@
dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[tslb]
standard_name = soil_temperature_for_land_surface_model
long_name = soil temperature for land surface model
@@ -1163,6 +1244,7 @@
dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[zs]
standard_name = depth_of_soil_levels_for_land_surface_model
long_name = depth of soil levels for land surface model
@@ -1170,6 +1252,7 @@
dimensions = (soil_vertical_dimension_for_land_surface_model)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[clw_surf]
standard_name = cloud_condensed_water_mixing_ratio_at_surface
long_name = moist cloud water mixing ratio at surface
@@ -1177,6 +1260,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[qwv_surf]
standard_name = water_vapor_mixing_ratio_at_surface
long_name = water vapor mixing ratio at surface
@@ -1184,6 +1268,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[cndm_surf]
standard_name = surface_condensation_mass
long_name = surface condensation mass
@@ -1191,6 +1276,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[flag_frsoil]
standard_name = flag_for_frozen_soil_physics
long_name = flag for frozen soil physics (RUC)
@@ -1198,6 +1284,7 @@
dimensions = (horizontal_dimension,soil_vertical_dimension_for_land_surface_model)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[rhofr]
standard_name = density_of_frozen_precipitation
long_name = density of frozen precipitation
@@ -1205,6 +1292,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[tsnow]
standard_name = snow_temperature_bottom_first_layer
long_name = snow temperature at the bottom of the first snow layer
@@ -1212,6 +1300,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[snowfallac]
standard_name = total_accumulated_snowfall
long_name = run-total snow accumulation on the ground
@@ -1219,6 +1308,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[acsnow]
standard_name = accumulated_water_equivalent_of_frozen_precip
long_name = snow water equivalent of run-total frozen precip
@@ -1226,6 +1316,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[ustm]
standard_name = surface_friction_velocity_drag
long_name = friction velocity isolated for momentum only
@@ -1233,6 +1324,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[zol]
standard_name = surface_stability_parameter
long_name = monin obukhov surface stability parameter
@@ -1240,6 +1332,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[mol]
standard_name = theta_star
long_name = temperature flux divided by ustar (temperature scale)
@@ -1247,6 +1340,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[rmol]
standard_name = reciprocal_of_obukhov_length
long_name = one over obukhov length
@@ -1254,6 +1348,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[flhc]
standard_name = surface_exchange_coefficient_for_heat
long_name = surface exchange coefficient for heat
@@ -1261,6 +1356,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[flqc]
standard_name = surface_exchange_coefficient_for_moisture
long_name = surface exchange coefficient for moisture
@@ -1268,6 +1364,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[chs2]
standard_name = surface_exchange_coefficient_for_heat_at_2m
long_name = exchange coefficient for heat at 2 meters
@@ -1275,6 +1372,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[cqs2]
standard_name = surface_exchange_coefficient_for_moisture_at_2m
long_name = exchange coefficient for moisture at 2 meters
@@ -1282,6 +1380,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[lh]
standard_name = surface_latent_heat
long_name = latent heating at the surface (pos = up)
@@ -1289,6 +1388,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnsfclay)
[evap]
standard_name = kinematic_surface_upward_latent_heat_flux
long_name = kinematic surface upward latent heat flux
@@ -1317,6 +1417,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[rainncprv]
standard_name = lwe_thickness_of_explicit_rainfall_amount_from_previous_timestep
long_name = explicit rainfall from previous timestep
@@ -1324,6 +1425,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[iceprv]
standard_name = lwe_thickness_of_ice_amount_from_previous_timestep
long_name = ice amount from previous timestep
@@ -1331,6 +1433,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[snowprv]
standard_name = lwe_thickness_of_snow_amount_from_previous_timestep
long_name = snow amount from previous timestep
@@ -1338,6 +1441,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[graupelprv]
standard_name = lwe_thickness_of_graupel_amount_from_previous_timestep
long_name = graupel amount from previous timestep
@@ -1345,6 +1449,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme .or. flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[draincprv]
standard_name = convective_precipitation_rate_from_previous_timestep
long_name = convective precipitation rate from previous timestep
@@ -1352,6 +1457,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[drainncprv]
standard_name = explicit_rainfall_rate_from_previous_timestep
long_name = explicit rainfall rate previous timestep
@@ -1359,6 +1465,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[diceprv]
standard_name = ice_precipitation_rate_from_previous_timestep
long_name = ice precipitation rate from previous timestep
@@ -1366,6 +1473,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[dsnowprv]
standard_name = snow_precipitation_rate_from_previous_timestep
long_name = snow precipitation rate from previous timestep
@@ -1373,6 +1481,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[dgraupelprv]
standard_name = graupel_precipitation_rate_from_previous_timestep
long_name = graupel precipitation rate from previous timestep
@@ -1380,6 +1489,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[alvsf]
standard_name = mean_vis_albedo_with_strong_cosz_dependency
long_name = mean vis albedo with strong cosz dependency
@@ -1410,6 +1520,11 @@
kind = kind_phys
########################################################################
+[ccpp-table-properties]
+ name = GFS_coupling_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_coupling_type
type = ddt
@@ -1497,6 +1612,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling .or. flag_for_stochastic_physics_perturbations .or. flag_for_chemistry_coupling .or. flag_for_global_cellular_automata)
[rainc_cpl]
standard_name = lwe_thickness_of_convective_precipitation_amount_for_coupling
long_name = total convective precipitation
@@ -1511,6 +1627,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling .or. flag_for_stochastic_physics_perturbations .or. flag_for_chemistry_coupling .or. flag_for_global_cellular_automata)
[dusfc_cpl]
standard_name = cumulative_surface_x_momentum_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc x momentum flux multiplied by timestep
@@ -1518,6 +1635,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dvsfc_cpl]
standard_name = cumulative_surface_y_momentum_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc y momentum flux multiplied by timestep
@@ -1525,6 +1643,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dtsfc_cpl]
standard_name = cumulative_surface_upward_sensible_heat_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc sensible heat flux multiplied by timestep
@@ -1532,6 +1651,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dqsfc_cpl]
standard_name = cumulative_surface_upward_latent_heat_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc latent heat flux multiplied by timestep
@@ -1539,6 +1659,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dlwsfc_cpl]
standard_name = cumulative_surface_downwelling_longwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc downward lw flux mulitplied by timestep
@@ -1546,6 +1667,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dswsfc_cpl]
standard_name = cumulative_surface_downwelling_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc downward sw flux multiplied by timestep
@@ -1553,6 +1675,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dnirbm_cpl]
standard_name = cumulative_surface_downwelling_direct_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc nir beam downward sw flux multiplied by timestep
@@ -1560,6 +1683,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dnirdf_cpl]
standard_name = cumulative_surface_downwelling_diffuse_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc nir diff downward sw flux multiplied by timestep
@@ -1567,6 +1691,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dvisbm_cpl]
standard_name = cumulative_surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc uv+vis beam dnwd sw flux multiplied by timestep
@@ -1574,6 +1699,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dvisdf_cpl]
standard_name = cumulative_surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative sfc uv+vis diff dnwd sw flux multiplied by timestep
@@ -1581,6 +1707,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nlwsfc_cpl]
standard_name = cumulative_surface_net_downward_longwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative net downward lw flux multiplied by timestep
@@ -1588,6 +1715,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nswsfc_cpl]
standard_name = cumulative_surface_net_downward_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative net downward sw flux multiplied by timestep
@@ -1595,6 +1723,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nnirbm_cpl]
standard_name = cumulative_surface_net_downward_direct_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative net nir beam downward sw flux multiplied by timestep
@@ -1602,6 +1731,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nnirdf_cpl]
standard_name = cumulative_surface_net_downward_diffuse_near_infrared_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative net nir diff downward sw flux multiplied by timestep
@@ -1609,6 +1739,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nvisbm_cpl]
standard_name = cumulative_surface_net_downward_direct_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative net uv+vis beam downward sw rad flux multiplied by timestep
@@ -1616,6 +1747,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nvisdf_cpl]
standard_name = cumulative_surface_net_downward_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling_multiplied_by_timestep
long_name = cumulative net uv+vis diff downward sw rad flux multiplied by timestep
@@ -1623,6 +1755,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dusfci_cpl]
standard_name = instantaneous_surface_x_momentum_flux_for_coupling
long_name = instantaneous sfc x momentum flux
@@ -1630,6 +1763,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dvsfci_cpl]
standard_name = instantaneous_surface_y_momentum_flux_for_coupling
long_name = instantaneous sfc y momentum flux
@@ -1637,6 +1771,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dtsfci_cpl]
standard_name = instantaneous_surface_upward_sensible_heat_flux_for_coupling
long_name = instantaneous sfc sensible heat flux
@@ -1644,6 +1779,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dqsfci_cpl]
standard_name = instantaneous_surface_upward_latent_heat_flux_for_coupling
long_name = instantaneous sfc latent heat flux
@@ -1651,6 +1787,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dlwsfci_cpl]
standard_name = instantaneous_surface_downwelling_longwave_flux_for_coupling
long_name = instantaneous sfc downward lw flux
@@ -1658,6 +1795,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dswsfci_cpl]
standard_name = instantaneous_surface_downwelling_shortwave_flux_for_coupling
long_name = instantaneous sfc downward sw flux
@@ -1665,6 +1803,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dnirbmi_cpl]
standard_name = instantaneous_surface_downwelling_direct_near_infrared_shortwave_flux_for_coupling
long_name = instantaneous sfc nir beam downward sw flux
@@ -1672,6 +1811,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dnirdfi_cpl]
standard_name = instantaneous_surface_downwelling_diffuse_near_infrared_shortwave_flux_for_coupling
long_name = instantaneous sfc nir diff downward sw flux
@@ -1679,6 +1819,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dvisbmi_cpl]
standard_name = instantaneous_surface_downwelling_direct_ultraviolet_and_visible_shortwave_flux_for_coupling
long_name = instantaneous sfc uv+vis beam downward sw flux
@@ -1686,6 +1827,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dvisdfi_cpl]
standard_name = instantaneous_surface_downwelling_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling
long_name = instantaneous sfc uv+vis diff downward sw flux
@@ -1693,6 +1835,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nlwsfci_cpl]
standard_name = instantaneous_surface_net_downward_longwave_flux_for_coupling
long_name = instantaneous net sfc downward lw flux
@@ -1700,6 +1843,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nswsfci_cpl]
standard_name = instantaneous_surface_net_downward_shortwave_flux_for_coupling
long_name = instantaneous net sfc downward sw flux
@@ -1707,6 +1851,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nnirbmi_cpl]
standard_name = instantaneous_surface_net_downward_direct_near_infrared_shortwave_flux_for_coupling
long_name = instantaneous net nir beam sfc downward sw flux
@@ -1714,6 +1859,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nnirdfi_cpl]
standard_name = instantaneous_surface_net_downward_diffuse_near_infrared_shortwave_flux_for_coupling
long_name = instantaneous net nir diff sfc downward sw flux
@@ -1721,6 +1867,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nvisbmi_cpl]
standard_name = instantaneous_surface_net_downward_direct_ultraviolet_and_visible_shortwave_flux_for_coupling
long_name = instantaneous net uv+vis beam downward sw flux
@@ -1728,6 +1875,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[nvisdfi_cpl]
standard_name = instantaneous_surface_net_downward_diffuse_ultraviolet_and_visible_shortwave_flux_for_coupling
long_name = instantaneous net uv+vis diff downward sw flux
@@ -1735,6 +1883,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[t2mi_cpl]
standard_name = instantaneous_temperature_at_2m_for_coupling
long_name = instantaneous T2m
@@ -1742,6 +1891,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[q2mi_cpl]
standard_name = instantaneous_specific_humidity_at_2m_for_coupling
long_name = instantaneous Q2m
@@ -1749,6 +1899,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[u10mi_cpl]
standard_name = instantaneous_x_wind_at_10m_for_coupling
long_name = instantaneous U10m
@@ -1756,6 +1907,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling .or. flag_for_wave_coupling)
[v10mi_cpl]
standard_name = instantaneous_y_wind_at_10m_for_coupling
long_name = instantaneous V10m
@@ -1763,6 +1915,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling .or. flag_for_wave_coupling)
[tsfci_cpl]
standard_name = instantaneous_surface_skin_temperature_for_coupling
long_name = instantaneous sfc temperature
@@ -1770,6 +1923,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[psurfi_cpl]
standard_name = instantaneous_surface_air_pressure_for_coupling
long_name = instantaneous sfc pressure
@@ -1777,6 +1931,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[ulwsfcin_cpl]
standard_name = surface_upwelling_longwave_flux_for_coupling
long_name = surface upwelling LW flux for coupling
@@ -1784,6 +1939,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dusfcin_cpl]
standard_name = surface_x_momentum_flux_for_coupling
long_name = sfc x momentum flux for coupling
@@ -1791,6 +1947,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dvsfcin_cpl]
standard_name = surface_y_momentum_flux_for_coupling
long_name = sfc y momentum flux for coupling
@@ -1798,6 +1955,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dtsfcin_cpl]
standard_name = surface_upward_sensible_heat_flux_for_coupling
long_name = sfc sensible heat flux input
@@ -1805,6 +1963,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[dqsfcin_cpl]
standard_name = surface_upward_latent_heat_flux_for_coupling
long_name = sfc latent heat flux input for coupling
@@ -1812,6 +1971,14 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
+[hsnoin_cpl]
+ standard_name = surface_snow_thickness_for_coupling
+ long_name = sfc snow depth in meters over sea ice for coupling
+ 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)
@@ -1819,6 +1986,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling)
[ca_deep]
standard_name = fraction_of_cellular_automata_for_deep_convection
long_name = fraction of cellular automata for deep convection
@@ -1826,6 +1994,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_cellular_automata)
[vfact_ca]
standard_name = vertical_weight_for_ca
long_name = vertical weight for ca
@@ -1840,6 +2009,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_cellular_automata)
[condition]
standard_name = physics_field_for_coupling
long_name = physics_field_for_coupling
@@ -1854,6 +2024,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_stochastic_shum_option)
[sppt_wts]
standard_name = weights_for_stochastic_sppt_perturbation
long_name = weights for stochastic sppt perturbation
@@ -1861,6 +2032,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_stochastic_physics_perturbations .or. flag_for_global_cellular_automata)
[skebu_wts]
standard_name = weights_for_stochastic_skeb_perturbation_of_x_wind
long_name = weights for stochastic skeb perturbation of x wind
@@ -1868,6 +2040,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_stochastic_skeb_option)
[skebv_wts]
standard_name = weights_for_stochastic_skeb_perturbation_of_y_wind
long_name = weights for stochastic skeb perturbation of y wind
@@ -1875,13 +2048,15 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_stochastic_skeb_option)
[sfc_wts]
standard_name = weights_for_stochastic_surface_physics_perturbation
long_name = weights for stochastic surface physics perturbation
units = none
- dimensions = (horizontal_dimension,number_of_surface_perturbations)
+ dimensions = (horizontal_dimension,number_of_land_surface_variables_perturbed)
type = real
kind = kind_phys
+ active = (index_for_stochastic_land_surface_perturbation_type .ne. 0)
[dqdti]
standard_name = instantaneous_water_vapor_specific_humidity_tendency_due_to_convection
long_name = instantaneous moisture tendency due to convection
@@ -1889,6 +2064,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_chemistry_coupling)
[nwfa2d]
standard_name = tendency_of_water_friendly_aerosols_at_surface
long_name = instantaneous water-friendly sfc aerosol source
@@ -1912,6 +2088,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_chemistry_coupling)
[dkt]
standard_name = instantaneous_atmosphere_heat_diffusivity
long_name = instantaneous atmospheric heat diffusivity
@@ -1919,6 +2096,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_chemistry_coupling)
[qci_conv]
standard_name = convective_cloud_condesate_after_rainout
long_name = convective cloud condesate after rainout
@@ -1926,7 +2104,13 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme)
########################################################################
+[ccpp-table-properties]
+ name = GFS_control_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_control_type
type = ddt
@@ -2284,14 +2468,20 @@
units = flag
dimensions = ()
type = integer
+[iovr]
+ standard_name = flag_for_cloud_overlap_method_for_radiation
+ long_name = max-random overlap clouds
+ units = flag
+ dimensions = ()
+ type = integer
[iovr_sw]
- standard_name = flag_for_max_random_overlap_clouds_for_shortwave_radiation
+ standard_name = flag_for_cloud_overlap_method_for_shortwave_radiation
long_name = sw: max-random overlap clouds
units = flag
dimensions = ()
type = integer
[iovr_lw]
- standard_name = flag_for_max_random_overlap_clouds_for_longwave_radiation
+ standard_name = flag_for_cloud_overlap_method_for_longwave_radiation
long_name = lw: max-random overlap clouds
units = flag
dimensions = ()
@@ -3504,14 +3694,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
@@ -3670,8 +3860,8 @@
type = real
kind = kind_phys
[do_sppt]
- standard_name = flag_for_stochastic_surface_physics_perturbations
- long_name = flag for stochastic surface physics perturbations
+ standard_name = flag_for_stochastic_physics_perturbations
+ long_name = flag for stochastic physics perturbations
units = flag
dimensions = ()
type = logical
@@ -3693,60 +3883,32 @@
units = flag
dimensions = ()
type = logical
-[do_sfcperts]
- standard_name = flag_for_stochastic_surface_perturbations
- long_name = flag for stochastic surface perturbations option
- units = flag
+[lndp_type]
+ standard_name = index_for_stochastic_land_surface_perturbation_type
+ long_name = index for stochastic land surface perturbations type
+ units = index
dimensions = ()
- type = logical
-[nsfcpert]
- standard_name = number_of_surface_perturbations
- long_name = number of surface perturbations
+ type = integer
+[n_var_lndp]
+ standard_name = number_of_land_surface_variables_perturbed
+ long_name = number of land surface variables perturbed
units = count
dimensions = ()
type = integer
-[pertz0]
- standard_name = magnitude_of_perturbation_of_momentum_roughness_length
- long_name = magnitude of perturbation of momentum roughness length
- units = frac
- dimensions = (5)
- type = real
- kind = kind_phys
-[pertzt]
- standard_name = magnitude_of_perturbation_of_heat_to_momentum_roughness_length_ratio
- long_name = magnitude of perturbation of heat to momentum roughness length ratio
- units = frac
- dimensions = (5)
- type = real
- kind = kind_phys
-[pertshc]
- standard_name = magnitude_of_perturbation_of_soil_type_b_parameter
- long_name = magnitude of perturbation of soil type b parameter
- units = frac
- dimensions = (5)
- type = real
- kind = kind_phys
-[pertlai]
- standard_name = magnitude_of_perturbation_of_leaf_area_index
- long_name = magnitude of perturbation of leaf area index
- units = frac
- dimensions = (5)
- type = real
- kind = kind_phys
-[pertalb]
- standard_name = magnitude_of_surface_albedo_perturbation
- long_name = magnitude of surface albedo perturbation
- units = frac
- dimensions = (5)
- type = real
- kind = kind_phys
-[pertvegf]
- standard_name = magnitude_of_perturbation_of_vegetation_fraction
- long_name = magnitude of perturbation of vegetation fraction
- units = frac
- dimensions = (5)
+[lndp_prt_list]
+ standard_name =magnitude_of_perturbations_for_landperts
+ long_name = magnitude of perturbations for landperts
+ units = variable
+ dimensions = (number_of_land_surface_variables_perturbed)
type = real
kind = kind_phys
+[lndp_var_list]
+ standard_name = variables_to_be_perturbed_for_landperts
+ long_name = variables to be perturbed for landperts
+ units = none
+ dimensions = (number_of_land_surface_variables_perturbed)
+ type = character
+ kind = len=3
[ntrac]
standard_name = number_of_tracers
long_name = number of tracers
@@ -4336,6 +4498,11 @@
type = logical
########################################################################
+[ccpp-table-properties]
+ name = GFS_grid_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_grid_type
type = ddt
@@ -4388,8 +4555,20 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+[xlon_d]
+ standard_name = longitude_in_degree
+ long_name = longitude in degree east
+ units = degree_east
+ dimensions = (horizontal_dimension)
+ type = real
+ kind = kind_phys
########################################################################
+[ccpp-table-properties]
+ name = GFS_tbd_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_tbd_type
type = ddt
@@ -4399,12 +4578,14 @@
units = none
dimensions = (horizontal_dimension)
type = integer
+ active = (flag_for_lw_clouds_without_sub_grid_approximation == 2 .or. flag_for_sw_clouds_without_sub_grid_approximation == 2)
[icsdlw]
standard_name = seed_random_numbers_lw
long_name = random seeds for sub-column cloud generators lw
units = none
dimensions = (horizontal_dimension)
type = integer
+ active = (flag_for_lw_clouds_without_sub_grid_approximation == 2 .or. flag_for_sw_clouds_without_sub_grid_approximation == 2)
[ozpl]
standard_name = ozone_forcing
long_name = ozone forcing data
@@ -4494,6 +4675,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_stochastic_physics_perturbations .or. flag_for_global_cellular_automata)
[drain_cpl]
standard_name = tendency_of_lwe_thickness_of_precipitation_amount_for_coupling
long_name = change in rain_cpl (coupling_type)
@@ -4501,6 +4683,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling .or. flag_for_chemistry_coupling)
[dsnow_cpl]
standard_name = tendency_of_lwe_thickness_of_snow_amount_for_coupling
long_name = change in show_cpl (coupling_type)
@@ -4508,6 +4691,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_flux_coupling .or. flag_for_chemistry_coupling)
[phy_fctd]
standard_name = cloud_base_mass_flux
long_name = cloud base mass flux for CS convection
@@ -4515,6 +4699,7 @@
dimensions = (horizontal_dimension,number_of_cloud_types_CS)
type = real
kind = kind_phys
+ active = (number_of_cloud_types_CS > 0 .and. flag_for_Chikira_Sugiyama_deep_convection)
[phy_f2d(:,1)]
standard_name = surface_air_pressure_two_time_steps_back
long_name = surface air pressure two time steps back
@@ -4648,6 +4833,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme .or. flag_for_mass_flux_deep_convection_scheme == flag_for_ntiedtke_deep_convection_scheme)
[forceq]
standard_name = moisture_tendency_due_to_dynamics
long_name = moisture tendency due to dynamics only
@@ -4655,6 +4841,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme .or. flag_for_mass_flux_deep_convection_scheme == flag_for_ntiedtke_deep_convection_scheme)
[prevst]
standard_name = temperature_from_previous_timestep
long_name = temperature from previous time step
@@ -4662,6 +4849,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme .or. flag_for_mass_flux_deep_convection_scheme == flag_for_ntiedtke_deep_convection_scheme)
[prevsq]
standard_name = moisture_from_previous_timestep
long_name = moisture from previous time step
@@ -4669,12 +4857,14 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme .or. flag_for_mass_flux_deep_convection_scheme == flag_for_ntiedtke_deep_convection_scheme)
[cactiv]
standard_name = conv_activity_counter
long_name = convective activity memory
units = none
dimensions = (horizontal_dimension)
type = integer
+ active = (flag_for_mass_flux_deep_convection_scheme == flag_for_gf_deep_convection_scheme)
[CLDFRA_BL]
standard_name = subgrid_cloud_fraction_pbl
long_name = subgrid cloud fraction from PBL scheme
@@ -4682,6 +4872,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[QC_BL]
standard_name = subgrid_cloud_water_mixing_ratio_pbl
long_name = subgrid cloud water mixing ratio from PBL scheme
@@ -4689,6 +4880,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[QI_BL]
standard_name = subgrid_cloud_ice_mixing_ratio_pbl
long_name = subgrid cloud ice mixing ratio from PBL scheme
@@ -4696,6 +4888,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[el_pbl]
standard_name = mixing_length
long_name = mixing length in meters
@@ -4703,6 +4896,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[Sh3D]
standard_name = stability_function_for_heat
long_name = stability function for heat
@@ -4710,6 +4904,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[qke]
standard_name = tke_at_mass_points
long_name = 2 x tke at mass points
@@ -4717,6 +4912,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[tsq]
standard_name = t_prime_squared
long_name = temperature fluctuation squared
@@ -4724,6 +4920,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[qsq]
standard_name = q_prime_squared
long_name = water vapor fluctuation squared
@@ -4731,6 +4928,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[cov]
standard_name = t_prime_q_prime
long_name = covariance of temperature and moisture
@@ -4738,6 +4936,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[phy_myj_qsfc]
standard_name = surface_specific_humidity_for_MYJ_schemes
long_name = surface air saturation specific humidity for MYJ schemes
@@ -4745,6 +4944,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_thz0]
standard_name = potential_temperature_at_viscous_sublayer_top
long_name = potential temperature at viscous sublayer top over water
@@ -4752,6 +4952,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_qz0]
standard_name = specific_humidity_at_viscous_sublayer_top
long_name = specific humidity at_viscous sublayer top over water
@@ -4759,6 +4960,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_uz0]
standard_name = u_wind_component_at_viscous_sublayer_top
long_name = u wind component at viscous sublayer top over water
@@ -4766,6 +4968,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_vz0]
standard_name = v_wind_component_at_viscous_sublayer_top
long_name = v wind component at viscous sublayer top over water
@@ -4773,6 +4976,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_z0base]
standard_name = baseline_surface_roughness_length
long_name = baseline surface roughness length for momentum in meter
@@ -4780,6 +4984,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_akhs]
standard_name = heat_exchange_coefficient_for_MYJ_schemes
long_name = surface heat exchange_coefficient for MYJ schemes
@@ -4787,6 +4992,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_akms]
standard_name = momentum_exchange_coefficient_for_MYJ_schemes
long_name = surface momentum exchange_coefficient for MYJ schemes
@@ -4794,6 +5000,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_chkqlm]
standard_name = surface_layer_evaporation_switch
long_name = surface layer evaporation switch
@@ -4801,6 +5008,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_elflx]
standard_name = kinematic_surface_latent_heat_flux
long_name = kinematic surface latent heat flux
@@ -4808,6 +5016,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_a1u]
standard_name = weight_for_momentum_at_viscous_sublayer_top
long_name = weight for momentum at viscous layer top
@@ -4815,6 +5024,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_a1t]
standard_name = weight_for_potental_temperature_at_viscous_sublayer_top
long_name = weight for potental temperature at viscous layer top
@@ -4822,6 +5032,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
[phy_myj_a1q]
standard_name = weight_for_specific_humidity_at_viscous_sublayer_top
long_name = weight for Specfic Humidity at viscous layer top
@@ -4829,8 +5040,14 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_myjsfc .or. do_myjpbl)
########################################################################
+[ccpp-table-properties]
+ name = GFS_cldprop_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_cldprop_type
type = ddt
@@ -4857,6 +5074,11 @@
kind = kind_phys
########################################################################
+[ccpp-table-properties]
+ name = GFS_radtend_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_radtend_type
type = ddt
@@ -4944,6 +5166,11 @@
kind = kind_phys
########################################################################
+[ccpp-table-properties]
+ name = GFS_diag_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_diag_type
type = ddt
@@ -5064,6 +5291,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dvsfc_ls]
standard_name = integrated_y_momentum_flux_from_large_scale_gwd
long_name = integrated y momentum flux from large scale gwd
@@ -5071,6 +5299,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dusfc_bl]
standard_name = integrated_x_momentum_flux_from_blocking_drag
long_name = integrated x momentum flux from blocking drag
@@ -5078,6 +5307,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dvsfc_bl]
standard_name = integrated_y_momentum_flux_from_blocking_drag
long_name = integrated y momentum flux from blocking drag
@@ -5085,6 +5315,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dusfc_ss]
standard_name = integrated_x_momentum_flux_from_small_scale_gwd
long_name = integrated x momentum flux from small scale gwd
@@ -5092,6 +5323,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dvsfc_ss]
standard_name = integrated_y_momentum_flux_from_small_scale_gwd
long_name = integrated y momentum flux from small scale gwd
@@ -5099,6 +5331,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dusfc_fd]
standard_name = integrated_x_momentum_flux_from_form_drag
long_name = integrated x momentum flux from form drag
@@ -5106,6 +5339,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dvsfc_fd]
standard_name = integrated_y_momentum_flux_from_form_drag
long_name = integrated y momentum flux from form drag
@@ -5113,6 +5347,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dtaux2d_ls]
standard_name = x_momentum_tendency_from_large_scale_gwd
long_name = x momentum tendency from large scale gwd
@@ -5120,6 +5355,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dtauy2d_ls]
standard_name = y_momentum_tendency_from_large_scale_gwd
long_name = y momentum tendency from large scale gwd
@@ -5127,6 +5363,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dtaux2d_bl]
standard_name = x_momentum_tendency_from_blocking_drag
long_name = x momentum tendency from blocking drag
@@ -5134,6 +5371,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dtauy2d_bl]
standard_name = y_momentum_tendency_from_blocking_drag
long_name = y momentum tendency from blocking drag
@@ -5141,6 +5379,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dtaux2d_ss]
standard_name = x_momentum_tendency_from_small_scale_gwd
long_name = x momentum tendency from small scale gwd
@@ -5148,12 +5387,14 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dtauy2d_ss]
standard_name = y_momentum_tendency_from_small_scale_gwd
long_name = y momentum tendency from small scale gwd
units = m s-2
dimensions = (horizontal_dimension,vertical_dimension)
type = real
+ active = (gwd_opt == 33)
kind = kind_phys
[dtaux2d_fd]
standard_name = x_momentum_tendency_from_form_drag
@@ -5162,6 +5403,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[dtauy2d_fd]
standard_name = y_momentum_tendency_from_form_drag
long_name = y momentum tendency from form drag
@@ -5169,6 +5411,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 33)
[totprcp]
standard_name = accumulated_lwe_thickness_of_precipitation_amount
long_name = accumulated total precipitation
@@ -5232,6 +5475,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[gflux]
standard_name = cumulative_surface_ground_heat_flux_multiplied_by_timestep
long_name = cumulative groud conductive heat flux multiplied by timestep
@@ -5596,6 +5840,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (.not. flag_for_land_surface_scheme == flag_for_ruc_land_surface_scheme)
[tdomr]
standard_name = dominant_rain_type
long_name = dominant rain type
@@ -5715,6 +5960,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_diagnostics_3D)
[dv3dt(:,:,1)]
standard_name = cumulative_change_in_y_wind_due_to_PBL
long_name = cumulative change in y wind due to PBL
@@ -5771,6 +6017,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_diagnostics_3D)
[dt3dt(:,:,1)]
standard_name = cumulative_change_in_temperature_due_to_longwave_radiation
long_name = cumulative change in temperature due to longwave radiation
@@ -5848,6 +6095,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_diagnostics_3D)
[dq3dt(:,:,1)]
standard_name = cumulative_change_in_water_vapor_specific_humidity_due_to_PBL
long_name = cumulative change in water vapor specific humidity due to PBL
@@ -5939,6 +6187,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_diagnostics_3D .and. flag_tracer_diagnostics_3D)
[refdmax]
standard_name = maximum_reflectivity_at_1km_agl_over_maximum_hourly_time_interval
long_name = maximum reflectivity at 1km agl over maximum hourly time interval
@@ -6009,6 +6258,13 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+[cldfra]
+ standard_name = instantaneous_3d_cloud_fraction
+ long_name = instantaneous 3D cloud fraction for all MPs
+ units = frac
+ dimensions = (horizontal_dimension,vertical_dimension)
+ type = real
+ kind = kind_phys
[ndust]
standard_name = number_of_dust_bins_for_diagnostics
long_name = number of dust bins for diagnostics
@@ -6034,6 +6290,7 @@
dimensions = (horizonal_dimension,number_of_dust_bins_for_diagnostics)
type = real
kind = kind_phys
+ active = (number_of_dust_bins_for_diagnostics > 0)
[ssem]
standard_name = instantaneous_seasalt_emission_flux
long_name = instantaneous sea salt emission flux
@@ -6041,6 +6298,7 @@
dimensions = (horizonal_dimension,number_of_seasalt_bins_for_diagnostics)
type = real
kind = kind_phys
+ active = (number_of_seasalt_bins_for_diagnostics > 0)
[sedim]
standard_name = instantaneous_sedimentation
long_name = instantaneous sedimentation
@@ -6048,6 +6306,7 @@
dimensions = (horizonal_dimension,number_of_chemical_tracers_for_diagnostics)
type = real
kind = kind_phys
+ active = (number_of_chemical_tracers_for_diagnostics > 0)
[drydep]
standard_name = instantaneous_dry_deposition
long_name = instantaneous dry deposition
@@ -6055,6 +6314,7 @@
dimensions = (horizonal_dimension,number_of_chemical_tracers_for_diagnostics)
type = real
kind = kind_phys
+ active = (number_of_chemical_tracers_for_diagnostics > 0)
[wetdpl]
standard_name = instantaneous_large_scale_wet_deposition
long_name = instantaneous large-scale wet deposition
@@ -6062,6 +6322,7 @@
dimensions = (horizonal_dimension,number_of_chemical_tracers_for_diagnostics)
type = real
kind = kind_phys
+ active = (number_of_chemical_tracers_for_diagnostics > 0)
[wetdpc]
standard_name = instantaneous_convective_scale_wet_deposition
long_name = instantaneous convective-scale wet deposition
@@ -6069,6 +6330,7 @@
dimensions = (horizonal_dimension,number_of_chemical_tracers_for_diagnostics)
type = real
kind = kind_phys
+ active = (number_of_chemical_tracers_for_diagnostics > 0)
[abem]
standard_name = instantaneous_anthopogenic_and_biomass_burning_emissions
long_name = instantaneous anthopogenic and biomass burning emissions for black carbon, organic carbon, and sulfur dioxide
@@ -6090,6 +6352,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[edmf_w]
standard_name = emdf_updraft_vertical_velocity
long_name = updraft vertical velocity from mass flux scheme
@@ -6097,6 +6360,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[edmf_qt]
standard_name = emdf_updraft_total_water
long_name = updraft total water from mass flux scheme
@@ -6104,6 +6368,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[edmf_thl]
standard_name = emdf_updraft_theta_l
long_name = updraft theta-l from mass flux scheme
@@ -6111,6 +6376,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[edmf_ent]
standard_name = emdf_updraft_entrainment_rate
long_name = updraft entranment rate from mass flux scheme
@@ -6118,6 +6384,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[edmf_qc]
standard_name = emdf_updraft_cloud_water
long_name = updraft cloud water from mass flux scheme
@@ -6125,6 +6392,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[sub_thl]
standard_name = theta_subsidence_tendency
long_name = updraft theta subsidence tendency
@@ -6132,6 +6400,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[sub_sqv]
standard_name = water_vapor_subsidence_tendency
long_name = updraft water vapor subsidence tendency
@@ -6139,6 +6408,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[det_thl]
standard_name = theta_detrainment_tendency
long_name = updraft theta detrainment tendency
@@ -6146,6 +6416,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[det_sqv]
standard_name = water_vapor_detrainment_tendency
long_name = updraft water vapor detrainment tendency
@@ -6153,12 +6424,14 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf .and. (mynn_output_flag .ne. 0))
[nupdraft]
standard_name = number_of_plumes
long_name = number of plumes per grid column
units = count
dimensions = (horizontal_dimension)
type = integer
+ active = (do_mynnedmf)
[maxMF]
standard_name = maximum_mass_flux
long_name = maximum mass flux within a column
@@ -6166,6 +6439,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[ktop_shallow]
standard_name = k_level_of_highest_reaching_plume
long_name = k-level of highest reaching plume
@@ -6178,6 +6452,7 @@
units = count
dimensions = (horizontal_dimension)
type = integer
+ active = (do_mynnedmf)
[exch_h]
standard_name = atmosphere_heat_diffusivity_for_mynnpbl
long_name = diffusivity for heat for MYNN PBL (defined for all mass levels)
@@ -6185,6 +6460,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[exch_m]
standard_name = atmosphere_momentum_diffusivity_for_mynnpbl
long_name = diffusivity for momentum for MYNN PBL (defined for all mass levels)
@@ -6192,6 +6468,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (do_mynnedmf)
[zmtb]
standard_name = time_integral_of_height_of_mountain_blocking
long_name = time integral of height of mountain blocking drag
@@ -6248,6 +6525,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (diag_ugwp_flag)
[du3dt_ogw]
standard_name = time_integral_of_change_in_x_wind_due_to_orographic_gravity_wave_drag
long_name = time integral of change in x wind due to orographic gw drag
@@ -6255,6 +6533,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (diag_ugwp_flag)
[du3dt_tms]
standard_name = time_integral_of_change_in_x_wind_due_to_turbulent_orographic_form_drag
long_name = time integral of change in x wind due to TOFD
@@ -6262,6 +6541,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (diag_ugwp_flag)
[du3dt_ngw]
standard_name = time_integral_of_change_in_x_wind_due_to_nonstationary_gravity_wave
long_name = time integral of change in x wind due to NGW
@@ -6269,6 +6549,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (diag_ugwp_flag)
[dv3dt_ngw]
standard_name = time_integral_of_change_in_y_wind_due_to_nonstationary_gravity_wave
long_name = time integral of change in y wind due to NGW
@@ -6276,6 +6557,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (diag_ugwp_flag)
[aux2d]
standard_name = auxiliary_2d_arrays
long_name = auxiliary 2d arrays to output (for debugging)
@@ -6283,6 +6565,7 @@
dimensions = (horizontal_dimension,number_of_3d_auxiliary_arrays)
type = real
kind = kind_phys
+ active = (number_of_2d_auxiliary_arrays > 0)
[aux3d]
standard_name = auxiliary_3d_arrays
long_name = auxiliary 3d arrays to output (for debugging)
@@ -6290,9 +6573,15 @@
dimensions = (horizontal_dimension,vertical_dimension,number_of_3d_auxiliary_arrays)
type = real
kind = kind_phys
+ active = (number_of_2d_auxiliary_arrays > 0)
########################################################################
+[ccpp-table-properties]
+ name = GFS_interstitial_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_interstitial_type
type = ddt
@@ -6303,6 +6592,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[qc_r]
standard_name = cloud_liquid_water_mixing_ratio
long_name = the ratio of the mass of liquid water to the mass of dry air
@@ -6310,6 +6600,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[qr_r]
standard_name = cloud_rain_water_mixing_ratio
long_name = the ratio of the mass rain water to the mass of dry air
@@ -6317,6 +6608,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[qi_r]
standard_name = cloud_ice_mixing_ratio
long_name = the ratio of the mass of ice to the mass of dry air
@@ -6324,6 +6616,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[qs_r]
standard_name = cloud_snow_mixing_ratio
long_name = the ratio of the mass of snow to mass of dry air
@@ -6331,6 +6624,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[qg_r]
standard_name = mass_weighted_rime_factor_mixing_ratio
long_name = the ratio of the mass of rime factor to mass of dry air
@@ -6338,6 +6632,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[f_ice]
standard_name = fraction_of_ice_water_cloud
long_name = fraction of ice water cloud
@@ -6345,6 +6640,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[f_rain]
standard_name = fraction_of_rain_water_cloud
long_name = fraction of rain water cloud
@@ -6352,6 +6648,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[f_rimef]
standard_name = rime_factor
long_name = rime factor
@@ -6359,6 +6656,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[cwm]
standard_name = total_cloud_condensate_mixing_ratio_updated_by_physics
long_name = total cloud condensate mixing ratio (except water vapor) updated by physics
@@ -6366,6 +6664,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_fer_hires_microphysics_scheme)
[adjsfculw_ocean]
standard_name = surface_upwelling_longwave_flux_over_ocean_interstitial
long_name = surface upwelling longwave flux at current time over ocean (temporary use as interstitial)
@@ -6457,6 +6756,13 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+[alpha]
+ standard_name = cloud_overlap_decorrelation_parameter
+ long_name = cloud overlap decorrelation parameter for RRTMG (but not for RRTMGP)
+ units = frac
+ dimensions = (horizontal_dimension,adjusted_vertical_layer_dimension_for_radiation)
+ type = real
+ kind = kind_phys
[bexp1d]
standard_name = perturbation_of_soil_type_b_parameter
long_name = perturbation of soil type "b" parameter
@@ -6548,6 +6854,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[clcn]
standard_name = convective_cloud_volume_fraction
long_name = convective cloud volume fraction
@@ -6555,6 +6862,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[cldf]
standard_name = cloud_area_fraction
long_name = fraction of grid box area in which updrafts occur
@@ -6695,6 +7003,7 @@
dimensions = (horizontal_dimension,4)
type = real
kind = kind_phys
+ active = (gwd_opt == 3 .or. gwd_opt == 33)
[cmm_ocean]
standard_name = surface_drag_wind_speed_for_momentum_in_air_over_ocean
long_name = momentum exchange coefficient over ocean
@@ -6723,6 +7032,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[cnv_fice]
standard_name = ice_fraction_in_convective_tower
long_name = ice fraction in convective tower
@@ -6730,6 +7040,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[cnv_mfd]
standard_name = detrained_mass_flux
long_name = detrained mass flux
@@ -6737,6 +7048,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[cnv_ndrop]
standard_name = number_concentration_of_cloud_liquid_water_particles_for_detrainment
long_name = droplet number concentration in convective detrainment
@@ -6744,6 +7056,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[cnv_nice]
standard_name = number_concentration_of_ice_crystals_for_detrainment
long_name = crystal number concentration in convective detrainment
@@ -6751,6 +7064,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[cnvc]
standard_name = convective_cloud_cover
long_name = convective cloud cover
@@ -7486,6 +7800,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_gfdl_microphysics_scheme .or. flag_for_microphysics_scheme == flag_for_thompson_microphysics_scheme)
[gwdcu]
standard_name = tendency_of_x_wind_due_to_convective_gravity_wave_drag
long_name = zonal wind tendency due to convective gravity wave drag
@@ -7590,6 +7905,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_gfdl_microphysics_scheme .or. flag_for_microphysics_scheme == flag_for_thompson_microphysics_scheme)
[dry]
standard_name = flag_nonzero_land_surface_fraction
long_name = flag indicating presence of some land surface area fraction
@@ -7771,6 +8087,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[ncpi]
standard_name = local_ice_number_concentration
long_name = number concentration of ice local to physics
@@ -7778,6 +8095,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_shoc)
[ncpl]
standard_name = local_condesed_water_number_concentration
long_name = number concentration of condensed water local to physics
@@ -7785,6 +8103,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_shoc)
[ncpr]
standard_name = local_rain_number_concentration
long_name = number concentration of rain local to physics
@@ -7792,6 +8111,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[ncps]
standard_name = local_snow_number_concentration
long_name = number concentration of snow local to physics
@@ -7799,6 +8119,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[ncstrac]
standard_name = number_of_tracers_for_CS
long_name = number of convectively transported tracers in Chikira-Sugiyama deep convection scheme
@@ -7891,6 +8212,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 3 .or. gwd_opt == 33)
[oa4ss]
standard_name = asymmetry_of_subgrid_orography_small_scale
long_name = asymmetry of subgrid orography small scale
@@ -7898,6 +8220,7 @@
dimensions = (horizontal_dimension,4)
type = real
kind = kind_phys
+ active = (gwd_opt == 3 .or. gwd_opt == 33)
[oc]
standard_name = convexity_of_subgrid_orography
long_name = convexity of subgrid orography
@@ -7912,6 +8235,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (gwd_opt == 3 .or. gwd_opt == 33)
[olyr]
standard_name = ozone_concentration_at_layer_for_radiation
long_name = ozone concentration layer
@@ -7978,6 +8302,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[qgl]
standard_name = local_graupel_mixing_ratio
long_name = ratio of mass of graupel to mass of dry air plus vapor (without condensates) local to physics
@@ -7985,6 +8310,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme .or. flag_for_shoc)
[qicn]
standard_name = mass_fraction_of_convective_cloud_ice
long_name = mass fraction of convective cloud ice water
@@ -7992,6 +8318,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[qlcn]
standard_name = mass_fraction_of_convective_cloud_liquid_water
long_name = mass fraction of convective cloud liquid water
@@ -7999,6 +8326,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[qlyr]
standard_name = water_vapor_specific_humidity_at_layer_for_radiation
long_name = specific humidity layer
@@ -8013,6 +8341,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme .or. flag_for_shoc)
[qsnw]
standard_name = local_snow_water_mixing_ratio
long_name = ratio of mass of snow water to mass of dry air plus vapor (without condensates) local to physics
@@ -8020,6 +8349,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme .or. flag_for_shoc)
[prcpmp]
standard_name = lwe_thickness_of_explicit_precipitation_amount
long_name = explicit precipitation (rain, ice, snow, graupel, ...) on physics timestep
@@ -8089,6 +8419,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_gfdl_microphysics_scheme .or. flag_for_microphysics_scheme == flag_for_thompson_microphysics_scheme)
[rainp]
standard_name = tendency_of_rain_water_mixing_ratio_due_to_microphysics
long_name = tendency of rain water mixing ratio due to microphysics
@@ -8330,6 +8661,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_gfdl_microphysics_scheme .or. flag_for_microphysics_scheme == flag_for_thompson_microphysics_scheme)
[snowmt]
standard_name = surface_snow_melt
long_name = snow melt during timestep
@@ -8378,6 +8710,7 @@
dimensions = (horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_land_surface_scheme == flag_for_noahmp_land_surface_scheme)
[theta]
standard_name = angle_from_east_of_maximum_subgrid_orographic_variations
long_name = angle with_respect to east of maximum subgrid orographic variations
@@ -8563,6 +8896,13 @@
dimensions = (horizontal_dimension,vertical_dimension,number_of_vertical_diffusion_tracers)
type = real
kind = kind_phys
+[lndp_vgf]
+ standard_name = magnitude_of_perturbation_of_vegetation_fraction
+ long_name = magnitude of perturbation of vegetation fraction
+ units = frac
+ dimensions = ()
+ type = real
+ kind = kind_phys
[vegf1d]
standard_name = perturbation_of_vegetation_fraction
long_name = perturbation of vegetation fraction
@@ -8583,6 +8923,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_microphysics_scheme == flag_for_morrison_gettelman_microphysics_scheme)
[wcbmax]
standard_name = maximum_updraft_velocity_at_cloud_base
long_name = maximum updraft velocity at cloud base
@@ -8800,7 +9141,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[p_lev]
standard_name = air_pressure_at_interface_for_RRTMGP_in_hPa
long_name = air pressure level
@@ -8808,7 +9149,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[t_lay]
standard_name = air_temperature_at_layer_for_RRTMGP
long_name = air temperature layer
@@ -8816,7 +9157,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[t_lev]
standard_name = air_temperature_at_interface_for_RRTMGP
long_name = air temperature layer
@@ -8824,7 +9165,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[tv_lay]
standard_name = virtual_temperature
long_name = layer virtual temperature
@@ -8832,7 +9173,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[relhum]
standard_name = relative_humidity
long_name = layer relative humidity
@@ -8840,6 +9181,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[deltaZ]
standard_name = layer_thickness
long_name = layer_thickness
@@ -8847,6 +9189,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[tracer]
standard_name = chemical_tracers
long_name = chemical tracers
@@ -8854,13 +9197,15 @@
dimensions = (horizontal_dimension,vertical_dimension,number_of_tracers)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[cloud_overlap_param]
standard_name = cloud_overlap_param
- long_name = cloud overlap parameter
+ long_name = cloud overlap parameter for RRTMGP (but not for RRTMG)
units = km
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[precip_overlap_param]
standard_name = precip_overlap_param
long_name = precipitation overlap parameter
@@ -8868,6 +9213,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[ipsdsw0]
standard_name = initial_permutation_seed_sw
long_name = initial seed for McICA SW
@@ -8887,7 +9233,6 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
- optional = F
[cldtaulw]
standard_name = RRTMGP_cloud_optical_depth_layers_at_10mu_band
long_name = approx 10mu band layer cloud optical depth
@@ -8902,7 +9247,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[fluxlwDOWN_allsky]
standard_name = RRTMGP_lw_flux_profile_downward_allsky
long_name = RRTMGP downward longwave all-sky flux profile
@@ -8910,7 +9255,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[fluxlwUP_clrsky]
standard_name = RRTMGP_lw_flux_profile_upward_clrsky
long_name = RRTMGP upward longwave clr-sky flux profile
@@ -8918,7 +9263,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[fluxlwDOWN_clrsky]
standard_name = RRTMGP_lw_flux_profile_downward_clrsky
long_name = RRTMGP downward longwave clr-sky flux profile
@@ -8926,6 +9271,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[sktp1r]
standard_name = surface_skin_temperature_at_previous_time_step
long_name = surface skin temperature at previous time step
@@ -8954,7 +9300,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[fluxswDOWN_allsky]
standard_name = RRTMGP_sw_flux_profile_downward_allsky
long_name = RRTMGP downward shortwave all-sky flux profile
@@ -8962,7 +9308,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[fluxswUP_clrsky]
standard_name = RRTMGP_sw_flux_profile_upward_clrsky
long_name = RRTMGP upward shortwave clr-sky flux profile
@@ -8970,7 +9316,7 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[fluxswDOWN_clrsky]
standard_name = RRTMGP_sw_flux_profile_downward_clrsky
long_name = RRTMGP downward shortwave clr-sky flux profile
@@ -8978,21 +9324,21 @@
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[flxprf_lw]
standard_name = RRTMGP_lw_fluxes
long_name = lw fluxes total sky / csk and up / down at levels
units = W m-2
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = proflw_type
- optional = T
+ active = (flag_for_rrtmgp_radiation_scheme)
[flxprf_sw]
standard_name = RRTMGP_sw_fluxes
long_name = sw fluxes total sky / csk and up / down at levels
units = W m-2
dimensions = (horizontal_dimension,vertical_dimension_plus_one)
type = profsw_type
- optional = T
+ active = (flag_for_rrtmgp_radiation_scheme)
[aerosolslw]
standard_name = RRTMGP_aerosol_optical_properties_for_longwave_bands_01_16
long_name = aerosol optical properties for longwave bands 01-16
@@ -9000,7 +9346,7 @@
dimensions = (horizontal_dimension,vertical_dimension, number_of_lw_bands_rrtmgp,number_of_aerosol_output_fields_for_longwave_radiation)
type = real
kind = kind_phys
- optional = F
+ active = (flag_for_rrtmgp_radiation_scheme)
[aerosolslw(:,:,:,1)]
standard_name = RRTMGP_aerosol_optical_depth_for_longwave_bands_01_16
long_name = aerosol optical depth for longwave bands 01-16
@@ -9029,6 +9375,7 @@
dimensions = (horizontal_dimension,vertical_dimension, number_of_sw_bands_rrtmgp, number_of_aerosol_output_fields_for_shortwave_radiation)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[aerosolssw(:,:,:,1)]
standard_name = RRTMGP_aerosol_optical_depth_for_shortwave_bands_01_16
long_name = aerosol optical depth for shortwave bands 01-16
@@ -9056,12 +9403,14 @@
units = none
dimensions = (horizontal_dimension)
type = integer
+ active = (flag_for_rrtmgp_radiation_scheme)
[icseed_sw]
standard_name = seed_random_numbers_sw_for_RRTMGP
long_name = seed for random number generation for shortwave radiation
units = none
dimensions = (horizontal_dimension)
type = integer
+ active = (flag_for_rrtmgp_radiation_scheme)
[precip_frac]
standard_name = precipitation_fraction_by_layer
long_name = precipitation fraction in each layer
@@ -9069,6 +9418,7 @@
dimensions = (horizontal_dimension,vertical_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[sw_gas_props]
standard_name = coefficients_for_sw_gas_optics
long_name = DDT containing spectral information for RRTMGP SW radiation scheme
@@ -9184,6 +9534,7 @@
dimensions = (number_of_lw_bands_rrtmgp,horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[sec_diff_byband]
standard_name = secant_of_diffusivity_angle_each_RRTMGP_LW_band
long_name = secant of diffusivity angle in each RRTMGP LW band
@@ -9191,6 +9542,7 @@
dimensions = (number_of_lw_bands_rrtmgp,horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[sfc_alb_nir_dir]
standard_name = surface_albedo_nearIR_direct
long_name = near-IR (direct) surface albedo (sfc_alb_nir_dir)
@@ -9198,6 +9550,7 @@
dimensions = (number_of_sw_bands_rrtmgp,horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[sfc_alb_nir_dif]
standard_name = surface_albedo_nearIR_diffuse
long_name = near-IR (diffuse) surface albedo (sfc_alb_nir_dif)
@@ -9205,6 +9558,7 @@
dimensions = (number_of_sw_bands_rrtmgp,horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[sfc_alb_uvvis_dir]
standard_name = surface_albedo_uvvis_dir
long_name = UVVIS (direct) surface albedo (sfc_alb_uvvis_dir)
@@ -9212,6 +9566,7 @@
dimensions = (number_of_sw_bands_rrtmgp,horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[sfc_alb_uvvis_dif]
standard_name = surface_albedo_uvvis_dif
long_name = UVVIS (diffuse) surface albedo (sfc_alb_uvvis_dif)
@@ -9219,6 +9574,7 @@
dimensions = (number_of_sw_bands_rrtmgp,horizontal_dimension)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[toa_src_lw]
standard_name = toa_incident_lw_flux_by_spectral_point
long_name = TOA longwave incident flux at each spectral points
@@ -9226,6 +9582,7 @@
dimensions = (horizontal_dimension,number_of_lw_spectral_points_rrtmgp)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[toa_src_sw]
standard_name = toa_incident_sw_flux_by_spectral_point
long_name = TOA shortwave incident flux at each spectral points
@@ -9233,6 +9590,7 @@
dimensions = (horizontal_dimension,number_of_sw_spectral_points_rrtmgp)
type = real
kind = kind_phys
+ active = (flag_for_rrtmgp_radiation_scheme)
[active_gases_array]
standard_name = list_of_active_gases_used_by_RRTMGP
long_name = list of active gases used by RRTMGP
@@ -9240,8 +9598,14 @@
dimensions = (number_of_active_gases_used_by_RRTMGP)
type = character
kind = len=128
+ active = (flag_for_rrtmgp_radiation_scheme)
########################################################################
+[ccpp-table-properties]
+ name = GFS_data_type
+ type = ddt
+ dependencies =
+
[ccpp-arg-table]
name = GFS_data_type
type = ddt
@@ -9301,6 +9665,14 @@
type = GFS_diag_type
########################################################################
+[ccpp-table-properties]
+ name = GFS_typedefs
+ type = module
+ relative_path = ../../ccpp/physics/physics
+ dependencies = machine.F,physcons.F90,radlw_param.f,radsw_param.f,GFDL_parse_tracers.F90
+ dependencies = rte-rrtmgp/rrtmgp/mo_gas_optics_rrtmgp.F90,rte-rrtmgp/rte/mo_optical_props.F90,rte-rrtmgp/extensions/cloud_optics/mo_cloud_optics.F90
+ dependencies = rte-rrtmgp/rrtmgp/mo_gas_concentrations.F90,rte-rrtmgp/rte/mo_rte_config.F90,rte-rrtmgp/rte/mo_source_functions.F90
+
[ccpp-arg-table]
name = GFS_typedefs
type = module
@@ -9564,5 +9936,3 @@
dimensions = ()
type = real
kind = kind_phys
- intent = in
- optional = F
diff --git a/gfsphysics/physics/GFS_debug.F90 b/gfsphysics/physics/GFS_debug.F90
index 57bcc0f45..e1953a9ff 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 )
@@ -468,7 +468,7 @@ subroutine GFS_diagtoscreen_run (Model, Statein, Stateout, Sfcprop, Coupling,
call print_var(mpirank,omprank, blkno, 'Coupling%skebu_wts', Coupling%skebu_wts )
call print_var(mpirank,omprank, blkno, 'Coupling%skebv_wts', Coupling%skebv_wts )
end if
- if (Model%do_sfcperts) then
+ if (Model%lndp_type .NE. 0) then
call print_var(mpirank,omprank, blkno, 'Coupling%sfc_wts' , Coupling%sfc_wts )
end if
if (Model%do_ca) then
diff --git a/gfsphysics/physics/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..9ae258a0c 100644
--- a/gfsphysics/physics/radiation_surface.f
+++ b/gfsphysics/physics/radiation_surface.f
@@ -382,7 +382,7 @@ subroutine setalb &
& slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, &
& alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, &
& sncovr, snoalb, albPpert ! sfc-perts, mgehne
- real (kind=kind_phys), dimension(5), intent(in) :: pertalb ! sfc-perts, mgehne
+ real (kind=kind_phys), intent(in) :: pertalb ! sfc-perts, mgehne
! --- outputs
real (kind=kind_phys), dimension(IMAX,NF_ALBD), intent(out) :: &
@@ -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,12 +620,12 @@ subroutine setalb &
! sfc-perts, mgehne ***
! perturb all 4 kinds of surface albedo, sfcalb(:,1:4)
- if (pertalb(1)>0.0) then
+ if (pertalb>0.0) then
do i = 1, imax
do kk=1, 4
! compute beta distribution parameters for all 4 albedos
m = sfcalb(i,kk)
- s = pertalb(1)*m*(1.-m)
+ s = pertalb*m*(1.-m)
alpha = m*m*(1.-m)/(s*s)-m
beta = alpha*(1.-m)/m
! compute beta distribution value corresponding
diff --git a/gfsphysics/physics/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..80e081909 100644
--- a/gfsphysics/physics/sfc_drv.f
+++ b/gfsphysics/physics/sfc_drv.f
@@ -166,21 +166,23 @@ 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
- real (kind=kind_phys), dimension(5), intent(in) :: pertvegf
+ real (kind=kind_phys), intent(in) :: pertvegf
integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp
@@ -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 > zero) then
! compute beta distribution parameters for vegetation fraction
mv = shdfac
- sv = pertvegf(1)*mv*(1.-mv)
- alphav = mv*mv*(1.0-mv)/(sv*sv)-mv
- betav = alphav*(1.0-mv)/mv
+ sv = pertvegf*mv*(one-mv)
+ alphav = mv*mv*(one-mv)/(sv*sv)-mv
+ betav = alphav*(one-mv)/mv
! compute beta distribution value corresponding
! to the given percentile albPpert to use as new albedo
call ppfbet(vegfp,alphav,betav,iflag,vegftmp)
@@ -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..458605c96 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,54 +1308,109 @@ 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
+ if( Model%phour < 1.e-7) then
+!$omp parallel do default(shared) private(nb, ix, tem)
+ do nb = 1, Atm_block%nblks
+ do ix = 1, Atm_block%blksz(nb)
+ !--- 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)
+ 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
+ else
+!$omp parallel do default(shared) private(nb, ix, tem)
+ do nb = 1, Atm_block%nblks
+ do ix = 1, Atm_block%blksz(nb)
+ !--- specify tsfcl/zorll/zorli from existing variable tsfco/zorlo
+ Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix)
+ if (Sfcprop(nb)%slmsk(ix) == 1) then
+ Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix)
+ Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix)
+ else
+ tem = one - Sfcprop(nb)%fice(ix)
+ Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorli(ix) * Sfcprop(nb)%fice(ix) &
+ + Sfcprop(nb)%zorlo(ix) * tem
+ if (Sfcprop(nb)%fice(ix) > min(Model%min_seaice,Model%min_lakeice)) then
+ Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix)
+ endif
+ endif
+ enddo
+ enddo
+ endif
+ endif ! if (Model%frac_grid)
+
+!#ifdef CCPP
+ 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)
- !--- 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)
+ 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 ! if (Model%frac_grid)
+ endif
+!#endif
if (Model%lsm == Model%lsm_noahmp) then
if (nint(sfc_var2(1,1,nvar_s2m+19)) == -66666) then
@@ -1603,11 +1713,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 +1785,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 +1832,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 +1909,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 +1982,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 +2010,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 +2054,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 +2252,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 +2281,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 +2294,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 +2360,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 +2378,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 +2389,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 +2515,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 +2558,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 +2861,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 +2962,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
diff --git a/stochastic_physics/makefile b/stochastic_physics/makefile
index eb721c8c4..c841571a4 100644
--- a/stochastic_physics/makefile
+++ b/stochastic_physics/makefile
@@ -18,7 +18,7 @@ $(info $$ESMF_INC is [${ESMF_INC}])
LIBRARY = libstochastic_physics_wrapper.a
-FFLAGS += -I$(FMS_DIR) -I ../../stochastic_physics -I../ccpp/physics -I../atmos_cubed_sphere
+FFLAGS += -I$(FMS_DIR) -I ../../stochastic_physics -I../ccpp/physics -I../ccpp/build/physics -I../atmos_cubed_sphere
SRCS_f =
diff --git a/stochastic_physics/stochastic_physics_wrapper.F90 b/stochastic_physics/stochastic_physics_wrapper.F90
index 2fb8cafd1..d4803c639 100644
--- a/stochastic_physics/stochastic_physics_wrapper.F90
+++ b/stochastic_physics/stochastic_physics_wrapper.F90
@@ -13,6 +13,12 @@ module stochastic_physics_wrapper_mod
real(kind=kind_phys), dimension(:,:,:), allocatable, save :: skebv_wts
real(kind=kind_phys), dimension(:,:,:), allocatable, save :: sfc_wts
+ real(kind=kind_phys), dimension(:,:,:), allocatable, save :: smc
+ real(kind=kind_phys), dimension(:,:,:), allocatable, save :: stc
+ real(kind=kind_phys), dimension(:,:,:), allocatable, save :: slc
+ real(kind=kind_phys), dimension(:,:), allocatable, save :: vfrac
+ real(kind=kind_phys), dimension(:,:), allocatable, save :: stype
+
! For cellular automata
real(kind=kind_phys), dimension(:,:,:), allocatable, save :: ugrs
real(kind=kind_phys), dimension(:,:,:), allocatable, save :: qgrs
@@ -37,7 +43,7 @@ module stochastic_physics_wrapper_mod
!-------------------------------
! CCPP step
!-------------------------------
- subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block)
+ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block, ierr)
#ifdef OPENMP
use omp_lib
@@ -49,47 +55,56 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block)
use atmosphere_mod, only: Atm, mygrid
use stochastic_physics, only: init_stochastic_physics, run_stochastic_physics
- use stochastic_physics_sfc, only: run_stochastic_physics_sfc
use cellular_automata_global_mod, only: cellular_automata_global
use cellular_automata_sgs_mod, only: cellular_automata_sgs
+ use lndp_apply_perts_mod, only: lndp_apply_perts
+ use namelist_soilveg, only: maxsmc
implicit none
type(GFS_control_type), intent(inout) :: GFS_Control
type(GFS_data_type), intent(inout) :: GFS_Data(:)
type(block_control_type), intent(inout) :: Atm_block
+ integer, intent(out) :: ierr
integer :: nthreads, nb
+ logical :: param_update_flag
#ifdef OPENMP
nthreads = omp_get_max_threads()
#else
nthreads = 1
#endif
+ ierr = 0
! Initialize
initalize_stochastic_physics: if (GFS_Control%kdt==0) then
- if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. GFS_Control%do_sfcperts) then
+ if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type .GT. 0) ) then
! Initialize stochastic physics
call init_stochastic_physics(GFS_Control%levs, GFS_Control%blksz, GFS_Control%dtp, &
GFS_Control%input_nml_file, GFS_Control%fn_nml, GFS_Control%nlunit, GFS_Control%do_sppt, GFS_Control%do_shum, &
- GFS_Control%do_skeb, GFS_Control%do_sfcperts, GFS_Control%use_zmtnblck, GFS_Control%skeb_npass, GFS_Control%nsfcpert, &
- GFS_Control%pertz0, GFS_Control%pertzt, GFS_Control%pertshc, GFS_Control%pertlai, GFS_Control%pertalb, GFS_Control%pertvegf, &
- GFS_Control%ak, GFS_Control%bk, nthreads, GFS_Control%master, GFS_Control%communicator)
+ GFS_Control%do_skeb, GFS_Control%lndp_type, GFS_Control%n_var_lndp, GFS_Control%use_zmtnblck, GFS_Control%skeb_npass, &
+ GFS_Control%lndp_var_list, GFS_Control%lndp_prt_list, &
+ GFS_Control%ak, GFS_Control%bk, nthreads, GFS_Control%master, GFS_Control%communicator, ierr)
+ if (ierr/=0) then
+ write(6,*) 'call to init_stochastic_physics failed'
+ return
+ endif
end if
- ! Get land surface perturbations here (move to "else" block below if wanting to update each time-step)
- if (GFS_Control%do_sfcperts) then
+ if ( GFS_Control%lndp_type .EQ. 1 ) then ! this scheme sets perts once
! Copy blocked data into contiguous arrays; no need to copy sfc_wts in (intent out)
allocate(xlat(1:Atm_block%nblks,maxval(GFS_Control%blksz)))
allocate(xlon(1:Atm_block%nblks,maxval(GFS_Control%blksz)))
- allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs))
+ allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%n_var_lndp))
do nb=1,Atm_block%nblks
xlat(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlat(:)
xlon(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Grid%xlon(:)
end do
- call run_stochastic_physics_sfc(GFS_Control%blksz, xlat=xlat, xlon=xlon, sfc_wts=sfc_wts)
+ call run_stochastic_physics(GFS_Control%levs, GFS_Control%kdt, GFS_Control%phour, GFS_Control%blksz, xlat=xlat, xlon=xlon, &
+ sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, sfc_wts=sfc_wts, &
+ nthreads=nthreads)
! Copy contiguous data back; no need to copy xlat/xlon, these are intent(in) - just deallocate
do nb=1,Atm_block%nblks
GFS_Data(nb)%Coupling%sfc_wts(:,:) = sfc_wts(nb,1:GFS_Control%blksz(nb),:)
@@ -97,8 +112,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block)
deallocate(xlat)
deallocate(xlon)
deallocate(sfc_wts)
- end if
-
+ end if
! Consistency check for cellular automata
if(GFS_Control%do_ca)then
! DH* The current implementation of cellular_automata assumes that all blocksizes are the
@@ -111,7 +125,7 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block)
else initalize_stochastic_physics
- if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb) then
+ if (GFS_Control%do_sppt .OR. GFS_Control%do_shum .OR. GFS_Control%do_skeb .OR. (GFS_Control%lndp_type .EQ. 2) ) then
! Copy blocked data into contiguous arrays; no need to copy weights in (intent(out))
allocate(xlat(1:Atm_block%nblks,maxval(GFS_Control%blksz)))
allocate(xlon(1:Atm_block%nblks,maxval(GFS_Control%blksz)))
@@ -129,11 +143,14 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block)
allocate(skebu_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs))
allocate(skebv_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%levs))
end if
+ if ( GFS_Control%lndp_type .EQ. 2 ) then ! this scheme updates through forecast
+ allocate(sfc_wts(1:Atm_block%nblks,maxval(GFS_Control%blksz),1:GFS_Control%n_var_lndp))
+ end if
+
call run_stochastic_physics(GFS_Control%levs, GFS_Control%kdt, GFS_Control%phour, GFS_Control%blksz, xlat=xlat, xlon=xlon, &
- sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, nthreads=nthreads)
+ sppt_wts=sppt_wts, shum_wts=shum_wts, skebu_wts=skebu_wts, skebv_wts=skebv_wts, sfc_wts=sfc_wts, &
+ nthreads=nthreads)
! Copy contiguous data back; no need to copy xlat/xlon, these are intent(in) - just deallocate
- deallocate(xlat)
- deallocate(xlon)
if (GFS_Control%do_sppt) then
do nb=1,Atm_block%nblks
GFS_Data(nb)%Coupling%sppt_wts(:,:) = sppt_wts(nb,1:GFS_Control%blksz(nb),:)
@@ -154,6 +171,52 @@ subroutine stochastic_physics_wrapper (GFS_Control, GFS_Data, Atm_block)
deallocate(skebu_wts)
deallocate(skebv_wts)
end if
+ if (GFS_Control%lndp_type .EQ. 2) then ! save wts, and apply lndp scheme
+ do nb=1,Atm_block%nblks
+ GFS_Data(nb)%Coupling%sfc_wts(:,:) = sfc_wts(nb,1:GFS_Control%blksz(nb),:)
+ end do
+
+ allocate(smc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil))
+ allocate(slc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil))
+ allocate(stc(1:Atm_block%nblks,maxval(GFS_Control%blksz),GFS_Control%lsoil))
+ allocate(stype(1:Atm_block%nblks,maxval(GFS_Control%blksz)))
+ allocate(vfrac(1:Atm_block%nblks,maxval(GFS_Control%blksz)))
+ do nb=1,Atm_block%nblks
+ stype(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%stype(:)
+ smc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%smc(:,:)
+ slc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%slc(:,:)
+ stc(nb,1:GFS_Control%blksz(nb),:) = GFS_Data(nb)%Sfcprop%stc(:,:)
+ vfrac(nb,1:GFS_Control%blksz(nb)) = GFS_Data(nb)%Sfcprop%vfrac(:)
+ end do
+
+ ! determine whether land paramaters have been over-written
+ if (mod(GFS_Control%kdt,GFS_Control%nscyc) == 1) then ! logic copied from GFS_driver
+ param_update_flag = .true.
+ else
+ param_update_flag = .false.
+ endif
+ call lndp_apply_perts( GFS_Control%blksz, GFS_Control%lsm, GFS_Control%lsoil, GFS_Control%dtf, &
+ GFS_Control%n_var_lndp, GFS_Control%lndp_var_list, GFS_Control%lndp_prt_list, &
+ sfc_wts, xlon, xlat, stype, maxsmc,param_update_flag, smc, slc,stc, vfrac, ierr)
+ if (ierr/=0) then
+ write(6,*) 'call to GFS_apply_lndp failed'
+ return
+ endif
+ deallocate(stype)
+ deallocate(sfc_wts)
+ do nb=1,Atm_block%nblks
+ GFS_Data(nb)%Sfcprop%smc(:,:) = smc(nb,1:GFS_Control%blksz(nb),:)
+ GFS_Data(nb)%Sfcprop%slc(:,:) = slc(nb,1:GFS_Control%blksz(nb),:)
+ GFS_Data(nb)%Sfcprop%stc(:,:) = stc(nb,1:GFS_Control%blksz(nb),:)
+ GFS_Data(nb)%Sfcprop%vfrac(:) = vfrac(nb,1:GFS_Control%blksz(nb))
+ enddo
+ deallocate(smc)
+ deallocate(slc)
+ deallocate(stc)
+ deallocate(vfrac)
+ endif ! lndp block
+ deallocate(xlat)
+ deallocate(xlon)
end if
endif initalize_stochastic_physics