MODULE MODULE_SF_NOAHMPLSM
IMPLICIT NONE
public :: noahmp_options
public :: NOAHMP_SFLX
private :: ATM
private :: PHENOLOGY
private :: PRECIP_HEAT
private :: ENERGY
private :: THERMOPROP
private :: CSNOW
private :: TDFCND
private :: RADIATION
private :: ALBEDO
private :: SNOW_AGE
private :: SNOWALB_BATS
private :: SNOWALB_CLASS
private :: GROUNDALB
private :: TWOSTREAM
private :: SURRAD
private :: VEGE_FLUX
private :: SFCDIF1
private :: SFCDIF2
private :: STOMATA
private :: CANRES
private :: ESAT
private :: RAGRB
private :: BARE_FLUX
private :: TSNOSOI
private :: HRT
private :: HSTEP
private :: ROSR12
private :: PHASECHANGE
private :: FRH2O
private :: WATER
private :: CANWATER
private :: SNOWWATER
private :: SNOWFALL
private :: COMBINE
private :: DIVIDE
private :: COMBO
private :: COMPACT
private :: SNOWH2O
private :: SOILWATER
private :: ZWTEQ
private :: INFIL
private :: SRT
private :: WDFCND1
private :: WDFCND2
private :: SSTEP
private :: GROUNDWATER
private :: SHALLOWWATERTABLE
private :: CARBON
private :: CO2FLUX
private :: ERROR
INTEGER :: DVEG
INTEGER :: OPT_CRS
INTEGER :: OPT_BTR
INTEGER :: OPT_RUN
INTEGER :: OPT_SFC
INTEGER :: OPT_FRZ
INTEGER :: OPT_INF
INTEGER :: OPT_RAD
INTEGER :: OPT_ALB
INTEGER :: OPT_SNF
INTEGER :: OPT_TBOT
INTEGER :: OPT_STC
INTEGER :: OPT_RSF
REAL, PARAMETER :: GRAV = 9.80616
REAL, PARAMETER :: SB = 5.67E-08
REAL, PARAMETER :: VKC = 0.40
REAL, PARAMETER :: TFRZ = 273.16
REAL, PARAMETER :: HSUB = 2.8440E06
REAL, PARAMETER :: HVAP = 2.5104E06
REAL, PARAMETER :: HFUS = 0.3336E06
REAL, PARAMETER :: CWAT = 4.188E06
REAL, PARAMETER :: CICE = 2.094E06
REAL, PARAMETER :: CPAIR = 1004.64
REAL, PARAMETER :: TKWAT = 0.6
REAL, PARAMETER :: TKICE = 2.2
REAL, PARAMETER :: TKAIR = 0.023
REAL, PARAMETER :: RAIR = 287.04
REAL, PARAMETER :: RW = 461.269
REAL, PARAMETER :: DENH2O = 1000.
REAL, PARAMETER :: DENICE = 917.
INTEGER, PRIVATE, PARAMETER :: MBAND = 2
INTEGER, PRIVATE, PARAMETER :: NSOIL = 4
INTEGER, PRIVATE, PARAMETER :: NSTAGE = 8
TYPE noahmp_parameters
LOGICAL :: URBAN_FLAG
INTEGER :: ISWATER
INTEGER :: ISBARREN
INTEGER :: ISICE
INTEGER :: ISCROP
INTEGER :: EBLFOREST
REAL :: CH2OP
REAL :: DLEAF
REAL :: Z0MVT
REAL :: HVT
REAL :: HVB
REAL :: DEN
REAL :: RC
REAL :: MFSNO
REAL :: SAIM(12)
REAL :: LAIM(12)
REAL :: SLA
REAL :: DILEFC
REAL :: DILEFW
REAL :: FRAGR
REAL :: LTOVRC
REAL :: C3PSN
REAL :: KC25
REAL :: AKC
REAL :: KO25
REAL :: AKO
REAL :: VCMX25
REAL :: AVCMX
REAL :: BP
REAL :: MP
REAL :: QE25
REAL :: AQE
REAL :: RMF25
REAL :: RMS25
REAL :: RMR25
REAL :: ARM
REAL :: FOLNMX
REAL :: TMIN
REAL :: XL
REAL :: RHOL(MBAND)
REAL :: RHOS(MBAND)
REAL :: TAUL(MBAND)
REAL :: TAUS(MBAND)
REAL :: MRP
REAL :: CWPVT
REAL :: WRRAT
REAL :: WDPOOL
REAL :: TDLEF
INTEGER :: NROOT
REAL :: RGL
REAL :: RSMIN
REAL :: HS
REAL :: TOPT
REAL :: RSMAX
REAL :: SLAREA
REAL :: EPS(5)
REAL :: ALBSAT(MBAND)
REAL :: ALBDRY(MBAND)
REAL :: ALBICE(MBAND)
REAL :: ALBLAK(MBAND)
REAL :: OMEGAS(MBAND)
REAL :: BETADS
REAL :: BETAIS
REAL :: EG(2)
REAL :: CO2
REAL :: O2
REAL :: TIMEAN
REAL :: FSATMX
REAL :: Z0SNO
REAL :: SSI
REAL :: SWEMX
REAL :: RSURF_SNOW
INTEGER :: PLTDAY
INTEGER :: HSDAY
REAL :: PLANTPOP
REAL :: IRRI
REAL :: GDDTBASE
REAL :: GDDTCUT
REAL :: GDDS1
REAL :: GDDS2
REAL :: GDDS3
REAL :: GDDS4
REAL :: GDDS5
INTEGER :: C3C4
REAL :: AREF
REAL :: PSNRF
REAL :: I2PAR
REAL :: TASSIM0
REAL :: TASSIM1
REAL :: TASSIM2
REAL :: K
REAL :: EPSI
REAL :: Q10MR
REAL :: FOLN_MX
REAL :: LEFREEZ
REAL :: DILE_FC(NSTAGE)
REAL :: DILE_FW(NSTAGE)
REAL :: FRA_GR
REAL :: LF_OVRC(NSTAGE)
REAL :: ST_OVRC(NSTAGE)
REAL :: RT_OVRC(NSTAGE)
REAL :: LFMR25
REAL :: STMR25
REAL :: RTMR25
REAL :: GRAINMR25
REAL :: LFPT(NSTAGE)
REAL :: STPT(NSTAGE)
REAL :: RTPT(NSTAGE)
REAL :: GRAINPT(NSTAGE)
REAL :: BIO2LAI
REAL :: BEXP(NSOIL)
REAL :: SMCDRY(NSOIL)
REAL :: SMCWLT(NSOIL)
REAL :: SMCREF(NSOIL)
REAL :: SMCMAX(NSOIL)
REAL :: PSISAT(NSOIL)
REAL :: DKSAT(NSOIL)
REAL :: DWSAT(NSOIL)
REAL :: QUARTZ(NSOIL)
REAL :: F1
REAL :: SLOPE
REAL :: CSOIL
REAL :: ZBOT
REAL :: CZIL
REAL :: REFDK
REAL :: REFKDT
REAL :: KDT
REAL :: FRZX
END TYPE noahmp_parameters
contains
SUBROUTINE NOAHMP_SFLX (parameters, &
ILOC , JLOC , LAT , YEARLEN , JULIAN , COSZ , &
DT , DX , DZ8W , NSOIL , ZSOIL , NSNOW , &
SHDFAC , SHDMAX , VEGTYP , ICE , IST , CROPTYPE, &
SMCEQ , &
SFCTMP , SFCPRS , PSFC , UU , VV , Q2 , &
QC , SOLDN , LWDN , &
PRCPCONV, PRCPNONC, PRCPSHCV, PRCPSNOW, PRCPGRPL, PRCPHAIL, &
TBOT , CO2AIR , O2AIR , FOLN , FICEOLD , ZLVL , &
ALBOLD , SNEQVO , &
STC , SH2O , SMC , TAH , EAH , FWET , &
CANLIQ , CANICE , TV , TG , QSFC , QSNOW , &
ISNOW , ZSNSO , SNOWH , SNEQV , SNICE , SNLIQ , &
ZWT , WA , WT , WSLAKE , LFMASS , RTMASS , &
STMASS , WOOD , STBLCP , FASTCP , LAI , SAI , &
CM , CH , TAUSS , &
GRAIN , GDD , PGS , &
SMCWTD ,DEEPRECH , RECH , &
Z0WRF , &
FSA , FSR , FIRA , FSH , SSOIL , FCEV , &
FGEV , FCTR , ECAN , ETRAN , EDIR , TRAD , &
TGB , TGV , T2MV , T2MB , Q2V , Q2B , &
RUNSRF , RUNSUB , APAR , PSN , SAV , SAG , &
FSNO , NEE , GPP , NPP , FVEG , ALBEDO , &
QSNBOT , PONDING , PONDING1, PONDING2, RSSUN , RSSHA , &
BGAP , WGAP , CHV , CHB , EMISSI , &
SHG , SHC , SHB , EVG , EVB , GHV , &
GHB , IRG , IRC , IRB , TR , EVC , &
CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , &
PAHG , PAHB , PAH &
)
implicit none
type (noahmp_parameters), INTENT(IN) :: parameters
INTEGER , INTENT(IN) :: ICE
INTEGER , INTENT(IN) :: IST
INTEGER , INTENT(IN) :: VEGTYP
INTEGER , INTENT(IN) :: CROPTYPE
INTEGER , INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: NSOIL
INTEGER , INTENT(IN) :: ILOC
INTEGER , INTENT(IN) :: JLOC
REAL , INTENT(IN) :: DT
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL , INTENT(IN) :: Q2
REAL , INTENT(IN) :: SFCTMP
REAL , INTENT(IN) :: UU
REAL , INTENT(IN) :: VV
REAL , INTENT(IN) :: SOLDN
REAL , INTENT(IN) :: LWDN
REAL , INTENT(IN) :: SFCPRS
REAL , INTENT(INOUT) :: ZLVL
REAL , INTENT(IN) :: COSZ
REAL , INTENT(IN) :: TBOT
REAL , INTENT(IN) :: FOLN
REAL , INTENT(IN) :: SHDFAC
INTEGER , INTENT(IN) :: YEARLEN
REAL , INTENT(IN) :: JULIAN
REAL , INTENT(IN) :: LAT
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ
REAL , INTENT(IN) :: PRCPCONV
REAL , INTENT(IN) :: PRCPNONC
REAL , INTENT(IN) :: PRCPSHCV
REAL , INTENT(IN) :: PRCPSNOW
REAL , INTENT(IN) :: PRCPGRPL
REAL , INTENT(IN) :: PRCPHAIL
REAL , INTENT(IN) :: QC
REAL , INTENT(INOUT) :: QSFC
REAL , INTENT(IN) :: PSFC
REAL , INTENT(IN) :: DZ8W
REAL , INTENT(IN) :: DX
REAL , INTENT(IN) :: SHDMAX
REAL , INTENT(INOUT) :: QSNOW
REAL , INTENT(INOUT) :: FWET
REAL , INTENT(INOUT) :: SNEQVO
REAL , INTENT(INOUT) :: EAH
REAL , INTENT(INOUT) :: TAH
REAL , INTENT(INOUT) :: ALBOLD
REAL , INTENT(INOUT) :: CM
REAL , INTENT(INOUT) :: CH
REAL , INTENT(INOUT) :: TAUSS
INTEGER , INTENT(INOUT) :: ISNOW
REAL , INTENT(INOUT) :: CANLIQ
REAL , INTENT(INOUT) :: CANICE
REAL , INTENT(INOUT) :: SNEQV
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO
REAL , INTENT(INOUT) :: SNOWH
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ
REAL , INTENT(INOUT) :: TV
REAL , INTENT(INOUT) :: TG
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O
REAL , INTENT(INOUT) :: ZWT
REAL , INTENT(INOUT) :: WA
REAL , INTENT(INOUT) :: WT
REAL , INTENT(INOUT) :: WSLAKE
REAL, INTENT(INOUT) :: SMCWTD
REAL, INTENT(INOUT) :: DEEPRECH
REAL, INTENT(INOUT) :: RECH
REAL , INTENT(OUT) :: Z0WRF
REAL , INTENT(OUT) :: FSA
REAL , INTENT(OUT) :: FSR
REAL , INTENT(OUT) :: FIRA
REAL , INTENT(OUT) :: FSH
REAL , INTENT(OUT) :: FCEV
REAL , INTENT(OUT) :: FGEV
REAL , INTENT(OUT) :: FCTR
REAL , INTENT(OUT) :: SSOIL
REAL , INTENT(OUT) :: TRAD
REAL :: TS
REAL , INTENT(OUT) :: ECAN
REAL , INTENT(OUT) :: ETRAN
REAL , INTENT(OUT) :: EDIR
REAL , INTENT(OUT) :: RUNSRF
REAL , INTENT(OUT) :: RUNSUB
REAL , INTENT(OUT) :: PSN
REAL , INTENT(OUT) :: APAR
REAL , INTENT(OUT) :: SAV
REAL , INTENT(OUT) :: SAG
REAL , INTENT(OUT) :: FSNO
REAL , INTENT(OUT) :: FVEG
REAL , INTENT(OUT) :: ALBEDO
REAL :: ERRWAT
REAL , INTENT(OUT) :: QSNBOT
REAL , INTENT(OUT) :: PONDING
REAL , INTENT(OUT) :: PONDING1
REAL , INTENT(OUT) :: PONDING2
REAL , INTENT(OUT) :: T2MV
REAL , INTENT(OUT) :: T2MB
REAL, INTENT(OUT) :: RSSUN
REAL, INTENT(OUT) :: RSSHA
REAL, INTENT(OUT) :: BGAP
REAL, INTENT(OUT) :: WGAP
REAL, INTENT(OUT) :: TGV
REAL, INTENT(OUT) :: TGB
REAL :: Q1
REAL, INTENT(OUT) :: EMISSI
INTEGER :: IZ
INTEGER, DIMENSION(-NSNOW+1:NSOIL) :: IMELT
REAL :: CMC
REAL :: TAUX
REAL :: TAUY
REAL :: RHOAIR
REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZSNSO
REAL :: THAIR
REAL :: QAIR
REAL :: EAIR
REAL, DIMENSION( 1: 2) :: SOLAD
REAL, DIMENSION( 1: 2) :: SOLAI
REAL :: QPRECC
REAL :: QPRECL
REAL :: IGS
REAL :: ELAI
REAL :: ESAI
REAL :: BEVAP
REAL, DIMENSION( 1:NSOIL) :: BTRANI
REAL :: BTRAN
REAL :: QIN
REAL :: QDIS
REAL, DIMENSION( 1:NSOIL) :: SICE
REAL, DIMENSION(-NSNOW+1: 0) :: SNICEV
REAL, DIMENSION(-NSNOW+1: 0) :: SNLIQV
REAL, DIMENSION(-NSNOW+1: 0) :: EPORE
REAL :: TOTSC
REAL :: TOTLB
REAL :: T2M
REAL :: QDEW
REAL :: QVAP
REAL :: LATHEA
REAL :: SWDOWN
REAL :: QMELT
REAL :: BEG_WB
REAL,INTENT(OUT) :: IRC
REAL,INTENT(OUT) :: IRG
REAL,INTENT(OUT) :: SHC
REAL,INTENT(OUT) :: SHG
REAL,INTENT(OUT) :: EVG
REAL,INTENT(OUT) :: GHV
REAL,INTENT(OUT) :: IRB
REAL,INTENT(OUT) :: SHB
REAL,INTENT(OUT) :: EVB
REAL,INTENT(OUT) :: GHB
REAL,INTENT(OUT) :: EVC
REAL,INTENT(OUT) :: TR
REAL, INTENT(OUT) :: FPICE
REAL, INTENT(OUT) :: PAHV
REAL, INTENT(OUT) :: PAHG
REAL, INTENT(OUT) :: PAHB
REAL, INTENT(OUT) :: PAH
REAL :: FSRV
REAL :: FSRG
REAL,INTENT(OUT) :: Q2V
REAL,INTENT(OUT) :: Q2B
REAL :: Q2E
REAL :: QFX
REAL,INTENT(OUT) :: CHV
REAL,INTENT(OUT) :: CHB
REAL,INTENT(OUT) :: CHLEAF
REAL,INTENT(OUT) :: CHUC
REAL,INTENT(OUT) :: CHV2
REAL,INTENT(OUT) :: CHB2
REAL , INTENT(IN) :: CO2AIR
REAL , INTENT(IN) :: O2AIR
REAL , INTENT(INOUT) :: LFMASS
REAL , INTENT(INOUT) :: RTMASS
REAL , INTENT(INOUT) :: STMASS
REAL , INTENT(INOUT) :: WOOD
REAL , INTENT(INOUT) :: STBLCP
REAL , INTENT(INOUT) :: FASTCP
REAL , INTENT(INOUT) :: LAI
REAL , INTENT(INOUT) :: SAI
REAL , INTENT(INOUT) :: GRAIN
REAL , INTENT(INOUT) :: GDD
INTEGER , INTENT(INOUT) :: PGS
REAL , INTENT(OUT) :: NEE
REAL , INTENT(OUT) :: GPP
REAL , INTENT(OUT) :: NPP
REAL :: AUTORS
REAL :: HETERS
REAL :: TROOT
REAL :: BDFALL
REAL :: RAIN
REAL :: SNOW
REAL :: FP
REAL :: PRCP
REAL :: QINTR
REAL :: QDRIPR
REAL :: QTHROR
REAL :: QINTS
REAL :: QDRIPS
REAL :: QTHROS
REAL :: QRAIN
REAL :: SNOWHIN
REAL :: LATHEAV
REAL :: LATHEAG
LOGICAL :: FROZEN_GROUND
LOGICAL :: FROZEN_CANOPY
nee = 0.0
npp = 0.0
gpp = 0.0
PAHV = 0.
PAHG = 0.
PAHB = 0.
PAH = 0.
CALL ATM (parameters,SFCPRS ,SFCTMP ,Q2 , &
PRCPCONV, PRCPNONC,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL, &
SOLDN ,COSZ ,THAIR ,QAIR , &
EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD ,SOLAI , &
SWDOWN ,BDFALL ,RAIN ,SNOW ,FP ,FPICE , PRCP )
DO IZ = ISNOW+1, NSOIL
IF(IZ == ISNOW+1) THEN
DZSNSO(IZ) = - ZSNSO(IZ)
ELSE
DZSNSO(IZ) = ZSNSO(IZ-1) - ZSNSO(IZ)
END IF
END DO
TROOT = 0.
DO IZ=1,parameters%NROOT
TROOT = TROOT + STC(IZ)*DZSNSO(IZ)/(-ZSOIL(parameters%NROOT))
ENDDO
IF(IST == 1) THEN
BEG_WB = CANLIQ + CANICE + SNEQV + WA
DO IZ = 1,NSOIL
BEG_WB = BEG_WB + SMC(IZ) * DZSNSO(IZ) * 1000.
END DO
END IF
CALL PHENOLOGY (parameters,VEGTYP ,croptype, SNOWH , TV , LAT , YEARLEN , JULIAN , &
LAI , SAI , TROOT , ELAI , ESAI ,IGS, PGS)
IF(DVEG == 1 .or. DVEG == 6 .or. DVEG == 7) THEN
FVEG = SHDFAC
IF(FVEG <= 0.05) FVEG = 0.05
ELSE IF (DVEG == 2 .or. DVEG == 3 .or. DVEG == 8) THEN
FVEG = 1.-EXP(-0.52*(LAI+SAI))
IF(FVEG <= 0.05) FVEG = 0.05
ELSE IF (DVEG == 4 .or. DVEG == 5 .or. DVEG == 9 .or. DVEG == 10) THEN
FVEG = SHDMAX
IF(FVEG <= 0.05) FVEG = 0.05
ELSE
WRITE(*,*) "-------- FATAL CALLED IN SFLX -----------"
CALL wrf_error_fatal3("<stdin>",673,&
"Namelist parameter DVEG unknown")
ENDIF
IF(parameters%urban_flag .OR. VEGTYP == parameters%ISBARREN) FVEG = 0.0
IF(ELAI+ESAI == 0.0) FVEG = 0.0
CALL PRECIP_HEAT(parameters,ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , &
ELAI ,ESAI ,FVEG ,IST , &
BDFALL ,RAIN ,SNOW ,FP , &
CANLIQ ,CANICE ,TV ,SFCTMP ,TG , &
QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , &
PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, &
FWET ,CMC )
CALL ENERGY (parameters,ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , &
ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , &
SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZLVL , &
CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , &
EAIR ,TBOT ,ZSNSO ,ZSOIL , &
ELAI ,ESAI ,FWET ,FOLN , &
FVEG ,PAHV ,PAHG ,PAHB , &
QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,iloc, jloc , &
Z0WRF , &
IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , &
SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , &
TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , &
TRAD ,PSN ,APAR ,SSOIL ,BTRANI ,BTRAN , &
PONDING,TS ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground, &
TV ,TG ,STC ,SNOWH ,EAH ,TAH , &
SNEQVO ,SNEQV ,SH2O ,SMC ,SNICE ,SNLIQ , &
ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , &
TAUSS , &
QC ,QSFC ,PSFC , &
T2MV ,T2MB ,FSRV , &
FSRG ,RSSUN ,RSSHA ,BGAP ,WGAP, TGV,TGB,&
Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB , &
EMISSI ,PAH , &
SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 )
SICE(:) = MAX(0.0, SMC(:) - SH2O(:))
SNEQVO = SNEQV
QVAP = MAX( FGEV/LATHEAG, 0.)
QDEW = ABS( MIN(FGEV/LATHEAG, 0.))
EDIR = QVAP - QDEW
CALL WATER (parameters,VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , &
VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , &
ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , &
FICEOLD,PONDING,TG ,IST ,FVEG ,iloc,jloc , SMCEQ , &
BDFALL ,FP ,RAIN ,SNOW , &
QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, &
ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , &
SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , &
SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , &
SMCWTD ,DEEPRECH,RECH , &
CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , &
QIN ,QDIS ,PONDING1 ,PONDING2,&
QSNBOT &
)
IF (DVEG == 2 .OR. DVEG == 5 .OR. DVEG == 6 .OR. (DVEG == 10 .and. CROPTYPE == 0)) THEN
CALL CARBON (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , &
DZSNSO ,STC ,SMC ,TV ,TG ,PSN , &
FOLN ,BTRAN ,APAR ,FVEG ,IGS , &
TROOT ,IST ,LAT ,iloc ,jloc , &
LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , &
GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , &
TOTLB ,LAI ,SAI )
END IF
IF (DVEG == 10 .and. CROPTYPE > 0) THEN
CALL CARBON_CROP (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL ,JULIAN , &
DZSNSO ,STC ,SMC ,TV ,PSN ,FOLN ,BTRAN , &
SOLDN ,T2M , &
LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP ,GRAIN , &
LAI ,SAI ,GDD , &
GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC ,TOTLB, PGS )
END IF
CALL ERROR (parameters,SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , &
FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , &
SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , &
ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , &
NSNOW ,IST ,ERRWAT ,ILOC , JLOC ,FVEG , &
SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , &
PAHV ,PAHG ,PAHB )
QFX = ETRAN + ECAN + EDIR
IF ( parameters%urban_flag ) THEN
QSFC = QFX/(RHOAIR*CH) + QAIR
Q2B = QSFC
END IF
IF(SNOWH <= 1.E-6 .OR. SNEQV <= 1.E-3) THEN
SNOWH = 0.0
SNEQV = 0.0
END IF
IF(SWDOWN.NE.0.) THEN
ALBEDO = FSR / SWDOWN
ELSE
ALBEDO = -999.9
END IF
END SUBROUTINE NOAHMP_SFLX
SUBROUTINE ATM (parameters,SFCPRS ,SFCTMP ,Q2 , &
PRCPCONV,PRCPNONC ,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL , &
SOLDN ,COSZ ,THAIR ,QAIR , &
EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD , SOLAI , &
SWDOWN ,BDFALL ,RAIN ,SNOW ,FP , FPICE ,PRCP )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
REAL , INTENT(IN) :: SFCPRS
REAL , INTENT(IN) :: SFCTMP
REAL , INTENT(IN) :: Q2
REAL , INTENT(IN) :: PRCPCONV
REAL , INTENT(IN) :: PRCPNONC
REAL , INTENT(IN) :: PRCPSHCV
REAL , INTENT(IN) :: PRCPSNOW
REAL , INTENT(IN) :: PRCPGRPL
REAL , INTENT(IN) :: PRCPHAIL
REAL , INTENT(IN) :: SOLDN
REAL , INTENT(IN) :: COSZ
REAL , INTENT(OUT) :: THAIR
REAL , INTENT(OUT) :: QAIR
REAL , INTENT(OUT) :: EAIR
REAL , INTENT(OUT) :: RHOAIR
REAL , INTENT(OUT) :: QPRECC
REAL , INTENT(OUT) :: QPRECL
REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAD
REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAI
REAL , INTENT(OUT) :: SWDOWN
REAL , INTENT(OUT) :: BDFALL
REAL , INTENT(OUT) :: RAIN
REAL , INTENT(OUT) :: SNOW
REAL , INTENT(OUT) :: FP
REAL , INTENT(OUT) :: FPICE
REAL , INTENT(OUT) :: PRCP
REAL :: PAIR
REAL :: PRCP_FROZEN
REAL, PARAMETER :: RHO_GRPL = 500.0
REAL, PARAMETER :: RHO_HAIL = 917.0
PAIR = SFCPRS
THAIR = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR)
QAIR = Q2
EAIR = QAIR*SFCPRS / (0.622+0.378*QAIR)
RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP)
IF(COSZ <= 0.) THEN
SWDOWN = 0.
ELSE
SWDOWN = SOLDN
END IF
SOLAD(1) = SWDOWN*0.7*0.5
SOLAD(2) = SWDOWN*0.7*0.5
SOLAI(1) = SWDOWN*0.3*0.5
SOLAI(2) = SWDOWN*0.3*0.5
PRCP = PRCPCONV + PRCPNONC + PRCPSHCV
IF(OPT_SNF == 4) THEN
QPRECC = PRCPCONV + PRCPSHCV
QPRECL = PRCPNONC
ELSE
QPRECC = 0.10 * PRCP
QPRECL = 0.90 * PRCP
END IF
FP = 0.0
IF(QPRECC + QPRECL > 0.) &
FP = (QPRECC + QPRECL) / (10.*QPRECC + QPRECL)
IF(OPT_SNF == 1) THEN
IF(SFCTMP > TFRZ+2.5)THEN
FPICE = 0.
ELSE
IF(SFCTMP <= TFRZ+0.5)THEN
FPICE = 1.0
ELSE IF(SFCTMP <= TFRZ+2.)THEN
FPICE = 1.-(-54.632 + 0.2*SFCTMP)
ELSE
FPICE = 0.6
ENDIF
ENDIF
ENDIF
IF(OPT_SNF == 2) THEN
IF(SFCTMP >= TFRZ+2.2) THEN
FPICE = 0.
ELSE
FPICE = 1.0
ENDIF
ENDIF
IF(OPT_SNF == 3) THEN
IF(SFCTMP >= TFRZ) THEN
FPICE = 0.
ELSE
FPICE = 1.0
ENDIF
ENDIF
BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59))
IF(OPT_SNF == 4) THEN
PRCP_FROZEN = PRCPSNOW + PRCPGRPL + PRCPHAIL
IF(PRCPNONC > 0. .and. PRCP_FROZEN > 0.) THEN
FPICE = MIN(1.0,PRCP_FROZEN/PRCPNONC)
FPICE = MAX(0.0,FPICE)
BDFALL = BDFALL*(PRCPSNOW/PRCP_FROZEN) + RHO_GRPL*(PRCPGRPL/PRCP_FROZEN) + &
RHO_HAIL*(PRCPHAIL/PRCP_FROZEN)
ELSE
FPICE = 0.0
ENDIF
ENDIF
RAIN = PRCP * (1.-FPICE)
SNOW = PRCP * FPICE
END SUBROUTINE ATM
SUBROUTINE PHENOLOGY (parameters,VEGTYP ,croptype, SNOWH , TV , LAT , YEARLEN , JULIAN , &
LAI , SAI , TROOT , ELAI , ESAI , IGS, PGS)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER , INTENT(IN ) :: VEGTYP
INTEGER , INTENT(IN ) :: CROPTYPE
REAL , INTENT(IN ) :: SNOWH
REAL , INTENT(IN ) :: TV
REAL , INTENT(IN ) :: LAT
INTEGER , INTENT(IN ) :: YEARLEN
REAL , INTENT(IN ) :: JULIAN
real , INTENT(IN ) :: TROOT
REAL , INTENT(INOUT) :: LAI
REAL , INTENT(INOUT) :: SAI
REAL , INTENT(OUT ) :: ELAI
REAL , INTENT(OUT ) :: ESAI
REAL , INTENT(OUT ) :: IGS
INTEGER , INTENT(IN ) :: PGS
REAL :: DB
REAL :: FB
REAL :: SNOWHC
INTEGER :: K
INTEGER :: IT1,IT2
REAL :: DAY
REAL :: WT1,WT2
REAL :: T
IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN
IF (LAT >= 0.) THEN
DAY = JULIAN
ELSE
DAY = MOD ( JULIAN + ( 0.5 * YEARLEN ) , REAL(YEARLEN) )
ENDIF
T = 12. * DAY / REAL(YEARLEN)
IT1 = T + 0.5
IT2 = IT1 + 1
WT1 = (IT1+0.5) - T
WT2 = 1.-WT1
IF (IT1 .LT. 1) IT1 = 12
IF (IT2 .GT. 12) IT2 = 1
LAI = WT1*parameters%LAIM(IT1) + WT2*parameters%LAIM(IT2)
SAI = WT1*parameters%SAIM(IT1) + WT2*parameters%SAIM(IT2)
ENDIF
IF(DVEG == 7 .or. DVEG == 8 .or. DVEG == 9) THEN
SAI = MAX(0.05,0.1 * LAI)
IF (LAI < 0.05) SAI = 0.0
ENDIF
IF (SAI < 0.05 .and. CROPTYPE == 0) SAI = 0.0
IF ((LAI < 0.05 .OR. SAI == 0.0) .and. CROPTYPE == 0) LAI = 0.0
IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. &
( VEGTYP == parameters%ISICE ) .or. ( parameters%urban_flag ) ) THEN
LAI = 0.
SAI = 0.
ENDIF
DB = MIN( MAX(SNOWH - parameters%HVB,0.), parameters%HVT-parameters%HVB )
FB = DB / MAX(1.E-06,parameters%HVT-parameters%HVB)
IF(parameters%HVT> 0. .AND. parameters%HVT <= 1.0) THEN
SNOWHC = parameters%HVT*EXP(-SNOWH/0.2)
FB = MIN(SNOWH,SNOWHC)/SNOWHC
ENDIF
ELAI = LAI*(1.-FB)
ESAI = SAI*(1.-FB)
IF (ESAI < 0.05 .and. CROPTYPE == 0) ESAI = 0.0
IF ((ELAI < 0.05 .OR. ESAI == 0.0) .and. CROPTYPE == 0) ELAI = 0.0
IF ((TV .GT. parameters%TMIN .and. CROPTYPE == 0).or.(PGS > 2 .and. PGS < 7 .and. CROPTYPE > 0)) THEN
IGS = 1.
ELSE
IGS = 0.
ENDIF
END SUBROUTINE PHENOLOGY
SUBROUTINE PRECIP_HEAT (parameters,ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , &
ELAI ,ESAI ,FVEG ,IST , &
BDFALL ,RAIN ,SNOW ,FP , &
CANLIQ ,CANICE ,TV ,SFCTMP ,TG , &
QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , &
PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, &
FWET ,CMC )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER,INTENT(IN) :: ILOC
INTEGER,INTENT(IN) :: JLOC
INTEGER,INTENT(IN) :: VEGTYP
INTEGER,INTENT(IN) :: IST
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: UU
REAL, INTENT(IN) :: VV
REAL, INTENT(IN) :: ELAI
REAL, INTENT(IN) :: ESAI
REAL, INTENT(IN) :: FVEG
REAL, INTENT(IN) :: BDFALL
REAL, INTENT(IN) :: RAIN
REAL, INTENT(IN) :: SNOW
REAL, INTENT(IN) :: FP
REAL, INTENT(IN) :: TV
REAL, INTENT(IN) :: SFCTMP
REAL, INTENT(IN) :: TG
REAL, INTENT(INOUT) :: CANLIQ
REAL, INTENT(INOUT) :: CANICE
REAL, INTENT(OUT) :: QINTR
REAL, INTENT(OUT) :: QDRIPR
REAL, INTENT(OUT) :: QTHROR
REAL, INTENT(OUT) :: QINTS
REAL, INTENT(OUT) :: QDRIPS
REAL, INTENT(OUT) :: QTHROS
REAL, INTENT(OUT) :: PAHV
REAL, INTENT(OUT) :: PAHG
REAL, INTENT(OUT) :: PAHB
REAL, INTENT(OUT) :: QRAIN
REAL, INTENT(OUT) :: QSNOW
REAL, INTENT(OUT) :: SNOWHIN
REAL, INTENT(OUT) :: FWET
REAL, INTENT(OUT) :: CMC
REAL :: MAXSNO
REAL :: MAXLIQ
REAL :: FT
REAL :: FV
REAL :: PAH_AC
REAL :: PAH_CG
REAL :: PAH_AG
REAL :: ICEDRIP
QINTR = 0.
QDRIPR = 0.
QTHROR = 0.
QINTR = 0.
QINTS = 0.
QDRIPS = 0.
QTHROS = 0.
PAH_AC = 0.
PAH_CG = 0.
PAH_AG = 0.
PAHV = 0.
PAHG = 0.
PAHB = 0.
QRAIN = 0.0
QSNOW = 0.0
SNOWHIN = 0.0
ICEDRIP = 0.0
MAXLIQ = parameters%CH2OP * (ELAI+ ESAI)
IF((ELAI+ ESAI).GT.0.) THEN
QINTR = FVEG * RAIN * FP
QINTR = MIN(QINTR, (MAXLIQ - CANLIQ)/DT * (1.-EXP(-RAIN*DT/MAXLIQ)) )
QINTR = MAX(QINTR, 0.)
QDRIPR = FVEG * RAIN - QINTR
QTHROR = (1.-FVEG) * RAIN
CANLIQ=MAX(0.,CANLIQ+QINTR*DT)
ELSE
QINTR = 0.
QDRIPR = 0.
QTHROR = RAIN
IF(CANLIQ > 0.) THEN
QDRIPR = QDRIPR + CANLIQ/DT
CANLIQ = 0.0
END IF
END IF
PAH_AC = FVEG * RAIN * (CWAT/1000.0) * (SFCTMP - TV)
PAH_CG = QDRIPR * (CWAT/1000.0) * (TV - TG)
PAH_AG = QTHROR * (CWAT/1000.0) * (SFCTMP - TG)
MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI)
IF((ELAI+ ESAI).GT.0.) THEN
QINTS = FVEG * SNOW * FP
QINTS = MIN(QINTS, (MAXSNO - CANICE)/DT * (1.-EXP(-SNOW*DT/MAXSNO)) )
QINTS = MAX(QINTS, 0.)
FT = MAX(0.0,(TV - 270.15) / 1.87E5)
FV = SQRT(UU*UU + VV*VV) / 1.56E5
ICEDRIP = MAX(0.,CANICE) * (FV+FT)
QDRIPS = (FVEG * SNOW - QINTS) + ICEDRIP
QTHROS = (1.0-FVEG) * SNOW
CANICE= MAX(0.,CANICE + (QINTS - ICEDRIP)*DT)
ELSE
QINTS = 0.
QDRIPS = 0.
QTHROS = SNOW
IF(CANICE > 0.) THEN
QDRIPS = QDRIPS + CANICE/DT
CANICE = 0.0
END IF
ENDIF
IF(CANICE.GT.0.) THEN
FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06)
ELSE
FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06)
ENDIF
FWET = MIN(FWET, 1.) ** 0.667
CMC = CANLIQ + CANICE
PAH_AC = PAH_AC + FVEG * SNOW * (CICE/1000.0) * (SFCTMP - TV)
PAH_CG = PAH_CG + QDRIPS * (CICE/1000.0) * (TV - TG)
PAH_AG = PAH_AG + QTHROS * (CICE/1000.0) * (SFCTMP - TG)
PAHV = PAH_AC - PAH_CG
PAHG = PAH_CG
PAHB = PAH_AG
IF (FVEG > 0.0 .AND. FVEG < 1.0) THEN
PAHG = PAHG / FVEG
PAHB = PAHB / (1.0-FVEG)
ELSEIF (FVEG <= 0.0) THEN
PAHB = PAHG + PAHB
PAHG = 0.0
PAHV = 0.0
ELSEIF (FVEG >= 1.0) THEN
PAHB = 0.0
END IF
PAHV = MAX(PAHV,-20.0)
PAHV = MIN(PAHV,20.0)
PAHG = MAX(PAHG,-20.0)
PAHG = MIN(PAHG,20.0)
PAHB = MAX(PAHB,-20.0)
PAHB = MIN(PAHB,20.0)
QRAIN = QDRIPR + QTHROR
QSNOW = QDRIPS + QTHROS
SNOWHIN = QSNOW/BDFALL
IF (IST == 2 .AND. TG > TFRZ) THEN
QSNOW = 0.
SNOWHIN = 0.
END IF
END SUBROUTINE PRECIP_HEAT
SUBROUTINE ERROR (parameters,SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , &
FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , &
SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , &
ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , &
NSNOW ,IST ,ERRWAT, ILOC ,JLOC ,FVEG , &
SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , &
PAHV ,PAHG ,PAHB )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER , INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: NSOIL
INTEGER , INTENT(IN) :: IST
INTEGER , INTENT(IN) :: ILOC
INTEGER , INTENT(IN) :: JLOC
REAL , INTENT(IN) :: SWDOWN
REAL , INTENT(IN) :: FSA
REAL , INTENT(IN) :: FSR
REAL , INTENT(IN) :: FIRA
REAL , INTENT(IN) :: FSH
REAL , INTENT(IN) :: FCEV
REAL , INTENT(IN) :: FGEV
REAL , INTENT(IN) :: FCTR
REAL , INTENT(IN) :: SSOIL
REAL , INTENT(IN) :: FVEG
REAL , INTENT(IN) :: SAV
REAL , INTENT(IN) :: SAG
REAL , INTENT(IN) :: FSRV
REAL , INTENT(IN) :: FSRG
REAL , INTENT(IN) :: ZWT
REAL , INTENT(IN) :: PRCP
REAL , INTENT(IN) :: ECAN
REAL , INTENT(IN) :: ETRAN
REAL , INTENT(IN) :: EDIR
REAL , INTENT(IN) :: RUNSRF
REAL , INTENT(IN) :: RUNSUB
REAL , INTENT(IN) :: CANLIQ
REAL , INTENT(IN) :: CANICE
REAL , INTENT(IN) :: SNEQV
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL , INTENT(IN) :: WA
REAL , INTENT(IN) :: DT
REAL , INTENT(IN) :: BEG_WB
REAL , INTENT(OUT) :: ERRWAT
REAL, INTENT(IN) :: PAH
REAL, INTENT(IN) :: PAHV
REAL, INTENT(IN) :: PAHG
REAL, INTENT(IN) :: PAHB
INTEGER :: IZ
REAL :: END_WB
REAL :: ERRENG
REAL :: ERRSW
REAL :: FSRVG
CHARACTER(len=256) :: message
ERRSW = SWDOWN - (FSA + FSR)
IF (ABS(ERRSW) > 0.01) THEN
WRITE(*,*) "VEGETATION!"
WRITE(*,*) "SWDOWN*FVEG =",SWDOWN*FVEG
WRITE(*,*) "FVEG*(SAV+SAG) =",FVEG*SAV + SAG
WRITE(*,*) "FVEG*(FSRV +FSRG)=",FVEG*FSRV + FSRG
WRITE(*,*) "GROUND!"
WRITE(*,*) "(1-.FVEG)*SWDOWN =",(1.-FVEG)*SWDOWN
WRITE(*,*) "(1.-FVEG)*SAG =",(1.-FVEG)*SAG
WRITE(*,*) "(1.-FVEG)*FSRG=",(1.-FVEG)*FSRG
WRITE(*,*) "FSRV =",FSRV
WRITE(*,*) "FSRG =",FSRG
WRITE(*,*) "FSR =",FSR
WRITE(*,*) "SAV =",SAV
WRITE(*,*) "SAG =",SAG
WRITE(*,*) "FSA =",FSA
WRITE(message,*) 'ERRSW =',ERRSW
call wrf_message(trim(message))
call wrf_error_fatal3("<stdin>",1359,&
"Stop in Noah-MP")
END IF
ERRENG = SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) +PAH
IF(ABS(ERRENG) > 0.01) THEN
write(message,*) 'ERRENG =',ERRENG,' at i,j: ',ILOC,JLOC
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Net solar: ",FSA
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Net longwave: ",FIRA
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Total sensible: ",FSH
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Canopy evap: ",FCEV
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Ground evap: ",FGEV
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Transpiration: ",FCTR
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Total ground: ",SSOIL
call wrf_message(trim(message))
WRITE(message,'(a17,4F10.4)') "Precip advected: ",PAH,PAHV,PAHG,PAHB
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Precip: ",PRCP
call wrf_message(trim(message))
WRITE(message,'(a17,F10.4)') "Veg fraction: ",FVEG
call wrf_message(trim(message))
call wrf_error_fatal3("<stdin>",1389,&
"Energy budget problem in NOAHMP LSM")
END IF
IF (IST == 1) THEN
END_WB = CANLIQ + CANICE + SNEQV + WA
DO IZ = 1,NSOIL
END_WB = END_WB + SMC(IZ) * DZSNSO(IZ) * 1000.
END DO
ERRWAT = END_WB-BEG_WB-(PRCP-ECAN-ETRAN-EDIR-RUNSRF-RUNSUB)*DT
IF(ABS(ERRWAT) > 0.1) THEN
if (ERRWAT > 0) then
call wrf_message ('The model is gaining water (ERRWAT is positive)')
else
call wrf_message('The model is losing water (ERRWAT is negative)')
endif
write(message, *) 'ERRWAT =',ERRWAT, "kg m{-2} timestep{-1}"
call wrf_message(trim(message))
WRITE(message, &
'(" I J END_WB BEG_WB PRCP ECAN EDIR ETRAN RUNSRF RUNSUB")')
call wrf_message(trim(message))
WRITE(message,'(i6,1x,i6,1x,2f15.3,9f11.5)')ILOC,JLOC,END_WB,BEG_WB,PRCP*DT,ECAN*DT,&
EDIR*DT,ETRAN*DT,RUNSRF*DT,RUNSUB*DT,ZWT
call wrf_message(trim(message))
call wrf_error_fatal3("<stdin>",1414,&
"Water budget problem in NOAHMP LSM")
END IF
ELSE
ERRWAT = 0.0
ENDIF
END SUBROUTINE ERROR
SUBROUTINE ENERGY (parameters,ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , &
ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , &
SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZREF , &
CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , &
EAIR ,TBOT ,ZSNSO ,ZSOIL , &
ELAI ,ESAI ,FWET ,FOLN , &
FVEG ,PAHV ,PAHG ,PAHB , &
QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,ILOC , JLOC, &
Z0WRF , &
IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , &
SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , &
TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , &
TRAD ,PSN ,APAR ,SSOIL ,BTRANI ,BTRAN , &
PONDING,TS ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground, &
TV ,TG ,STC ,SNOWH ,EAH ,TAH , &
SNEQVO ,SNEQV ,SH2O ,SMC ,SNICE ,SNLIQ , &
ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , &
TAUSS , &
QC ,QSFC ,PSFC , &
T2MV ,T2MB ,FSRV , &
FSRG ,RSSUN ,RSSHA ,BGAP ,WGAP,TGV,TGB,&
Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB, EMISSI,PAH ,&
SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
integer , INTENT(IN) :: ILOC
integer , INTENT(IN) :: JLOC
INTEGER , INTENT(IN) :: ICE
INTEGER , INTENT(IN) :: VEGTYP
INTEGER , INTENT(IN) :: IST
INTEGER , INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: NSOIL
INTEGER , INTENT(IN) :: ISNOW
REAL , INTENT(IN) :: DT
REAL , INTENT(IN) :: QSNOW
REAL , INTENT(IN) :: RHOAIR
REAL , INTENT(IN) :: EAIR
REAL , INTENT(IN) :: SFCPRS
REAL , INTENT(IN) :: QAIR
REAL , INTENT(IN) :: SFCTMP
REAL , INTENT(IN) :: THAIR
REAL , INTENT(IN) :: LWDN
REAL , INTENT(IN) :: UU
REAL , INTENT(IN) :: VV
REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAD
REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAI
REAL , INTENT(IN) :: COSZ
REAL , INTENT(IN) :: ELAI
REAL , INTENT(IN) :: ESAI
REAL , INTENT(IN) :: FWET
REAL , INTENT(IN) :: FVEG
REAL , INTENT(IN) :: LAT
REAL , INTENT(IN) :: CANLIQ
REAL , INTENT(IN) :: CANICE
REAL , INTENT(IN) :: FOLN
REAL , INTENT(IN) :: CO2AIR
REAL , INTENT(IN) :: O2AIR
REAL , INTENT(IN) :: IGS
REAL , INTENT(IN) :: ZREF
REAL , INTENT(IN) :: TBOT
REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO
REAL , DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, INTENT(IN) :: PAHV
REAL, INTENT(IN) :: PAHG
REAL, INTENT(IN) :: PAHB
REAL , INTENT(IN) :: QC
REAL , INTENT(INOUT) :: QSFC
REAL , INTENT(IN) :: PSFC
REAL , INTENT(IN) :: DX
REAL , INTENT(IN) :: DZ8W
REAL , INTENT(IN) :: Q2
REAL , INTENT(OUT) :: Z0WRF
INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT
REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV
REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV
REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE
REAL , INTENT(OUT) :: FSNO
REAL , INTENT(OUT) :: QMELT
REAL , INTENT(OUT) :: PONDING
REAL , INTENT(OUT) :: SAV
REAL , INTENT(OUT) :: SAG
REAL , INTENT(OUT) :: FSA
REAL , INTENT(OUT) :: FSR
REAL , INTENT(OUT) :: TAUX
REAL , INTENT(OUT) :: TAUY
REAL , INTENT(OUT) :: FIRA
REAL , INTENT(OUT) :: FSH
REAL , INTENT(OUT) :: FCEV
REAL , INTENT(OUT) :: FGEV
REAL , INTENT(OUT) :: FCTR
REAL , INTENT(OUT) :: TRAD
REAL , INTENT(OUT) :: T2M
REAL , INTENT(OUT) :: PSN
REAL , INTENT(OUT) :: APAR
REAL , INTENT(OUT) :: SSOIL
REAL , DIMENSION( 1:NSOIL), INTENT(OUT) :: BTRANI
REAL , INTENT(OUT) :: BTRAN
REAL , INTENT(OUT) :: LATHEAV
REAL , INTENT(OUT) :: LATHEAG
LOGICAL , INTENT(OUT) :: FROZEN_GROUND
LOGICAL , INTENT(OUT) :: FROZEN_CANOPY
REAL , INTENT(OUT) :: FSRV
REAL , INTENT(OUT) :: FSRG
REAL, INTENT(OUT) :: RSSUN
REAL, INTENT(OUT) :: RSSHA
REAL , INTENT(OUT) :: T2MV
REAL , INTENT(OUT) :: T2MB
REAL , INTENT(OUT) :: BGAP
REAL , INTENT(OUT) :: WGAP
REAL , INTENT(INOUT) :: TS
REAL , INTENT(INOUT) :: TV
REAL , INTENT(INOUT) :: TG
REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
REAL , INTENT(INOUT) :: SNOWH
REAL , INTENT(INOUT) :: SNEQV
REAL , INTENT(INOUT) :: SNEQVO
REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O
REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC
REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE
REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ
REAL , INTENT(INOUT) :: EAH
REAL , INTENT(INOUT) :: TAH
REAL , INTENT(INOUT) :: ALBOLD
REAL , INTENT(INOUT) :: TAUSS
REAL , INTENT(INOUT) :: CM
REAL , INTENT(INOUT) :: CH
REAL , INTENT(INOUT) :: Q1
REAL, INTENT(OUT) :: EMISSI
REAL, INTENT(OUT) :: PAH
INTEGER :: IZ
LOGICAL :: VEG
REAL :: UR
REAL :: ZLVL
REAL :: FSUN
REAL :: RB
REAL :: RSURF
REAL :: L_RSURF
REAL :: D_RSURF
REAL :: BEVAP
REAL :: MOL
REAL :: VAI
REAL :: CWP
REAL :: ZPD
REAL :: Z0M
REAL :: ZPDG
REAL :: Z0MG
REAL :: EMV
REAL :: EMG
REAL :: FIRE
REAL :: LAISUN
REAL :: LAISHA
REAL :: PSNSUN
REAL :: PSNSHA
REAL :: PARSUN
REAL :: PARSHA
REAL, DIMENSION(-NSNOW+1:NSOIL) :: FACT
REAL, DIMENSION(-NSNOW+1:NSOIL) :: DF
REAL, DIMENSION(-NSNOW+1:NSOIL) :: HCPCT
REAL :: BDSNO
REAL :: FMELT
REAL :: GX
REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI
REAL :: GAMMAV
REAL :: GAMMAG
REAL :: PSI
REAL :: RHSUR
REAL :: TAUXV
REAL :: TAUYV
REAL,INTENT(OUT) :: IRC
REAL,INTENT(OUT) :: IRG
REAL,INTENT(OUT) :: SHC
REAL,INTENT(OUT) :: SHG
REAL,INTENT(OUT) :: Q2V
REAL,INTENT(OUT) :: Q2B
REAL,INTENT(OUT) :: Q2E
REAL,INTENT(OUT) :: EVC
REAL,INTENT(OUT) :: EVG
REAL,INTENT(OUT) :: TR
REAL,INTENT(OUT) :: GHV
REAL,INTENT(OUT) :: TGV
REAL :: CMV
REAL,INTENT(OUT) :: CHV
REAL :: TAUXB
REAL :: TAUYB
REAL,INTENT(OUT) :: IRB
REAL,INTENT(OUT) :: SHB
REAL,INTENT(OUT) :: EVB
REAL,INTENT(OUT) :: GHB
REAL,INTENT(OUT) :: TGB
REAL :: CMB
REAL,INTENT(OUT) :: CHB
REAL,INTENT(OUT) :: CHLEAF
REAL,INTENT(OUT) :: CHUC
REAL,INTENT(OUT) :: CHV2
REAL,INTENT(OUT) :: CHB2
REAL :: noahmpres
REAL, PARAMETER :: MPE = 1.E-6
REAL, PARAMETER :: PSIWLT = -150.
REAL, PARAMETER :: Z0 = 0.002
TAUXV = 0.
TAUYV = 0.
IRC = 0.
SHC = 0.
IRG = 0.
SHG = 0.
EVG = 0.
EVC = 0.
TR = 0.
GHV = 0.
PSNSUN = 0.
PSNSHA = 0.
T2MV = 0.
Q2V = 0.
CHV = 0.
CHLEAF = 0.
CHUC = 0.
CHV2 = 0.
UR = MAX( SQRT(UU**2.+VV**2.), 1. )
VAI = ELAI + ESAI
VEG = .FALSE.
IF(VAI > 0.) VEG = .TRUE.
FSNO = 0.
IF(SNOWH.GT.0.) THEN
BDSNO = SNEQV / SNOWH
FMELT = (BDSNO/100.)**parameters%MFSNO
FSNO = TANH( SNOWH /(2.5* Z0 * FMELT))
ENDIF
IF(IST == 2) THEN
IF(TG .LE. TFRZ) THEN
Z0MG = 0.01 * (1.0-FSNO) + FSNO * parameters%Z0SNO
ELSE
Z0MG = 0.01
END IF
ELSE
Z0MG = Z0 * (1.0-FSNO) + FSNO * parameters%Z0SNO
END IF
ZPDG = SNOWH
IF(VEG) THEN
Z0M = parameters%Z0MVT
ZPD = 0.65 * parameters%HVT
IF(SNOWH.GT.ZPD) ZPD = SNOWH
ELSE
Z0M = Z0MG
ZPD = ZPDG
END IF
ZLVL = MAX(ZPD,parameters%HVT) + ZREF
IF(ZPDG >= ZLVL) ZLVL = ZPDG + ZREF
CWP = parameters%CWPVT
CALL THERMOPROP (parameters,NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , &
DT ,SNOWH ,SNICE ,SNLIQ , &
SMC ,SH2O ,TG ,STC ,UR , &
LAT ,Z0M ,ZLVL ,VEGTYP , &
DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , &
FACT )
CALL RADIATION (parameters,VEGTYP ,IST ,ICE ,NSOIL , &
SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , &
TG ,TV ,FSNO ,QSNOW ,FWET , &
ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , &
FVEG ,ILOC ,JLOC , &
ALBOLD ,TAUSS , &
FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , &
SAV ,SAG ,FSR ,FSA ,FSRV , &
FSRG ,BGAP ,WGAP )
EMV = 1. - EXP(-(ELAI+ESAI)/1.0)
IF (ICE == 1) THEN
EMG = 0.98*(1.-FSNO) + 1.0*FSNO
ELSE
EMG = parameters%EG(IST)*(1.-FSNO) + 1.0*FSNO
END IF
BTRAN = 0.
IF(IST ==1 ) THEN
DO IZ = 1, parameters%NROOT
IF(OPT_BTR == 1) then
GX = (SH2O(IZ)-parameters%SMCWLT(IZ)) / (parameters%SMCREF(IZ)-parameters%SMCWLT(IZ))
END IF
IF(OPT_BTR == 2) then
PSI = MAX(PSIWLT,-parameters%PSISAT(IZ)*(MAX(0.01,SH2O(IZ))/parameters%SMCMAX(IZ))**(-parameters%BEXP(IZ)) )
GX = (1.-PSI/PSIWLT)/(1.+parameters%PSISAT(IZ)/PSIWLT)
END IF
IF(OPT_BTR == 3) then
PSI = MAX(PSIWLT,-parameters%PSISAT(IZ)*(MAX(0.01,SH2O(IZ))/parameters%SMCMAX(IZ))**(-parameters%BEXP(IZ)) )
GX = 1.-EXP(-5.8*(LOG(PSIWLT/PSI)))
END IF
GX = MIN(1.,MAX(0.,GX))
BTRANI(IZ) = MAX(MPE,DZSNSO(IZ) / (-ZSOIL(parameters%NROOT)) * GX)
BTRAN = BTRAN + BTRANI(IZ)
END DO
BTRAN = MAX(MPE,BTRAN)
BTRANI(1:parameters%NROOT) = BTRANI(1:parameters%NROOT)/BTRAN
END IF
BEVAP = MAX(0.0,SH2O(1)/parameters%SMCMAX(1))
IF(IST == 2) THEN
RSURF = 1.
RHSUR = 1.0
ELSE
IF(OPT_RSF == 1 .OR. OPT_RSF == 4) THEN
L_RSURF = (-ZSOIL(1)) * ( exp ( (1.0 - MIN(1.0,SH2O(1)/parameters%SMCMAX(1))) ** 5 ) - 1.0 ) / ( 2.71828 - 1.0 )
D_RSURF = 2.2E-5 * parameters%SMCMAX(1) * parameters%SMCMAX(1) * ( 1.0 - parameters%SMCWLT(1) / parameters%SMCMAX(1) ) ** (2.0+3.0/parameters%BEXP(1))
RSURF = L_RSURF / D_RSURF
ELSEIF(OPT_RSF == 2) THEN
RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-4.225*BEVAP)
ELSEIF(OPT_RSF == 3) THEN
RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-6.0 *BEVAP)
ENDIF
IF(OPT_RSF == 4) THEN
RSURF = 1. / (FSNO * (1./parameters%RSURF_SNOW) + (1.-FSNO) * (1./max(RSURF, 0.001)))
ENDIF
IF(SH2O(1) < 0.01 .and. SNOWH == 0.) RSURF = 1.E6
PSI = -parameters%PSISAT(1)*(MAX(0.01,SH2O(1))/parameters%SMCMAX(1))**(-parameters%BEXP(1))
RHSUR = FSNO + (1.-FSNO) * EXP(PSI*GRAV/(RW*TG))
END IF
IF (parameters%urban_flag .and. SNOWH == 0. ) THEN
RSURF = 1.E6
ENDIF
IF (TV .GT. TFRZ) THEN
LATHEAV = HVAP
frozen_canopy = .false.
ELSE
LATHEAV = HSUB
frozen_canopy = .true.
END IF
GAMMAV = CPAIR*SFCPRS/(0.622*LATHEAV)
IF (TG .GT. TFRZ) THEN
LATHEAG = HVAP
frozen_ground = .false.
ELSE
LATHEAG = HSUB
frozen_ground = .true.
END IF
GAMMAG = CPAIR*SFCPRS/(0.622*LATHEAG)
IF (VEG .AND. FVEG > 0) THEN
TGV = TG
CMV = CM
CHV = CH
CALL VEGE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , &
DT ,SAV ,SAG ,LWDN ,UR , &
UU ,VV ,SFCTMP ,THAIR ,QAIR , &
EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG , &
FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , &
ZLVL ,ZPD ,Z0M ,FVEG , &
Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, &
CANICE ,STC ,DF ,RSSUN ,RSSHA , &
RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , &
FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , &
RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , &
EAH ,TAH ,TV ,TGV ,CMV , &
CHV ,DX ,DZ8W , &
TAUXV ,TAUYV ,IRG ,IRC ,SHG , &
SHC ,EVG ,EVC ,TR ,GHV , &
T2MV ,PSNSUN ,PSNSHA , &
QC ,QSFC ,PSFC , &
Q2V ,CHV2, CHLEAF, CHUC)
END IF
TGB = TG
CMB = CM
CHB = CH
CALL BARE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,SAG , &
LWDN ,UR ,UU ,VV ,SFCTMP , &
THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , &
DZSNSO ,ZLVL ,ZPDG ,Z0MG ,FSNO, &
EMG ,STC ,DF ,RSURF ,LATHEAG , &
GAMMAG ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , &
TGB ,CMB ,CHB , &
TAUXB ,TAUYB ,IRB ,SHB ,EVB , &
GHB ,T2MB ,DX ,DZ8W ,VEGTYP , &
QC ,QSFC ,PSFC , &
SFCPRS ,Q2B, CHB2)
IF (VEG .AND. FVEG > 0) THEN
TAUX = FVEG * TAUXV + (1.0 - FVEG) * TAUXB
TAUY = FVEG * TAUYV + (1.0 - FVEG) * TAUYB
FIRA = FVEG * IRG + (1.0 - FVEG) * IRB + IRC
FSH = FVEG * SHG + (1.0 - FVEG) * SHB + SHC
FGEV = FVEG * EVG + (1.0 - FVEG) * EVB
SSOIL = FVEG * GHV + (1.0 - FVEG) * GHB
FCEV = EVC
FCTR = TR
PAH = FVEG * PAHG + (1.0 - FVEG) * PAHB + PAHV
TG = FVEG * TGV + (1.0 - FVEG) * TGB
T2M = FVEG * T2MV + (1.0 - FVEG) * T2MB
TS = FVEG * TV + (1.0 - FVEG) * TGB
CM = FVEG * CMV + (1.0 - FVEG) * CMB
CH = FVEG * CHV + (1.0 - FVEG) * CHB
Q1 = FVEG * (EAH*0.622/(SFCPRS - 0.378*EAH)) + (1.0 - FVEG)*QSFC
Q2E = FVEG * Q2V + (1.0 - FVEG) * Q2B
Z0WRF = Z0M
ELSE
TAUX = TAUXB
TAUY = TAUYB
FIRA = IRB
FSH = SHB
FGEV = EVB
SSOIL = GHB
TG = TGB
T2M = T2MB
FCEV = 0.
FCTR = 0.
PAH = PAHB
TS = TG
CM = CMB
CH = CHB
Q1 = QSFC
Q2E = Q2B
RSSUN = 0.0
RSSHA = 0.0
TGV = TGB
CHV = CHB
Z0WRF = Z0MG
END IF
FIRE = LWDN + FIRA
IF(FIRE <=0.) THEN
WRITE(6,*) 'emitted longwave <0; skin T may be wrong due to inconsistent'
WRITE(6,*) 'input of SHDFAC with LAI'
WRITE(6,*) ILOC, JLOC, 'SHDFAC=',FVEG,'VAI=',VAI,'TV=',TV,'TG=',TG
WRITE(6,*) 'LWDN=',LWDN,'FIRA=',FIRA,'SNOWH=',SNOWH
call wrf_error_fatal3("<stdin>",1991,&
"STOP in Noah-MP")
END IF
EMISSI = FVEG * ( EMG*(1-EMV) + EMV + EMV*(1-EMV)*(1-EMG) ) + &
(1-FVEG) * EMG
TRAD = ( ( FIRE - (1-EMISSI)*LWDN ) / (EMISSI*SB) ) ** 0.25
APAR = PARSUN*LAISUN + PARSHA*LAISHA
PSN = PSNSUN*LAISUN + PSNSHA*LAISHA
CALL TSNOSOI (parameters,ICE ,NSOIL ,NSNOW ,ISNOW ,IST , &
TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , &
SAG ,DT ,SNOWH ,DZSNSO , &
TG ,ILOC ,JLOC , &
STC )
IF(OPT_STC == 2) THEN
IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN
TGV = TFRZ
TGB = TFRZ
IF (VEG .AND. FVEG > 0) THEN
TG = FVEG * TGV + (1.0 - FVEG) * TGB
TS = FVEG * TV + (1.0 - FVEG) * TGB
ELSE
TG = TGB
TS = TGB
END IF
END IF
END IF
CALL PHASECHANGE (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,FACT , &
DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , &
STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , &
SMC ,SH2O , &
QMELT ,IMELT ,PONDING )
END SUBROUTINE ENERGY
SUBROUTINE THERMOPROP (parameters,NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , &
DT ,SNOWH ,SNICE ,SNLIQ , &
SMC ,SH2O ,TG ,STC ,UR , &
LAT ,Z0M ,ZLVL ,VEGTYP , &
DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , &
FACT )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER , INTENT(IN) :: NSOIL
INTEGER , INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: ISNOW
INTEGER , INTENT(IN) :: IST
REAL , INTENT(IN) :: DT
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SH2O
REAL , INTENT(IN) :: SNOWH
REAL, INTENT(IN) :: TG
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL, INTENT(IN) :: UR
REAL, INTENT(IN) :: LAT
REAL, INTENT(IN) :: Z0M
REAL, INTENT(IN) :: ZLVL
INTEGER , INTENT(IN) :: VEGTYP
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: DF
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: HCPCT
REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV
REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV
REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: FACT
INTEGER :: IZ
REAL, DIMENSION(-NSNOW+1: 0) :: CVSNO
REAL, DIMENSION(-NSNOW+1: 0) :: TKSNO
REAL, DIMENSION( 1:NSOIL) :: SICE
CALL CSNOW (parameters,ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , &
TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE )
DO IZ = ISNOW+1, 0
DF (IZ) = TKSNO(IZ)
HCPCT(IZ) = CVSNO(IZ)
END DO
DO IZ = 1, NSOIL
SICE(IZ) = SMC(IZ) - SH2O(IZ)
HCPCT(IZ) = SH2O(IZ)*CWAT + (1.0-parameters%SMCMAX(IZ))*parameters%CSOIL &
+ (parameters%SMCMAX(IZ)-SMC(IZ))*CPAIR + SICE(IZ)*CICE
CALL TDFCND (parameters,IZ,DF(IZ), SMC(IZ), SH2O(IZ))
END DO
IF ( parameters%urban_flag ) THEN
DO IZ = 1,NSOIL
DF(IZ) = 3.24
END DO
ENDIF
IF(IST == 2) THEN
DO IZ = 1, NSOIL
IF(STC(IZ) > TFRZ) THEN
HCPCT(IZ) = CWAT
DF(IZ) = TKWAT
ELSE
HCPCT(IZ) = CICE
DF(IZ) = TKICE
END IF
END DO
END IF
DO IZ = ISNOW+1,NSOIL
FACT(IZ) = DT/(HCPCT(IZ)*DZSNSO(IZ))
END DO
IF(ISNOW == 0) THEN
DF(1) = (DF(1)*DZSNSO(1)+0.35*SNOWH) / (SNOWH +DZSNSO(1))
ELSE
DF(1) = (DF(1)*DZSNSO(1)+DF(0)*DZSNSO(0)) / (DZSNSO(0)+DZSNSO(1))
END IF
END SUBROUTINE THERMOPROP
SUBROUTINE CSNOW (parameters,ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , &
TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ISNOW
INTEGER , INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: NSOIL
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: CVSNO
REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: TKSNO
REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV
REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV
REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE
INTEGER :: IZ
REAL, DIMENSION(-NSNOW+1: 0) :: BDSNOI
DO IZ = ISNOW+1, 0
SNICEV(IZ) = MIN(1., SNICE(IZ)/(DZSNSO(IZ)*DENICE) )
EPORE(IZ) = 1. - SNICEV(IZ)
SNLIQV(IZ) = MIN(EPORE(IZ),SNLIQ(IZ)/(DZSNSO(IZ)*DENH2O))
ENDDO
DO IZ = ISNOW+1, 0
BDSNOI(IZ) = (SNICE(IZ)+SNLIQ(IZ))/DZSNSO(IZ)
CVSNO(IZ) = CICE*SNICEV(IZ)+CWAT*SNLIQV(IZ)
enddo
DO IZ = ISNOW+1, 0
TKSNO(IZ) = 3.2217E-6*BDSNOI(IZ)**2.
ENDDO
END SUBROUTINE CSNOW
SUBROUTINE TDFCND (parameters, ISOIL, DF, SMC, SH2O)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ISOIL
REAL, INTENT(IN) :: SMC
REAL, INTENT(IN) :: SH2O
REAL, INTENT(OUT) :: DF
REAL :: AKE
REAL :: GAMMD
REAL :: THKDRY
REAL :: THKO
REAL :: THKQTZ
REAL :: THKSAT
REAL :: THKS
REAL :: THKW
REAL :: SATRATIO
REAL :: XU
REAL :: XUNFROZ
SATRATIO = SMC / parameters%SMCMAX(ISOIL)
THKW = 0.57
THKO = 2.0
THKQTZ = 7.7
THKS = (THKQTZ ** parameters%QUARTZ(ISOIL))* (THKO ** (1. - parameters%QUARTZ(ISOIL)))
XUNFROZ = 1.0
IF(SMC > 0.) XUNFROZ = SH2O / SMC
XU = XUNFROZ * parameters%SMCMAX(ISOIL)
THKSAT = THKS ** (1. - parameters%SMCMAX(ISOIL))* TKICE ** (parameters%SMCMAX(ISOIL) - XU)* THKW ** &
(XU)
GAMMD = (1. - parameters%SMCMAX(ISOIL))*2700.
THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD)
IF ( (SH2O + 0.0005) < SMC ) THEN
AKE = SATRATIO
ELSE
IF ( SATRATIO > 0.1 ) THEN
AKE = LOG10 (SATRATIO) + 1.0
ELSE
AKE = 0.0
END IF
END IF
DF = AKE * (THKSAT - THKDRY) + THKDRY
end subroutine TDFCND
SUBROUTINE RADIATION (parameters,VEGTYP ,IST ,ICE ,NSOIL , &
SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , &
TG ,TV ,FSNO ,QSNOW ,FWET , &
ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , &
FVEG ,ILOC ,JLOC , &
ALBOLD ,TAUSS , &
FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , &
SAV ,SAG ,FSR ,FSA ,FSRV , &
FSRG ,BGAP ,WGAP)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: VEGTYP
INTEGER, INTENT(IN) :: IST
INTEGER, INTENT(IN) :: ICE
INTEGER, INTENT(IN) :: NSOIL
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: QSNOW
REAL, INTENT(IN) :: SNEQVO
REAL, INTENT(IN) :: SNEQV
REAL, INTENT(IN) :: SNOWH
REAL, INTENT(IN) :: COSZ
REAL, INTENT(IN) :: TG
REAL, INTENT(IN) :: TV
REAL, INTENT(IN) :: ELAI
REAL, INTENT(IN) :: ESAI
REAL, INTENT(IN) :: FWET
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC
REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAD
REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAI
REAL, INTENT(IN) :: FSNO
REAL, INTENT(IN) :: FVEG
REAL, INTENT(INOUT) :: ALBOLD
REAL, INTENT(INOUT) :: TAUSS
REAL, INTENT(OUT) :: FSUN
REAL, INTENT(OUT) :: LAISUN
REAL, INTENT(OUT) :: LAISHA
REAL, INTENT(OUT) :: PARSUN
REAL, INTENT(OUT) :: PARSHA
REAL, INTENT(OUT) :: SAV
REAL, INTENT(OUT) :: SAG
REAL, INTENT(OUT) :: FSA
REAL, INTENT(OUT) :: FSR
REAL, INTENT(OUT) :: FSRV
REAL, INTENT(OUT) :: FSRG
REAL, INTENT(OUT) :: BGAP
REAL, INTENT(OUT) :: WGAP
REAL :: FAGE
REAL, DIMENSION(1:2) :: ALBGRD
REAL, DIMENSION(1:2) :: ALBGRI
REAL, DIMENSION(1:2) :: ALBD
REAL, DIMENSION(1:2) :: ALBI
REAL, DIMENSION(1:2) :: FABD
REAL, DIMENSION(1:2) :: FABI
REAL, DIMENSION(1:2) :: FTDD
REAL, DIMENSION(1:2) :: FTID
REAL, DIMENSION(1:2) :: FTII
REAL, DIMENSION(1:2) :: FREVI
REAL, DIMENSION(1:2) :: FREVD
REAL, DIMENSION(1:2) :: FREGI
REAL, DIMENSION(1:2) :: FREGD
REAL :: FSHA
REAL :: VAI
REAL,PARAMETER :: MPE = 1.E-6
LOGICAL VEG
CALL ALBEDO (parameters,VEGTYP ,IST ,ICE ,NSOIL , &
DT ,COSZ ,FAGE ,ELAI ,ESAI , &
TG ,TV ,SNOWH ,FSNO ,FWET , &
SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , &
ILOC ,JLOC , &
ALBOLD ,TAUSS , &
ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , &
FABI ,FTDD ,FTID ,FTII ,FSUN , &
FREVI ,FREVD ,FREGD ,FREGI ,BGAP , &
WGAP)
FSHA = 1.-FSUN
LAISUN = ELAI*FSUN
LAISHA = ELAI*FSHA
VAI = ELAI+ ESAI
IF (VAI .GT. 0.) THEN
VEG = .TRUE.
ELSE
VEG = .FALSE.
END IF
CALL SURRAD (parameters,MPE ,FSUN ,FSHA ,ELAI ,VAI , &
LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , &
FABI ,FTDD ,FTID ,FTII ,ALBGRD , &
ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , &
PARSUN ,PARSHA ,SAV ,SAG ,FSA , &
FSR , &
FREVI ,FREVD ,FREGD ,FREGI ,FSRV , &
FSRG)
END SUBROUTINE RADIATION
SUBROUTINE ALBEDO (parameters,VEGTYP ,IST ,ICE ,NSOIL , &
DT ,COSZ ,FAGE ,ELAI ,ESAI , &
TG ,TV ,SNOWH ,FSNO ,FWET , &
SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , &
ILOC ,JLOC , &
ALBOLD ,TAUSS , &
ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , &
FABI ,FTDD ,FTID ,FTII ,FSUN , &
FREVI ,FREVD ,FREGD ,FREGI ,BGAP , &
WGAP)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: VEGTYP
INTEGER, INTENT(IN) :: IST
INTEGER, INTENT(IN) :: ICE
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: QSNOW
REAL, INTENT(IN) :: COSZ
REAL, INTENT(IN) :: SNOWH
REAL, INTENT(IN) :: TG
REAL, INTENT(IN) :: TV
REAL, INTENT(IN) :: ELAI
REAL, INTENT(IN) :: ESAI
REAL, INTENT(IN) :: FSNO
REAL, INTENT(IN) :: FWET
REAL, INTENT(IN) :: SNEQVO
REAL, INTENT(IN) :: SNEQV
REAL, INTENT(IN) :: FVEG
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC
REAL, INTENT(INOUT) :: ALBOLD
REAL, INTENT(INOUT) :: TAUSS
REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD
REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI
REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBD
REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBI
REAL, DIMENSION(1: 2), INTENT(OUT) :: FABD
REAL, DIMENSION(1: 2), INTENT(OUT) :: FABI
REAL, DIMENSION(1: 2), INTENT(OUT) :: FTDD
REAL, DIMENSION(1: 2), INTENT(OUT) :: FTID
REAL, DIMENSION(1: 2), INTENT(OUT) :: FTII
REAL, INTENT(OUT) :: FSUN
REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVD
REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVI
REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGD
REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGI
REAL, INTENT(OUT) :: BGAP
REAL, INTENT(OUT) :: WGAP
REAL :: FAGE
REAL :: ALB
INTEGER :: IB
INTEGER :: NBAND
INTEGER :: IC
REAL :: WL
REAL :: WS
REAL :: MPE
REAL, DIMENSION(1:2) :: RHO
REAL, DIMENSION(1:2) :: TAU
REAL, DIMENSION(1:2) :: FTDI
REAL, DIMENSION(1:2) :: ALBSND
REAL, DIMENSION(1:2) :: ALBSNI
REAL :: VAI
REAL :: GDIR
REAL :: EXT
NBAND = 2
MPE = 1.E-06
BGAP = 0.
WGAP = 0.
DO IB = 1, NBAND
ALBD(IB) = 0.
ALBI(IB) = 0.
ALBGRD(IB) = 0.
ALBGRI(IB) = 0.
FABD(IB) = 0.
FABI(IB) = 0.
FTDD(IB) = 0.
FTID(IB) = 0.
FTII(IB) = 0.
IF (IB.EQ.1) FSUN = 0.
END DO
IF(COSZ <= 0) GOTO 100
DO IB = 1, NBAND
VAI = ELAI + ESAI
WL = ELAI / MAX(VAI,MPE)
WS = ESAI / MAX(VAI,MPE)
RHO(IB) = MAX(parameters%RHOL(IB)*WL+parameters%RHOS(IB)*WS, MPE)
TAU(IB) = MAX(parameters%TAUL(IB)*WL+parameters%TAUS(IB)*WS, MPE)
END DO
CALL SNOW_AGE (parameters,DT,TG,SNEQVO,SNEQV,TAUSS,FAGE)
IF(OPT_ALB == 1) &
CALL SNOWALB_BATS (parameters,NBAND, FSNO,COSZ,FAGE,ALBSND,ALBSNI)
IF(OPT_ALB == 2) THEN
CALL SNOWALB_CLASS (parameters,NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC)
ALBOLD = ALB
END IF
CALL GROUNDALB (parameters,NSOIL ,NBAND ,ICE ,IST , &
FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , &
TG ,ILOC ,JLOC , &
ALBGRD ,ALBGRI )
DO IB = 1, NBAND
IC = 0
CALL TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , &
FWET ,TV ,ALBGRD ,ALBGRI ,RHO , &
TAU ,FVEG ,IST ,ILOC ,JLOC , &
FABD ,ALBD ,FTDD ,FTID ,GDIR , &
FREVD ,FREGD ,BGAP ,WGAP)
IC = 1
CALL TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , &
FWET ,TV ,ALBGRD ,ALBGRI ,RHO , &
TAU ,FVEG ,IST ,ILOC ,JLOC , &
FABI ,ALBI ,FTDI ,FTII ,GDIR , &
FREVI ,FREGI ,BGAP ,WGAP)
END DO
EXT = GDIR/COSZ * SQRT(1.-RHO(1)-TAU(1))
FSUN = (1.-EXP(-EXT*VAI)) / MAX(EXT*VAI,MPE)
EXT = FSUN
IF (EXT .LT. 0.01) THEN
WL = 0.
ELSE
WL = EXT
END IF
FSUN = WL
100 CONTINUE
END SUBROUTINE ALBEDO
SUBROUTINE SURRAD (parameters,MPE ,FSUN ,FSHA ,ELAI ,VAI , &
LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , &
FABI ,FTDD ,FTID ,FTII ,ALBGRD , &
ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , &
PARSUN ,PARSHA ,SAV ,SAG ,FSA , &
FSR , &
FREVI ,FREVD ,FREGD ,FREGI ,FSRV , &
FSRG)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
REAL, INTENT(IN) :: MPE
REAL, INTENT(IN) :: FSUN
REAL, INTENT(IN) :: FSHA
REAL, INTENT(IN) :: ELAI
REAL, INTENT(IN) :: VAI
REAL, INTENT(IN) :: LAISUN
REAL, INTENT(IN) :: LAISHA
REAL, DIMENSION(1:2), INTENT(IN) :: SOLAD
REAL, DIMENSION(1:2), INTENT(IN) :: SOLAI
REAL, DIMENSION(1:2), INTENT(IN) :: FABD
REAL, DIMENSION(1:2), INTENT(IN) :: FABI
REAL, DIMENSION(1:2), INTENT(IN) :: FTDD
REAL, DIMENSION(1:2), INTENT(IN) :: FTID
REAL, DIMENSION(1:2), INTENT(IN) :: FTII
REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD
REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI
REAL, DIMENSION(1:2), INTENT(IN) :: ALBD
REAL, DIMENSION(1:2), INTENT(IN) :: ALBI
REAL, DIMENSION(1:2), INTENT(IN) :: FREVD
REAL, DIMENSION(1:2), INTENT(IN) :: FREVI
REAL, DIMENSION(1:2), INTENT(IN) :: FREGD
REAL, DIMENSION(1:2), INTENT(IN) :: FREGI
REAL, INTENT(OUT) :: PARSUN
REAL, INTENT(OUT) :: PARSHA
REAL, INTENT(OUT) :: SAV
REAL, INTENT(OUT) :: SAG
REAL, INTENT(OUT) :: FSA
REAL, INTENT(OUT) :: FSR
REAL, INTENT(OUT) :: FSRV
REAL, INTENT(OUT) :: FSRG
INTEGER :: IB
INTEGER :: NBAND
REAL :: ABS
REAL :: RNIR
REAL :: RVIS
REAL :: LAIFRA
REAL :: TRD
REAL :: TRI
REAL, DIMENSION(1:2) :: CAD
REAL, DIMENSION(1:2) :: CAI
NBAND = 2
SAG = 0.
SAV = 0.
FSA = 0.
DO IB = 1, NBAND
CAD(IB) = SOLAD(IB)*FABD(IB)
CAI(IB) = SOLAI(IB)*FABI(IB)
SAV = SAV + CAD(IB) + CAI(IB)
FSA = FSA + CAD(IB) + CAI(IB)
TRD = SOLAD(IB)*FTDD(IB)
TRI = SOLAD(IB)*FTID(IB) + SOLAI(IB)*FTII(IB)
ABS = TRD*(1.-ALBGRD(IB)) + TRI*(1.-ALBGRI(IB))
SAG = SAG + ABS
FSA = FSA + ABS
END DO
LAIFRA = ELAI / MAX(VAI,MPE)
IF (FSUN .GT. 0.) THEN
PARSUN = (CAD(1)+FSUN*CAI(1)) * LAIFRA / MAX(LAISUN,MPE)
PARSHA = (FSHA*CAI(1))*LAIFRA / MAX(LAISHA,MPE)
ELSE
PARSUN = 0.
PARSHA = (CAD(1)+CAI(1))*LAIFRA /MAX(LAISHA,MPE)
ENDIF
RVIS = ALBD(1)*SOLAD(1) + ALBI(1)*SOLAI(1)
RNIR = ALBD(2)*SOLAD(2) + ALBI(2)*SOLAI(2)
FSR = RVIS + RNIR
FSRV = FREVD(1)*SOLAD(1)+FREVI(1)*SOLAI(1)+FREVD(2)*SOLAD(2)+FREVI(2)*SOLAI(2)
FSRG = FREGD(1)*SOLAD(1)+FREGI(1)*SOLAI(1)+FREGD(2)*SOLAD(2)+FREGI(2)*SOLAI(2)
END SUBROUTINE SURRAD
SUBROUTINE SNOW_AGE (parameters,DT,TG,SNEQVO,SNEQV,TAUSS,FAGE)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: TG
REAL, INTENT(IN) :: SNEQVO
REAL, INTENT(IN) :: SNEQV
REAL, INTENT(OUT) :: FAGE
REAL, INTENT(INOUT) :: TAUSS
REAL :: TAGE
REAL :: AGE1
REAL :: AGE2
REAL :: AGE3
REAL :: DELA
REAL :: SGE
REAL :: DELS
REAL :: DELA0
REAL :: ARG
IF(SNEQV.LE.0.0) THEN
TAUSS = 0.
ELSE IF (SNEQV.GT.800.) THEN
TAUSS = 0.
ELSE
DELA0 = 1.E-6*DT
ARG = 5.E3*(1./TFRZ-1./TG)
AGE1 = EXP(ARG)
AGE2 = EXP(AMIN1(0.,10.*ARG))
AGE3 = 0.3
TAGE = AGE1+AGE2+AGE3
DELA = DELA0*TAGE
DELS = AMAX1(0.0,SNEQV-SNEQVO) / parameters%SWEMX
SGE = (TAUSS+DELA)*(1.0-DELS)
TAUSS = AMAX1(0.,SGE)
ENDIF
FAGE= TAUSS/(TAUSS+1.)
END SUBROUTINE SNOW_AGE
SUBROUTINE SNOWALB_BATS (parameters,NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER,INTENT(IN) :: NBAND
REAL,INTENT(IN) :: COSZ
REAL,INTENT(IN) :: FSNO
REAL,INTENT(IN) :: FAGE
REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND
REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI
INTEGER :: IB
REAL :: FZEN
REAL :: CF1
REAL :: SL2
REAL :: SL1
REAL :: SL
REAL, PARAMETER :: C1 = 0.2
REAL, PARAMETER :: C2 = 0.5
ALBSND(1: NBAND) = 0.
ALBSNI(1: NBAND) = 0.
SL=2.0
SL1=1./SL
SL2=2.*SL
CF1=((1.+SL1)/(1.+SL2*COSZ)-SL1)
FZEN=AMAX1(CF1,0.)
ALBSNI(1)=0.95*(1.-C1*FAGE)
ALBSNI(2)=0.65*(1.-C2*FAGE)
ALBSND(1)=ALBSNI(1)+0.4*FZEN*(1.-ALBSNI(1))
ALBSND(2)=ALBSNI(2)+0.4*FZEN*(1.-ALBSNI(2))
END SUBROUTINE SNOWALB_BATS
SUBROUTINE SNOWALB_CLASS (parameters,NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER,INTENT(IN) :: ILOC
INTEGER,INTENT(IN) :: JLOC
INTEGER,INTENT(IN) :: NBAND
REAL,INTENT(IN) :: QSNOW
REAL,INTENT(IN) :: DT
REAL,INTENT(IN) :: ALBOLD
REAL, INTENT(INOUT) :: ALB
REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND
REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI
INTEGER :: IB
ALBSND(1: NBAND) = 0.
ALBSNI(1: NBAND) = 0.
ALB = 0.55 + (ALBOLD-0.55) * EXP(-0.01*DT/3600.)
IF (QSNOW > 0.) then
ALB = ALB + MIN(QSNOW,parameters%SWEMX/DT) * (0.84-ALB)/(parameters%SWEMX/DT)
ENDIF
ALBSNI(1)= ALB
ALBSNI(2)= ALB
ALBSND(1)= ALB
ALBSND(2)= ALB
END SUBROUTINE SNOWALB_CLASS
SUBROUTINE GROUNDALB (parameters,NSOIL ,NBAND ,ICE ,IST , &
FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , &
TG ,ILOC ,JLOC , &
ALBGRD ,ALBGRI )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NBAND
INTEGER, INTENT(IN) :: ICE
INTEGER, INTENT(IN) :: IST
REAL, INTENT(IN) :: FSNO
REAL, INTENT(IN) :: TG
REAL, INTENT(IN) :: COSZ
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC
REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSND
REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSNI
REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD
REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI
INTEGER :: IB
REAL :: INC
REAL :: ALBSOD
REAL :: ALBSOI
DO IB = 1, NBAND
INC = MAX(0.11-0.40*SMC(1), 0.)
IF (IST .EQ. 1) THEN
ALBSOD = MIN(parameters%ALBSAT(IB)+INC,parameters%ALBDRY(IB))
ALBSOI = ALBSOD
ELSE IF (TG .GT. TFRZ) THEN
ALBSOD = 0.06/(MAX(0.01,COSZ)**1.7 + 0.15)
ALBSOI = 0.06
ELSE
ALBSOD = parameters%ALBLAK(IB)
ALBSOI = ALBSOD
END IF
ALBGRD(IB) = ALBSOD*(1.-FSNO) + ALBSND(IB)*FSNO
ALBGRI(IB) = ALBSOI*(1.-FSNO) + ALBSNI(IB)*FSNO
END DO
END SUBROUTINE GROUNDALB
SUBROUTINE TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , &
FWET ,T ,ALBGRD ,ALBGRI ,RHO , &
TAU ,FVEG ,IST ,ILOC ,JLOC , &
FAB ,FRE ,FTD ,FTI ,GDIR , &
FREV ,FREG ,BGAP ,WGAP)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: IST
INTEGER, INTENT(IN) :: IB
INTEGER, INTENT(IN) :: IC
INTEGER, INTENT(IN) :: VEGTYP
REAL, INTENT(IN) :: COSZ
REAL, INTENT(IN) :: VAI
REAL, INTENT(IN) :: FWET
REAL, INTENT(IN) :: T
REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD
REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI
REAL, DIMENSION(1:2), INTENT(IN) :: RHO
REAL, DIMENSION(1:2), INTENT(IN) :: TAU
REAL, INTENT(IN) :: FVEG
REAL, DIMENSION(1:2), INTENT(OUT) :: FAB
REAL, DIMENSION(1:2), INTENT(OUT) :: FRE
REAL, DIMENSION(1:2), INTENT(OUT) :: FTD
REAL, DIMENSION(1:2), INTENT(OUT) :: FTI
REAL, INTENT(OUT) :: GDIR
REAL, DIMENSION(1:2), INTENT(OUT) :: FREV
REAL, DIMENSION(1:2), INTENT(OUT) :: FREG
REAL :: OMEGA
REAL :: OMEGAL
REAL :: BETAI
REAL :: BETAIL
REAL :: BETAD
REAL :: BETADL
REAL :: EXT
REAL :: AVMU
REAL :: COSZI
REAL :: ASU
REAL :: CHIL
REAL :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9
REAL :: P1,P2,P3,P4,S1,S2,U1,U2,U3
REAL :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10
REAL :: PHI1,PHI2,SIGMA
REAL :: FTDS,FTIS,FRES
REAL :: DENFVEG
REAL :: VAI_SPREAD
REAL :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR
REAL :: THETAZ
REAL, PARAMETER :: PAI = 3.14159265
REAL :: HD
REAL :: BB
REAL :: THETAP
REAL :: FA
REAL :: NEWVAI
REAL,INTENT(INOUT) :: BGAP
REAL,INTENT(INOUT) :: WGAP
REAL :: KOPEN
REAL :: GAP
VAI_SPREAD = VAI
if(VAI == 0.0) THEN
GAP = 1.0
KOPEN = 1.0
ELSE
IF(OPT_RAD == 1) THEN
DENFVEG = -LOG(MAX(1.0-FVEG,0.01))/(PAI*parameters%RC**2)
HD = parameters%HVT - parameters%HVB
BB = 0.5 * HD
THETAP = ATAN(BB/parameters%RC * TAN(ACOS(MAX(0.01,COSZ))) )
BGAP = EXP(-DENFVEG * PAI * parameters%RC**2/COS(THETAP) )
FA = VAI/(1.33 * PAI * parameters%RC**3.0 *(BB/parameters%RC)*DENFVEG)
NEWVAI = HD*FA
WGAP = (1.0-BGAP) * EXP(-0.5*NEWVAI/COSZ)
GAP = MIN(1.0-FVEG, BGAP+WGAP)
KOPEN = 0.05
END IF
IF(OPT_RAD == 2) THEN
GAP = 0.0
KOPEN = 0.0
END IF
IF(OPT_RAD == 3) THEN
GAP = 1.0-FVEG
KOPEN = 1.0-FVEG
END IF
end if
COSZI = MAX(0.001, COSZ)
CHIL = MIN( MAX(parameters%XL, -0.4), 0.6)
IF (ABS(CHIL) .LE. 0.01) CHIL = 0.01
PHI1 = 0.5 - 0.633*CHIL - 0.330*CHIL*CHIL
PHI2 = 0.877 * (1.-2.*PHI1)
GDIR = PHI1 + PHI2*COSZI
EXT = GDIR/COSZI
AVMU = ( 1. - PHI1/PHI2 * LOG((PHI1+PHI2)/PHI1) ) / PHI2
OMEGAL = RHO(IB) + TAU(IB)
TMP0 = GDIR + PHI2*COSZI
TMP1 = PHI1*COSZI
ASU = 0.5*OMEGAL*GDIR/TMP0 * ( 1.-TMP1/TMP0*LOG((TMP1+TMP0)/TMP1) )
BETADL = (1.+AVMU*EXT)/(OMEGAL*AVMU*EXT)*ASU
BETAIL = 0.5 * ( RHO(IB)+TAU(IB) + (RHO(IB)-TAU(IB)) &
* ((1.+CHIL)/2.)**2 ) / OMEGAL
IF (T .GT. TFRZ) THEN
TMP0 = OMEGAL
TMP1 = BETADL
TMP2 = BETAIL
ELSE
TMP0 = (1.-FWET)*OMEGAL + FWET*parameters%OMEGAS(IB)
TMP1 = ( (1.-FWET)*OMEGAL*BETADL + FWET*parameters%OMEGAS(IB)*parameters%BETADS ) / TMP0
TMP2 = ( (1.-FWET)*OMEGAL*BETAIL + FWET*parameters%OMEGAS(IB)*parameters%BETAIS ) / TMP0
END IF
OMEGA = TMP0
BETAD = TMP1
BETAI = TMP2
B = 1. - OMEGA + OMEGA*BETAI
C = OMEGA*BETAI
TMP0 = AVMU*EXT
D = TMP0 * OMEGA*BETAD
F = TMP0 * OMEGA*(1.-BETAD)
TMP1 = B*B - C*C
H = SQRT(TMP1) / AVMU
SIGMA = TMP0*TMP0 - TMP1
if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,SIGMA)
P1 = B + AVMU*H
P2 = B - AVMU*H
P3 = B + TMP0
P4 = B - TMP0
S1 = EXP(-H*VAI)
S2 = EXP(-EXT*VAI)
IF (IC .EQ. 0) THEN
U1 = B - C/ALBGRD(IB)
U2 = B - C*ALBGRD(IB)
U3 = F + C*ALBGRD(IB)
ELSE
U1 = B - C/ALBGRI(IB)
U2 = B - C*ALBGRI(IB)
U3 = F + C*ALBGRI(IB)
END IF
TMP2 = U1 - AVMU*H
TMP3 = U1 + AVMU*H
D1 = P1*TMP2/S1 - P2*TMP3*S1
TMP4 = U2 + AVMU*H
TMP5 = U2 - AVMU*H
D2 = TMP4/S1 - TMP5*S1
H1 = -D*P4 - C*F
TMP6 = D - H1*P3/SIGMA
TMP7 = ( D - C - H1/SIGMA*(U1+TMP0) ) * S2
H2 = ( TMP6*TMP2/S1 - P2*TMP7 ) / D1
H3 = - ( TMP6*TMP3*S1 - P1*TMP7 ) / D1
H4 = -F*P3 - C*D
TMP8 = H4/SIGMA
TMP9 = ( U3 - TMP8*(U2-TMP0) ) * S2
H5 = - ( TMP8*TMP4/S1 + TMP9 ) / D2
H6 = ( TMP8*TMP5*S1 + TMP9 ) / D2
H7 = (C*TMP2) / (D1*S1)
H8 = (-C*TMP3*S1) / D1
H9 = TMP4 / (D2*S1)
H10 = (-TMP5*S1) / D2
IF (IC .EQ. 0) THEN
FTDS = S2 *(1.0-GAP) + GAP
FTIS = (H4*S2/SIGMA + H5*S1 + H6/S1)*(1.0-GAP)
ELSE
FTDS = 0.
FTIS = (H9*S1 + H10/S1)*(1.0-KOPEN) + KOPEN
END IF
FTD(IB) = FTDS
FTI(IB) = FTIS
IF (IC .EQ. 0) THEN
FRES = (H1/SIGMA + H2 + H3)*(1.0-GAP ) + ALBGRD(IB)*GAP
FREVEG = (H1/SIGMA + H2 + H3)*(1.0-GAP )
FREBAR = ALBGRD(IB)*GAP
ELSE
FRES = (H7 + H8) *(1.0-KOPEN) + ALBGRI(IB)*KOPEN
FREVEG = (H7 + H8) *(1.0-KOPEN) + ALBGRI(IB)*KOPEN
FREBAR = 0
END IF
FRE(IB) = FRES
FREV(IB) = FREVEG
FREG(IB) = FREBAR
FAB(IB) = 1. - FRE(IB) - (1.-ALBGRD(IB))*FTD(IB) &
- (1.-ALBGRI(IB))*FTI(IB)
END SUBROUTINE TWOSTREAM
SUBROUTINE VEGE_FLUX(parameters,NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , &
DT ,SAV ,SAG ,LWDN ,UR , &
UU ,VV ,SFCTMP ,THAIR ,QAIR , &
EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG, &
FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , &
ZLVL ,ZPD ,Z0M ,FVEG , &
Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, &
CANICE ,STC ,DF ,RSSUN ,RSSHA , &
RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , &
FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , &
RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , &
EAH ,TAH ,TV ,TG ,CM , &
CH ,DX ,DZ8W , &
TAUXV ,TAUYV ,IRG ,IRC ,SHG , &
SHC ,EVG ,EVC ,TR ,GH , &
T2MV ,PSNSUN ,PSNSHA , &
QC ,QSFC ,PSFC , &
Q2V ,CAH2 ,CHLEAF ,CHUC )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
LOGICAL, INTENT(IN) :: VEG
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: ISNOW
INTEGER, INTENT(IN) :: VEGTYP
REAL, INTENT(IN) :: FVEG
REAL, INTENT(IN) :: SAV
REAL, INTENT(IN) :: SAG
REAL, INTENT(IN) :: LWDN
REAL, INTENT(IN) :: UR
REAL, INTENT(IN) :: UU
REAL, INTENT(IN) :: VV
REAL, INTENT(IN) :: SFCTMP
REAL, INTENT(IN) :: THAIR
REAL, INTENT(IN) :: EAIR
REAL, INTENT(IN) :: QAIR
REAL, INTENT(IN) :: RHOAIR
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: FSNO
REAL, INTENT(IN) :: SNOWH
REAL, INTENT(IN) :: FWET
REAL, INTENT(IN) :: CWP
REAL, INTENT(IN) :: VAI
REAL, INTENT(IN) :: LAISUN
REAL, INTENT(IN) :: LAISHA
REAL, INTENT(IN) :: ZLVL
REAL, INTENT(IN) :: ZPD
REAL, INTENT(IN) :: Z0M
REAL, INTENT(IN) :: Z0MG
REAL, INTENT(IN) :: EMV
REAL, INTENT(IN) :: EMG
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, INTENT(IN) :: CANLIQ
REAL, INTENT(IN) :: CANICE
REAL, INTENT(IN) :: RSURF
REAL, INTENT(IN) :: GAMMAV
REAL, INTENT(IN) :: LATHEAV
REAL, INTENT(IN) :: GAMMAG
REAL, INTENT(IN) :: LATHEAG
REAL, INTENT(IN) :: PARSUN
REAL, INTENT(IN) :: PARSHA
REAL, INTENT(IN) :: FOLN
REAL, INTENT(IN) :: CO2AIR
REAL, INTENT(IN) :: O2AIR
REAL, INTENT(IN) :: IGS
REAL, INTENT(IN) :: SFCPRS
REAL, INTENT(IN) :: BTRAN
REAL, INTENT(IN) :: RHSUR
REAL , INTENT(IN) :: QC
REAL , INTENT(IN) :: PSFC
REAL , INTENT(IN) :: DX
REAL , INTENT(IN) :: Q2
REAL , INTENT(IN) :: DZ8W
REAL , INTENT(INOUT) :: QSFC
REAL, INTENT(IN) :: PAHV
REAL, INTENT(IN) :: PAHG
REAL, INTENT(INOUT) :: EAH
REAL, INTENT(INOUT) :: TAH
REAL, INTENT(INOUT) :: TV
REAL, INTENT(INOUT) :: TG
REAL, INTENT(INOUT) :: CM
REAL, INTENT(INOUT) :: CH
REAL, INTENT(OUT) :: TAUXV
REAL, INTENT(OUT) :: TAUYV
REAL, INTENT(OUT) :: IRC
REAL, INTENT(OUT) :: SHC
REAL, INTENT(OUT) :: EVC
REAL, INTENT(OUT) :: IRG
REAL, INTENT(OUT) :: SHG
REAL, INTENT(OUT) :: EVG
REAL, INTENT(OUT) :: TR
REAL, INTENT(OUT) :: GH
REAL, INTENT(OUT) :: T2MV
REAL, INTENT(OUT) :: PSNSUN
REAL, INTENT(OUT) :: PSNSHA
REAL, INTENT(OUT) :: CHLEAF
REAL, INTENT(OUT) :: CHUC
REAL, INTENT(OUT) :: Q2V
REAL :: CAH
REAL :: U10V
REAL :: V10V
REAL :: WSPD
REAL :: CW
REAL :: FV
REAL :: WSTAR
REAL :: Z0H
REAL :: Z0HG
REAL :: RB
REAL :: RAMC
REAL :: RAHC
REAL :: RAWC
REAL :: RAMG
REAL :: RAHG
REAL :: RAWG
REAL, INTENT(OUT) :: RSSUN
REAL, INTENT(OUT) :: RSSHA
REAL :: MOL
REAL :: DTV
REAL :: DTG
REAL :: AIR,CIR
REAL :: CSH
REAL :: CEV
REAL :: CGH
REAL :: ATR,CTR
REAL :: ATA,BTA
REAL :: AEA,BEA
REAL :: ESTV
REAL :: ESTG
REAL :: DESTV
REAL :: DESTG
REAL :: ESATW
REAL :: ESATI
REAL :: DSATW
REAL :: DSATI
REAL :: FM
REAL :: FH
REAL :: FHG
REAL :: HCAN
REAL :: A
REAL :: B
REAL :: CVH
REAL :: CAW
REAL :: CTW
REAL :: CEW
REAL :: CGW
REAL :: COND
REAL :: UC
REAL :: KH
REAL :: H
REAL :: HG
REAL :: MOZ
REAL :: MOZG
REAL :: MOZOLD
REAL :: FM2
REAL :: FH2
REAL :: CH2
REAL :: THSTAR
REAL :: THVAIR
REAL :: THAH
REAL :: RAHC2
REAL :: RAWC2
REAL, INTENT(OUT):: CAH2
REAL :: CH2V
REAL :: CQ2V
REAL :: EAH2
REAL :: QFX
REAL :: E1
REAL :: VAIE
REAL :: LAISUNE
REAL :: LAISHAE
INTEGER :: K
INTEGER :: ITER
INTEGER, PARAMETER :: NITERC = 20
INTEGER, PARAMETER :: NITERG = 5
INTEGER :: MOZSGN
REAL :: MPE
INTEGER :: LITER
REAL :: T, TDC
character(len=80) :: message
TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) )
MPE = 1E-6
LITER = 0
FV = 0.1
DTV = 0.
DTG = 0.
MOZ = 0.
MOZSGN = 0
MOZOLD = 0.
FH2 = 0.
HG = 0.
H = 0.
QFX = 0.
VAIE = MIN(6.,VAI / FVEG)
LAISUNE = MIN(6.,LAISUN / FVEG)
LAISHAE = MIN(6.,LAISHA / FVEG)
T = TDC(TG)
CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
IF (T .GT. 0.) THEN
ESTG = ESATW
ELSE
ESTG = ESATI
END IF
QSFC = 0.622*EAIR/(PSFC-0.378*EAIR)
HCAN = parameters%HVT
UC = UR*LOG(HCAN/Z0M)/LOG(ZLVL/Z0M)
UC = UR*LOG((HCAN-ZPD+Z0M)/Z0M)/LOG(ZLVL/Z0M)
IF((HCAN-ZPD) <= 0.) THEN
WRITE(message,*) "CRITICAL PROBLEM: HCAN <= ZPD"
call wrf_message ( message )
WRITE(message,*) 'i,j point=',ILOC, JLOC
call wrf_message ( message )
WRITE(message,*) 'HCAN =',HCAN
call wrf_message ( message )
WRITE(message,*) 'ZPD =',ZPD
call wrf_message ( message )
write (message, *) 'SNOWH =',SNOWH
call wrf_message ( message )
call wrf_error_fatal3("<stdin>",3517,&
"CRITICAL PROBLEM IN MODULE_SF_NOAHMPLSM:VEGEFLUX" )
END IF
AIR = -EMV*(1.+(1.-EMV)*(1.-EMG))*LWDN - EMV*EMG*SB*TG**4
CIR = (2.-EMV*(1.-EMG))*EMV*SB
loop1: DO ITER = 1, NITERC
IF(ITER == 1) THEN
Z0H = Z0M
Z0HG = Z0MG
ELSE
Z0H = Z0M
Z0HG = Z0MG
END IF
IF(OPT_SFC == 1) THEN
CALL SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , &
ZLVL ,ZPD ,Z0M ,Z0H ,UR , &
MPE ,ILOC ,JLOC , &
MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, &
CM ,CH ,FV ,CH2 )
ENDIF
IF(OPT_SFC == 2) THEN
CALL SFCDIF2(parameters,ITER ,Z0M ,TAH ,THAIR ,UR , &
ZLVL ,ILOC ,JLOC , &
CM ,CH ,MOZ ,WSTAR , &
FV )
CH = CH / UR
CM = CM / UR
ENDIF
RAMC = MAX(1.,1./(CM*UR))
RAHC = MAX(1.,1./(CH*UR))
RAWC = RAHC
CALL RAGRB(parameters,ITER ,VAIE ,RHOAIR ,HG ,TAH , &
ZPD ,Z0MG ,Z0HG ,HCAN ,UC , &
Z0H ,FV ,CWP ,VEGTYP ,MPE , &
TV ,MOZG ,FHG ,ILOC ,JLOC , &
RAMG ,RAHG ,RAWG ,RB )
T = TDC(TV)
CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
IF (T .GT. 0.) THEN
ESTV = ESATW
DESTV = DSATW
ELSE
ESTV = ESATI
DESTV = DSATI
END IF
IF(ITER == 1) THEN
IF (OPT_CRS == 1) then
CALL STOMATA (parameters,VEGTYP,MPE ,PARSUN ,FOLN ,ILOC , JLOC , &
TV ,ESTV ,EAH ,SFCTMP,SFCPRS, &
O2AIR ,CO2AIR,IGS ,BTRAN ,RB , &
RSSUN ,PSNSUN)
CALL STOMATA (parameters,VEGTYP,MPE ,PARSHA ,FOLN ,ILOC , JLOC , &
TV ,ESTV ,EAH ,SFCTMP,SFCPRS, &
O2AIR ,CO2AIR,IGS ,BTRAN ,RB , &
RSSHA ,PSNSHA)
END IF
IF (OPT_CRS == 2) then
CALL CANRES (parameters,PARSUN,TV ,BTRAN ,EAH ,SFCPRS, &
RSSUN ,PSNSUN,ILOC ,JLOC )
CALL CANRES (parameters,PARSHA,TV ,BTRAN ,EAH ,SFCPRS, &
RSSHA ,PSNSHA,ILOC ,JLOC )
END IF
END IF
CAH = 1./RAHC
CVH = 2.*VAIE/RB
CGH = 1./RAHG
COND = CAH + CVH + CGH
ATA = (SFCTMP*CAH + TG*CGH) / COND
BTA = CVH/COND
CSH = (1.-BTA)*RHOAIR*CPAIR*CVH
CAW = 1./RAWC
CEW = FWET*VAIE/RB
CTW = (1.-FWET)*(LAISUNE/(RB+RSSUN) + LAISHAE/(RB+RSSHA))
CGW = 1./(RAWG+RSURF)
COND = CAW + CEW + CTW + CGW
AEA = (EAIR*CAW + ESTG*CGW) / COND
BEA = (CEW+CTW)/COND
CEV = (1.-BEA)*CEW*RHOAIR*CPAIR/GAMMAV
CTR = (1.-BEA)*CTW*RHOAIR*CPAIR/GAMMAV
TAH = ATA + BTA*TV
EAH = AEA + BEA*ESTV
IRC = FVEG*(AIR + CIR*TV**4)
SHC = FVEG*RHOAIR*CPAIR*CVH * ( TV-TAH)
EVC = FVEG*RHOAIR*CPAIR*CEW * (ESTV-EAH) / GAMMAV
TR = FVEG*RHOAIR*CPAIR*CTW * (ESTV-EAH) / GAMMAV
IF (TV > TFRZ) THEN
EVC = MIN(CANLIQ*LATHEAV/DT,EVC)
ELSE
EVC = MIN(CANICE*LATHEAV/DT,EVC)
END IF
B = SAV-IRC-SHC-EVC-TR+PAHV
A = FVEG*(4.*CIR*TV**3 + CSH + (CEV+CTR)*DESTV)
DTV = B/A
IRC = IRC + FVEG*4.*CIR*TV**3*DTV
SHC = SHC + FVEG*CSH*DTV
EVC = EVC + FVEG*CEV*DESTV*DTV
TR = TR + FVEG*CTR*DESTV*DTV
TV = TV + DTV
H = RHOAIR*CPAIR*(TAH - SFCTMP) /RAHC
HG = RHOAIR*CPAIR*(TG - TAH) /RAHG
QSFC = (0.622*EAH)/(SFCPRS-0.378*EAH)
IF (LITER == 1) THEN
exit loop1
ENDIF
IF (ITER >= 5 .AND. ABS(DTV) <= 0.01 .AND. LITER == 0) THEN
LITER = 1
ENDIF
END DO loop1
AIR = - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4
CIR = EMG*SB
CSH = RHOAIR*CPAIR/RAHG
CEV = RHOAIR*CPAIR / (GAMMAG*(RAWG+RSURF))
CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1)
loop2: DO ITER = 1, NITERG
T = TDC(TG)
CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
IF (T .GT. 0.) THEN
ESTG = ESATW
DESTG = DSATW
ELSE
ESTG = ESATI
DESTG = DSATI
END IF
IRG = CIR*TG**4 + AIR
SHG = CSH * (TG - TAH )
EVG = CEV * (ESTG*RHSUR - EAH )
GH = CGH * (TG - STC(ISNOW+1))
B = SAG-IRG-SHG-EVG-GH+PAHG
A = 4.*CIR*TG**3+CSH+CEV*DESTG+CGH
DTG = B/A
IRG = IRG + 4.*CIR*TG**3*DTG
SHG = SHG + CSH*DTG
EVG = EVG + CEV*DESTG*DTG
GH = GH + CGH*DTG
TG = TG + DTG
END DO loop2
IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN
IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN
IF(OPT_STC == 1) TG = TFRZ
IF(OPT_STC == 3) TG = (1.-FSNO)*TG + FSNO*TFRZ
IRG = CIR*TG**4 - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4
SHG = CSH * (TG - TAH)
EVG = CEV * (ESTG*RHSUR - EAH)
GH = SAG+PAHG - (IRG+SHG+EVG)
END IF
END IF
TAUXV = -RHOAIR*CM*UR*UU
TAUYV = -RHOAIR*CM*UR*VV
IF (OPT_SFC == 1 .OR. OPT_SFC == 2) THEN
CAH2 = FV*VKC/LOG((2.+Z0H)/Z0H)
CAH2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2)
CQ2V = CAH2
IF (CAH2 .LT. 1.E-5 ) THEN
T2MV = TAH
Q2V = QSFC
ELSE
T2MV = TAH - (SHG+SHC/FVEG)/(RHOAIR*CPAIR) * 1./CAH2
Q2V = QSFC - ((EVC+TR)/FVEG+EVG)/(LATHEAV*RHOAIR) * 1./CQ2V
ENDIF
ENDIF
CH = CAH
CHLEAF = CVH
CHUC = 1./RAHG
END SUBROUTINE VEGE_FLUX
SUBROUTINE BARE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,SAG , &
LWDN ,UR ,UU ,VV ,SFCTMP , &
THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , &
DZSNSO ,ZLVL ,ZPD ,Z0M ,FSNO , &
EMG ,STC ,DF ,RSURF ,LATHEA , &
GAMMA ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , &
TGB ,CM ,CH , &
TAUXB ,TAUYB ,IRB ,SHB ,EVB , &
GHB ,T2MB ,DX ,DZ8W ,IVGTYP , &
QC ,QSFC ,PSFC , &
SFCPRS ,Q2B ,EHB2 )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
integer , INTENT(IN) :: ILOC
integer , INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: ISNOW
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: SAG
REAL, INTENT(IN) :: LWDN
REAL, INTENT(IN) :: UR
REAL, INTENT(IN) :: UU
REAL, INTENT(IN) :: VV
REAL, INTENT(IN) :: SFCTMP
REAL, INTENT(IN) :: THAIR
REAL, INTENT(IN) :: QAIR
REAL, INTENT(IN) :: EAIR
REAL, INTENT(IN) :: RHOAIR
REAL, INTENT(IN) :: SNOWH
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, INTENT(IN) :: ZLVL
REAL, INTENT(IN) :: ZPD
REAL, INTENT(IN) :: Z0M
REAL, INTENT(IN) :: EMG
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF
REAL, INTENT(IN) :: RSURF
REAL, INTENT(IN) :: LATHEA
REAL, INTENT(IN) :: GAMMA
REAL, INTENT(IN) :: RHSUR
REAL, INTENT(IN) :: FSNO
INTEGER , INTENT(IN) :: IVGTYP
REAL , INTENT(IN) :: QC
REAL , INTENT(INOUT) :: QSFC
REAL , INTENT(IN) :: PSFC
REAL , INTENT(IN) :: SFCPRS
REAL , INTENT(IN) :: DX
REAL , INTENT(IN) :: Q2
REAL , INTENT(IN) :: DZ8W
REAL, INTENT(IN) :: PAHB
REAL, INTENT(INOUT) :: TGB
REAL, INTENT(INOUT) :: CM
REAL, INTENT(INOUT) :: CH
REAL, INTENT(OUT) :: TAUXB
REAL, INTENT(OUT) :: TAUYB
REAL, INTENT(OUT) :: IRB
REAL, INTENT(OUT) :: SHB
REAL, INTENT(OUT) :: EVB
REAL, INTENT(OUT) :: GHB
REAL, INTENT(OUT) :: T2MB
REAL, INTENT(OUT) :: Q2B
REAL :: EHB
REAL :: U10B
REAL :: V10B
REAL :: WSPD
REAL :: TAUX
REAL :: TAUY
REAL :: FIRA
REAL :: FSH
REAL :: FGEV
REAL :: SSOIL
REAL :: FIRE
REAL :: TRAD
REAL :: TAH
REAL :: CW
REAL :: FV
REAL :: WSTAR
REAL :: Z0H
REAL :: RB
REAL :: RAMB
REAL :: RAHB
REAL :: RAWB
REAL :: MOL
REAL :: DTG
REAL :: CIR
REAL :: CSH
REAL :: CEV
REAL :: CGH
REAL :: RAHB2
REAL :: RAWB2
REAL,INTENT(OUT) :: EHB2
REAL :: CH2B
REAL :: CQ2B
REAL :: THVAIR
REAL :: THGH
REAL :: EMB
REAL :: QFX
REAL :: ESTG2
INTEGER :: VEGTYP
REAL :: E1
REAL :: ESTG
REAL :: DESTG
REAL :: ESATW
REAL :: ESATI
REAL :: DSATW
REAL :: DSATI
REAL :: A
REAL :: B
REAL :: H
REAL :: MOZ
REAL :: MOZOLD
REAL :: FM
REAL :: FH
INTEGER :: MOZSGN
REAL :: FM2
REAL :: FH2
REAL :: CH2
INTEGER :: ITER
INTEGER :: NITERB
REAL :: MPE
DATA NITERB /5/
SAVE NITERB
REAL :: T, TDC
TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) )
MPE = 1E-6
DTG = 0.
MOZ = 0.
MOZSGN = 0
MOZOLD = 0.
FH2 = 0.
H = 0.
QFX = 0.
FV = 0.1
CIR = EMG*SB
CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1)
loop3: DO ITER = 1, NITERB
IF(ITER == 1) THEN
Z0H = Z0M
ELSE
Z0H = Z0M
END IF
IF(OPT_SFC == 1) THEN
CALL SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , &
ZLVL ,ZPD ,Z0M ,Z0H ,UR , &
MPE ,ILOC ,JLOC , &
MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, &
CM ,CH ,FV ,CH2 )
ENDIF
IF(OPT_SFC == 2) THEN
CALL SFCDIF2(parameters,ITER ,Z0M ,TGB ,THAIR ,UR , &
ZLVL ,ILOC ,JLOC , &
CM ,CH ,MOZ ,WSTAR , &
FV )
CH = CH / UR
CM = CM / UR
IF(SNOWH > 0.) THEN
CM = MIN(0.01,CM)
CH = MIN(0.01,CH)
END IF
ENDIF
RAMB = MAX(1.,1./(CM*UR))
RAHB = MAX(1.,1./(CH*UR))
RAWB = RAHB
EMB = 1./RAMB
EHB = 1./RAHB
T = TDC(TGB)
CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
IF (T .GT. 0.) THEN
ESTG = ESATW
DESTG = DSATW
ELSE
ESTG = ESATI
DESTG = DSATI
END IF
CSH = RHOAIR*CPAIR/RAHB
CEV = RHOAIR*CPAIR/GAMMA/(RSURF+RAWB)
IRB = CIR * TGB**4 - EMG*LWDN
SHB = CSH * (TGB - SFCTMP )
EVB = CEV * (ESTG*RHSUR - EAIR )
GHB = CGH * (TGB - STC(ISNOW+1))
B = SAG-IRB-SHB-EVB-GHB+PAHB
A = 4.*CIR*TGB**3 + CSH + CEV*DESTG + CGH
DTG = B/A
IRB = IRB + 4.*CIR*TGB**3*DTG
SHB = SHB + CSH*DTG
EVB = EVB + CEV*DESTG*DTG
GHB = GHB + CGH*DTG
TGB = TGB + DTG
H = CSH * (TGB - SFCTMP)
T = TDC(TGB)
CALL ESAT(T, ESATW, ESATI, DSATW, DSATI)
IF (T .GT. 0.) THEN
ESTG = ESATW
ELSE
ESTG = ESATI
END IF
QSFC = 0.622*(ESTG*RHSUR)/(PSFC-0.378*(ESTG*RHSUR))
QFX = (QSFC-QAIR)*CEV*GAMMA/CPAIR
END DO loop3
IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN
IF (SNOWH > 0.05 .AND. TGB > TFRZ) THEN
IF(OPT_STC == 1) TGB = TFRZ
IF(OPT_STC == 3) TGB = (1.-FSNO)*TGB + FSNO*TFRZ
IRB = CIR * TGB**4 - EMG*LWDN
SHB = CSH * (TGB - SFCTMP)
EVB = CEV * (ESTG*RHSUR - EAIR )
GHB = SAG+PAHB - (IRB+SHB+EVB)
END IF
END IF
TAUXB = -RHOAIR*CM*UR*UU
TAUYB = -RHOAIR*CM*UR*VV
IF(OPT_SFC == 1 .OR. OPT_SFC ==2) THEN
EHB2 = FV*VKC/LOG((2.+Z0H)/Z0H)
EHB2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2)
CQ2B = EHB2
IF (EHB2.lt.1.E-5 ) THEN
T2MB = TGB
Q2B = QSFC
ELSE
T2MB = TGB - SHB/(RHOAIR*CPAIR) * 1./EHB2
Q2B = QSFC - EVB/(LATHEA*RHOAIR)*(1./CQ2B + RSURF)
ENDIF
IF (parameters%urban_flag) Q2B = QSFC
END IF
CH = EHB
END SUBROUTINE BARE_FLUX
SUBROUTINE RAGRB(parameters,ITER ,VAI ,RHOAIR ,HG ,TAH , &
ZPD ,Z0MG ,Z0HG ,HCAN ,UC , &
Z0H ,FV ,CWP ,VEGTYP ,MPE , &
TV ,MOZG ,FHG ,ILOC ,JLOC , &
RAMG ,RAHG ,RAWG ,RB )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: ITER
INTEGER, INTENT(IN) :: VEGTYP
REAL, INTENT(IN) :: VAI
REAL, INTENT(IN) :: RHOAIR
REAL, INTENT(IN) :: HG
REAL, INTENT(IN) :: TV
REAL, INTENT(IN) :: TAH
REAL, INTENT(IN) :: ZPD
REAL, INTENT(IN) :: Z0MG
REAL, INTENT(IN) :: HCAN
REAL, INTENT(IN) :: UC
REAL, INTENT(IN) :: Z0H
REAL, INTENT(IN) :: Z0HG
REAL, INTENT(IN) :: FV
REAL, INTENT(IN) :: CWP
REAL, INTENT(IN) :: MPE
REAL, INTENT(INOUT) :: MOZG
REAL, INTENT(INOUT) :: FHG
REAL :: RAMG
REAL :: RAHG
REAL :: RAWG
REAL :: RB
REAL :: KH
REAL :: TMP1
REAL :: TMP2
REAL :: TMPRAH2
REAL :: TMPRB
real :: MOLG,FHGNEW,CWPC
MOZG = 0.
MOLG = 0.
IF(ITER > 1) THEN
TMP1 = VKC * (GRAV/TAH) * HG/(RHOAIR*CPAIR)
IF (ABS(TMP1) .LE. MPE) TMP1 = MPE
MOLG = -1. * FV**3 / TMP1
MOZG = MIN( (ZPD-Z0MG)/MOLG, 1.)
END IF
IF (MOZG < 0.) THEN
FHGNEW = (1. - 15.*MOZG)**(-0.25)
ELSE
FHGNEW = 1.+ 4.7*MOZG
ENDIF
IF (ITER == 1) THEN
FHG = FHGNEW
ELSE
FHG = 0.5 * (FHG+FHGNEW)
ENDIF
CWPC = (CWP * VAI * HCAN * FHG)**0.5
TMP1 = EXP( -CWPC*Z0HG/HCAN )
TMP2 = EXP( -CWPC*(Z0H+ZPD)/HCAN )
TMPRAH2 = HCAN*EXP(CWPC) / CWPC * (TMP1-TMP2)
KH = MAX ( VKC*FV*(HCAN-ZPD), MPE )
RAMG = 0.
RAHG = TMPRAH2 / KH
RAWG = RAHG
TMPRB = CWPC*50. / (1. - EXP(-CWPC/2.))
RB = TMPRB * SQRT(parameters%DLEAF/UC)
END SUBROUTINE RAGRB
SUBROUTINE SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , &
& ZLVL ,ZPD ,Z0M ,Z0H ,UR , &
& MPE ,ILOC ,JLOC , &
& MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, &
& CM ,CH ,FV ,CH2 )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: ITER
REAL, INTENT(IN) :: SFCTMP
REAL, INTENT(IN) :: RHOAIR
REAL, INTENT(IN) :: H
REAL, INTENT(IN) :: QAIR
REAL, INTENT(IN) :: ZLVL
REAL, INTENT(IN) :: ZPD
REAL, INTENT(IN) :: Z0H
REAL, INTENT(IN) :: Z0M
REAL, INTENT(IN) :: UR
REAL, INTENT(IN) :: MPE
INTEGER, INTENT(INOUT) :: MOZSGN
REAL, INTENT(INOUT) :: MOZ
REAL, INTENT(INOUT) :: FM
REAL, INTENT(INOUT) :: FH
REAL, INTENT(INOUT) :: FM2
REAL, INTENT(INOUT) :: FH2
REAL, INTENT(OUT) :: CM
REAL, INTENT(OUT) :: CH
REAL, INTENT(OUT) :: FV
REAL, INTENT(OUT) :: CH2
REAL :: MOL
REAL :: TMPCM
REAL :: TMPCH
REAL :: FMNEW
REAL :: FHNEW
REAL :: MOZOLD
REAL :: TMP1,TMP2,TMP3,TMP4,TMP5
REAL :: TVIR
REAL :: MOZ2
REAL :: TMPCM2
REAL :: TMPCH2
REAL :: FM2NEW
REAL :: FH2NEW
REAL :: TMP12,TMP22,TMP32
REAL :: CMFM, CHFH, CM2FM2, CH2FH2
MOZOLD = MOZ
IF(ZLVL <= ZPD) THEN
write(*,*) 'critical problem: ZLVL <= ZPD; model stops'
call wrf_error_fatal3("<stdin>",4237,&
"STOP in Noah-MP")
ENDIF
TMPCM = LOG((ZLVL-ZPD) / Z0M)
TMPCH = LOG((ZLVL-ZPD) / Z0H)
TMPCM2 = LOG((2.0 + Z0M) / Z0M)
TMPCH2 = LOG((2.0 + Z0H) / Z0H)
IF(ITER == 1) THEN
FV = 0.0
MOZ = 0.0
MOL = 0.0
MOZ2 = 0.0
ELSE
TVIR = (1. + 0.61*QAIR) * SFCTMP
TMP1 = VKC * (GRAV/TVIR) * H/(RHOAIR*CPAIR)
IF (ABS(TMP1) .LE. MPE) TMP1 = MPE
MOL = -1. * FV**3 / TMP1
MOZ = MIN( (ZLVL-ZPD)/MOL, 1.)
MOZ2 = MIN( (2.0 + Z0H)/MOL, 1.)
ENDIF
IF (MOZOLD*MOZ .LT. 0.) MOZSGN = MOZSGN+1
IF (MOZSGN .GE. 2) THEN
MOZ = 0.
FM = 0.
FH = 0.
MOZ2 = 0.
FM2 = 0.
FH2 = 0.
ENDIF
IF (MOZ .LT. 0.) THEN
TMP1 = (1. - 16.*MOZ)**0.25
TMP2 = LOG((1.+TMP1*TMP1)/2.)
TMP3 = LOG((1.+TMP1)/2.)
FMNEW = 2.*TMP3 + TMP2 - 2.*ATAN(TMP1) + 1.5707963
FHNEW = 2*TMP2
TMP12 = (1. - 16.*MOZ2)**0.25
TMP22 = LOG((1.+TMP12*TMP12)/2.)
TMP32 = LOG((1.+TMP12)/2.)
FM2NEW = 2.*TMP32 + TMP22 - 2.*ATAN(TMP12) + 1.5707963
FH2NEW = 2*TMP22
ELSE
FMNEW = -5.*MOZ
FHNEW = FMNEW
FM2NEW = -5.*MOZ2
FH2NEW = FM2NEW
ENDIF
IF (ITER == 1) THEN
FM = FMNEW
FH = FHNEW
FM2 = FM2NEW
FH2 = FH2NEW
ELSE
FM = 0.5 * (FM+FMNEW)
FH = 0.5 * (FH+FHNEW)
FM2 = 0.5 * (FM2+FM2NEW)
FH2 = 0.5 * (FH2+FH2NEW)
ENDIF
FH = MIN(FH,0.9*TMPCH)
FM = MIN(FM,0.9*TMPCM)
FH2 = MIN(FH2,0.9*TMPCH2)
FM2 = MIN(FM2,0.9*TMPCM2)
CMFM = TMPCM-FM
CHFH = TMPCH-FH
CM2FM2 = TMPCM2-FM2
CH2FH2 = TMPCH2-FH2
IF(ABS(CMFM) <= MPE) CMFM = MPE
IF(ABS(CHFH) <= MPE) CHFH = MPE
IF(ABS(CM2FM2) <= MPE) CM2FM2 = MPE
IF(ABS(CH2FH2) <= MPE) CH2FH2 = MPE
CM = VKC*VKC/(CMFM*CMFM)
CH = VKC*VKC/(CMFM*CHFH)
CH2 = VKC*VKC/(CM2FM2*CH2FH2)
FV = UR * SQRT(CM)
CH2 = VKC*FV/CH2FH2
END SUBROUTINE SFCDIF1
SUBROUTINE SFCDIF2(parameters,ITER ,Z0 ,THZ0 ,THLM ,SFCSPD , &
ZLM ,ILOC ,JLOC , &
AKMS ,AKHS ,RLMO ,WSTAR2 , &
USTAR )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: ITER
REAL, INTENT(IN) :: ZLM, Z0, THZ0, THLM, SFCSPD
REAL, intent(INOUT) :: AKMS
REAL, intent(INOUT) :: AKHS
REAL, intent(INOUT) :: RLMO
REAL, intent(INOUT) :: WSTAR2
REAL, intent(OUT) :: USTAR
REAL ZZ, PSLMU, PSLMS, PSLHU, PSLHS
REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS
REAL ZILFC, ZU, ZT, RDZ, CXCH
REAL DTHV, DU2, BTGH, ZSLU, ZSLT, RLOGU, RLOGT
REAL ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4
REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, &
& RLMA
INTEGER ILECH, ITR
INTEGER, PARAMETER :: ITRMX = 5
REAL, PARAMETER :: WWST = 1.2
REAL, PARAMETER :: WWST2 = WWST * WWST
REAL, PARAMETER :: VKRM = 0.40
REAL, PARAMETER :: EXCM = 0.001
REAL, PARAMETER :: BETA = 1.0 / 270.0
REAL, PARAMETER :: BTG = BETA * GRAV
REAL, PARAMETER :: ELFC = VKRM * BTG
REAL, PARAMETER :: WOLD = 0.15
REAL, PARAMETER :: WNEW = 1.0 - WOLD
REAL, PARAMETER :: PIHF = 3.14159265 / 2.
REAL, PARAMETER :: EPSU2 = 1.E-4
REAL, PARAMETER :: EPSUST = 0.07
REAL, PARAMETER :: EPSIT = 1.E-4
REAL, PARAMETER :: EPSA = 1.E-8
REAL, PARAMETER :: ZTMIN = -5.0
REAL, PARAMETER :: ZTMAX = 1.0
REAL, PARAMETER :: HPBL = 1000.0
REAL, PARAMETER :: SQVISC = 258.2
REAL, PARAMETER :: RIC = 0.183
REAL, PARAMETER :: RRIC = 1.0 / RIC
REAL, PARAMETER :: FHNEU = 0.8
REAL, PARAMETER :: RFC = 0.191
REAL, PARAMETER :: RFAC = RIC / ( FHNEU * RFC * RFC )
PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ)
PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.))
PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ)
PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.))
PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) &
& +2.* ATAN (XX) &
&- PIHF
PSPMS (YY)= 5.* YY
PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5)
PSPHS (YY)= 5.* YY
ILECH = 0
ZILFC = - parameters%CZIL * VKRM * SQVISC
ZU = Z0
RDZ = 1./ ZLM
CXCH = EXCM * RDZ
DTHV = THLM - THZ0
DU2 = MAX (SFCSPD * SFCSPD,EPSU2)
BTGH = BTG * HPBL
IF(ITER == 1) THEN
IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.)
ELSE
WSTAR2 = 0.0
END IF
USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
RLMO = ELFC * AKHS * DTHV / USTAR **3
END IF
ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0)
ZSLU = ZLM + ZU
ZSLT = ZLM + ZT
RLOGU = log (ZSLU / ZU)
RLOGT = log (ZSLT / ZT)
ZETALT = MAX (ZSLT * RLMO,ZTMIN)
RLMO = ZETALT / ZSLT
ZETALU = ZSLU * RLMO
ZETAU = ZU * RLMO
ZETAT = ZT * RLMO
IF (ILECH .eq. 0) THEN
IF (RLMO .lt. 0.)THEN
XLU4 = 1. -16.* ZETALU
XLT4 = 1. -16.* ZETALT
XU4 = 1. -16.* ZETAU
XT4 = 1. -16.* ZETAT
XLU = SQRT (SQRT (XLU4))
XLT = SQRT (SQRT (XLT4))
XU = SQRT (SQRT (XU4))
XT = SQRT (SQRT (XT4))
PSMZ = PSPMU (XU)
SIMM = PSPMU (XLU) - PSMZ + RLOGU
PSHZ = PSPHU (XT)
SIMH = PSPHU (XLT) - PSHZ + RLOGT
ELSE
ZETALU = MIN (ZETALU,ZTMAX)
ZETALT = MIN (ZETALT,ZTMAX)
ZETAU = MIN (ZETAU,ZTMAX/(ZSLU/ZU))
ZETAT = MIN (ZETAT,ZTMAX/(ZSLT/ZT))
PSMZ = PSPMS (ZETAU)
SIMM = PSPMS (ZETALU) - PSMZ + RLOGU
PSHZ = PSPHS (ZETAT)
SIMH = PSPHS (ZETALT) - PSHZ + RLOGT
END IF
ELSE
IF (RLMO .lt. 0.)THEN
PSMZ = PSLMU (ZETAU)
SIMM = PSLMU (ZETALU) - PSMZ + RLOGU
PSHZ = PSLHU (ZETAT)
SIMH = PSLHU (ZETALT) - PSHZ + RLOGT
ELSE
ZETALU = MIN (ZETALU,ZTMAX)
ZETALT = MIN (ZETALT,ZTMAX)
PSMZ = PSLMS (ZETAU)
SIMM = PSLMS (ZETALU) - PSMZ + RLOGU
PSHZ = PSLHS (ZETAT)
SIMH = PSLHS (ZETALT) - PSHZ + RLOGT
END IF
END IF
USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST)
ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0)
ZSLT = ZLM + ZT
RLOGT = log (ZSLT / ZT)
USTARK = USTAR * VKRM
IF(SIMM < 1.e-6) SIMM = 1.e-6
AKMS = MAX (USTARK / SIMM,CXCH)
IF(SIMH < 1.e-6) SIMH = 1.e-6
AKHS = MAX (USTARK / SIMH,CXCH)
IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.)
ELSE
WSTAR2 = 0.0
END IF
RLMN = ELFC * AKHS * DTHV / USTAR **3
RLMA = RLMO * WOLD+ RLMN * WNEW
RLMO = RLMA
END SUBROUTINE SFCDIF2
SUBROUTINE ESAT(T, ESW, ESI, DESW, DESI)
IMPLICIT NONE
REAL, intent(in) :: T
REAL, intent(out) :: ESW
REAL, intent(out) :: ESI
REAL, intent(out) :: DESW
REAL, intent(out) :: DESI
REAL :: A0,A1,A2,A3,A4,A5,A6
REAL :: B0,B1,B2,B3,B4,B5,B6
REAL :: C0,C1,C2,C3,C4,C5,C6
REAL :: D0,D1,D2,D3,D4,D5,D6
PARAMETER (A0=6.107799961 , A1=4.436518521E-01, &
A2=1.428945805E-02, A3=2.650648471E-04, &
A4=3.031240396E-06, A5=2.034080948E-08, &
A6=6.136820929E-11)
PARAMETER (B0=6.109177956 , B1=5.034698970E-01, &
B2=1.886013408E-02, B3=4.176223716E-04, &
B4=5.824720280E-06, B5=4.838803174E-08, &
B6=1.838826904E-10)
PARAMETER (C0= 4.438099984E-01, C1=2.857002636E-02, &
C2= 7.938054040E-04, C3=1.215215065E-05, &
C4= 1.036561403E-07, C5=3.532421810e-10, &
C6=-7.090244804E-13)
PARAMETER (D0=5.030305237E-01, D1=3.773255020E-02, &
D2=1.267995369E-03, D3=2.477563108E-05, &
D4=3.005693132E-07, D5=2.158542548E-09, &
D6=7.131097725E-12)
ESW = 100.*(A0+T*(A1+T*(A2+T*(A3+T*(A4+T*(A5+T*A6))))))
ESI = 100.*(B0+T*(B1+T*(B2+T*(B3+T*(B4+T*(B5+T*B6))))))
DESW = 100.*(C0+T*(C1+T*(C2+T*(C3+T*(C4+T*(C5+T*C6))))))
DESI = 100.*(D0+T*(D1+T*(D2+T*(D3+T*(D4+T*(D5+T*D6))))))
END SUBROUTINE ESAT
SUBROUTINE STOMATA (parameters,VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, &
TV ,EI ,EA ,SFCTMP ,SFCPRS , &
O2 ,CO2 ,IGS ,BTRAN ,RB , &
RS ,PSN )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER,INTENT(IN) :: ILOC
INTEGER,INTENT(IN) :: JLOC
INTEGER,INTENT(IN) :: VEGTYP
REAL, INTENT(IN) :: IGS
REAL, INTENT(IN) :: MPE
REAL, INTENT(IN) :: TV
REAL, INTENT(IN) :: EI
REAL, INTENT(IN) :: EA
REAL, INTENT(IN) :: APAR
REAL, INTENT(IN) :: O2
REAL, INTENT(IN) :: CO2
REAL, INTENT(IN) :: SFCPRS
REAL, INTENT(IN) :: SFCTMP
REAL, INTENT(IN) :: BTRAN
REAL, INTENT(IN) :: FOLN
REAL, INTENT(IN) :: RB
REAL, INTENT(OUT) :: RS
REAL, INTENT(OUT) :: PSN
REAL :: RLB
INTEGER :: ITER
INTEGER :: NITER
DATA NITER /3/
SAVE NITER
REAL :: AB
REAL :: BC
REAL :: F1
REAL :: F2
REAL :: TC
REAL :: CS
REAL :: KC
REAL :: KO
REAL :: A,B,C,Q
REAL :: R1,R2
REAL :: FNF
REAL :: PPF
REAL :: WC
REAL :: WJ
REAL :: WE
REAL :: CP
REAL :: CI
REAL :: AWC
REAL :: VCMX
REAL :: J
REAL :: CEA
REAL :: CF
F1(AB,BC) = AB**((BC-25.)/10.)
F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16)))
REAL :: T
CF = SFCPRS/(8.314*SFCTMP)*1.e06
RS = 1./parameters%BP * CF
PSN = 0.
IF (APAR .LE. 0.) RETURN
FNF = MIN( FOLN/MAX(MPE,parameters%FOLNMX), 1.0 )
TC = TV-TFRZ
PPF = 4.6*APAR
J = PPF*parameters%QE25
KC = parameters%KC25 * F1(parameters%AKC,TC)
KO = parameters%KO25 * F1(parameters%AKO,TC)
AWC = KC * (1.+O2/KO)
CP = 0.5*KC/KO*O2*0.21
VCMX = parameters%VCMX25 / F2(TC) * FNF * BTRAN * F1(parameters%AVCMX,TC)
CI = 0.7*CO2*parameters%C3PSN + 0.4*CO2*(1.-parameters%C3PSN)
RLB = RB/CF
CEA = MAX(0.25*EI*parameters%C3PSN+0.40*EI*(1.-parameters%C3PSN), MIN(EA,EI) )
DO ITER = 1, NITER
WJ = MAX(CI-CP,0.)*J/(CI+2.*CP)*parameters%C3PSN + J*(1.-parameters%C3PSN)
WC = MAX(CI-CP,0.)*VCMX/(CI+AWC)*parameters%C3PSN + VCMX*(1.-parameters%C3PSN)
WE = 0.5*VCMX*parameters%C3PSN + 4000.*VCMX*CI/SFCPRS*(1.-parameters%C3PSN)
PSN = MIN(WJ,WC,WE) * IGS
CS = MAX( CO2-1.37*RLB*SFCPRS*PSN, MPE )
A = parameters%MP*PSN*SFCPRS*CEA / (CS*EI) + parameters%BP
B = ( parameters%MP*PSN*SFCPRS/CS + parameters%BP ) * RLB - 1.
C = -RLB
IF (B .GE. 0.) THEN
Q = -0.5*( B + SQRT(B*B-4.*A*C) )
ELSE
Q = -0.5*( B - SQRT(B*B-4.*A*C) )
END IF
R1 = Q/A
R2 = C/Q
RS = MAX(R1,R2)
CI = MAX( CS-PSN*SFCPRS*1.65*RS, 0. )
END DO
RS = RS*CF
END SUBROUTINE STOMATA
SUBROUTINE CANRES (parameters,PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , &
RC ,PSN ,ILOC ,JLOC )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
REAL, INTENT(IN) :: PAR
REAL, INTENT(IN) :: SFCTMP
REAL, INTENT(IN) :: SFCPRS
REAL, INTENT(IN) :: EAH
REAL, INTENT(IN) :: RCSOIL
REAL, INTENT(OUT) :: RC
REAL, INTENT(OUT) :: PSN
REAL :: RCQ
REAL :: RCS
REAL :: RCT
REAL :: FF
REAL :: Q2
REAL :: Q2SAT
REAL :: DQSDT2
RC = 0.0
RCS = 0.0
RCT = 0.0
RCQ = 0.0
Q2 = 0.622 * EAH / (SFCPRS - 0.378 * EAH)
Q2 = Q2 / (1.0 + Q2)
CALL CALHUM(parameters,SFCTMP, SFCPRS, Q2SAT, DQSDT2)
FF = 2.0 * PAR / parameters%RGL
RCS = (FF + parameters%RSMIN / parameters%RSMAX) / (1.0+ FF)
RCS = MAX (RCS,0.0001)
RCT = 1.0- 0.0016* ( (parameters%TOPT - SFCTMP)**2.0)
RCT = MAX (RCT,0.0001)
RCQ = 1.0/ (1.0+ parameters%HS * MAX(0.,Q2SAT-Q2))
RCQ = MAX (RCQ,0.01)
RC = parameters%RSMIN / (RCS * RCT * RCQ * RCSOIL)
PSN = -999.99
END SUBROUTINE CANRES
SUBROUTINE CALHUM(parameters,SFCTMP, SFCPRS, Q2SAT, DQSDT2)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
REAL, INTENT(IN) :: SFCTMP, SFCPRS
REAL, INTENT(OUT) :: Q2SAT, DQSDT2
REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, &
A23M4=A2*(A3-A4), E0=0.611, RV=461.0, &
EPSILON=0.622
REAL :: ES, SFCPRSX
ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) )
SFCPRSX = SFCPRS*1.E-3
Q2SAT = EPSILON * ES / (SFCPRSX-ES)
Q2SAT = Q2SAT * 1.E3
DQSDT2=(Q2SAT/(1+Q2SAT))*A23M4/(SFCTMP-A4)**2
Q2SAT = Q2SAT / 1.E3
END SUBROUTINE CALHUM
SUBROUTINE TSNOSOI (parameters,ICE ,NSOIL ,NSNOW ,ISNOW ,IST , &
TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , &
SAG ,DT ,SNOWH ,DZSNSO , &
TG ,ILOC ,JLOC , &
STC )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: ICE
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: ISNOW
INTEGER, INTENT(IN) :: IST
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: TBOT
REAL, INTENT(IN) :: SSOIL
REAL, INTENT(IN) :: SAG
REAL, INTENT(IN) :: SNOWH
REAL, INTENT(IN) :: TG
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
INTEGER :: IZ
REAL :: ZBOTSNO
REAL, DIMENSION(-NSNOW+1:NSOIL) :: AI, BI, CI, RHSTS
REAL :: EFLXB
REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI
REAL, DIMENSION(-NSNOW+1:NSOIL) :: TBEG
REAL :: ERR_EST
REAL :: SSOIL2
REAL :: EFLXB2
character(len=256) :: message
PHI(ISNOW+1:NSOIL) = 0.
ZBOTSNO = parameters%ZBOT - SNOWH
DO IZ = ISNOW+1, NSOIL
TBEG(IZ) = STC(IZ)
ENDDO
CALL HRT (parameters,NSNOW ,NSOIL ,ISNOW ,ZSNSO , &
STC ,TBOT ,ZBOTSNO ,DT , &
DF ,HCPCT ,SSOIL ,PHI , &
AI ,BI ,CI ,RHSTS , &
EFLXB )
CALL HSTEP (parameters,NSNOW ,NSOIL ,ISNOW ,DT , &
AI ,BI ,CI ,RHSTS , &
STC )
IF(OPT_TBOT == 1) THEN
EFLXB2 = 0.
ELSE IF(OPT_TBOT == 2) THEN
EFLXB2 = DF(NSOIL)*(TBOT-STC(NSOIL)) / &
(0.5*(ZSNSO(NSOIL-1)+ZSNSO(NSOIL)) - ZBOTSNO)
END IF
return
ERR_EST = 0.0
DO IZ = ISNOW+1, NSOIL
ERR_EST = ERR_EST + (STC(IZ)-TBEG(IZ)) * DZSNSO(IZ) * HCPCT(IZ) / DT
ENDDO
if (OPT_STC == 1 .OR. OPT_STC == 3) THEN
ERR_EST = ERR_EST - (SSOIL +EFLXB)
ELSE
SSOIL2 = DF(ISNOW+1)*(TG-STC(ISNOW+1))/(0.5*DZSNSO(ISNOW+1))
ERR_EST = ERR_EST - (SSOIL2+EFLXB2)
ENDIF
IF (ABS(ERR_EST) > 1.) THEN
WRITE(message,*) 'TSNOSOI is losing(-)/gaining(+) false energy',ERR_EST,' W/m2'
call wrf_message(trim(message))
WRITE(message,'(i6,1x,i6,1x,i3,F18.13,5F20.12)') &
ILOC, JLOC, IST,ERR_EST,SSOIL,SNOWH,TG,STC(ISNOW+1),EFLXB
call wrf_message(trim(message))
END IF
END SUBROUTINE TSNOSOI
SUBROUTINE HRT (parameters,NSNOW ,NSOIL ,ISNOW ,ZSNSO , &
STC ,TBOT ,ZBOT ,DT , &
DF ,HCPCT ,SSOIL ,PHI , &
AI ,BI ,CI ,RHSTS , &
BOTFLX )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: ISNOW
REAL, INTENT(IN) :: TBOT
REAL, INTENT(IN) :: ZBOT
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: SSOIL
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: PHI
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: RHSTS
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: AI
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: BI
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: CI
REAL, INTENT(OUT) :: BOTFLX
INTEGER :: K
REAL, DIMENSION(-NSNOW+1:NSOIL) :: DDZ
REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZ
REAL, DIMENSION(-NSNOW+1:NSOIL) :: DENOM
REAL, DIMENSION(-NSNOW+1:NSOIL) :: DTSDZ
REAL, DIMENSION(-NSNOW+1:NSOIL) :: EFLUX
REAL :: TEMP1
DO K = ISNOW+1, NSOIL
IF (K == ISNOW+1) THEN
DENOM(K) = - ZSNSO(K) * HCPCT(K)
TEMP1 = - ZSNSO(K+1)
DDZ(K) = 2.0 / TEMP1
DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1
EFLUX(K) = DF(K) * DTSDZ(K) - SSOIL - PHI(K)
ELSE IF (K < NSOIL) THEN
DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K)
TEMP1 = ZSNSO(K-1) - ZSNSO(K+1)
DDZ(K) = 2.0 / TEMP1
DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1
EFLUX(K) = (DF(K)*DTSDZ(K) - DF(K-1)*DTSDZ(K-1)) - PHI(K)
ELSE IF (K == NSOIL) THEN
DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K)
TEMP1 = ZSNSO(K-1) - ZSNSO(K)
IF(OPT_TBOT == 1) THEN
BOTFLX = 0.
END IF
IF(OPT_TBOT == 2) THEN
DTSDZ(K) = (STC(K) - TBOT) / ( 0.5*(ZSNSO(K-1)+ZSNSO(K)) - ZBOT)
BOTFLX = -DF(K) * DTSDZ(K)
END IF
EFLUX(K) = (-BOTFLX - DF(K-1)*DTSDZ(K-1) ) - PHI(K)
END IF
END DO
DO K = ISNOW+1, NSOIL
IF (K == ISNOW+1) THEN
AI(K) = 0.0
CI(K) = - DF(K) * DDZ(K) / DENOM(K)
IF (OPT_STC == 1 .OR. OPT_STC == 3 ) THEN
BI(K) = - CI(K)
END IF
IF (OPT_STC == 2) THEN
BI(K) = - CI(K) + DF(K)/(0.5*ZSNSO(K)*ZSNSO(K)*HCPCT(K))
END IF
ELSE IF (K < NSOIL) THEN
AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K)
CI(K) = - DF(K ) * DDZ(K ) / DENOM(K)
BI(K) = - (AI(K) + CI (K))
ELSE IF (K == NSOIL) THEN
AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K)
CI(K) = 0.0
BI(K) = - (AI(K) + CI(K))
END IF
RHSTS(K) = EFLUX(K)/ (-DENOM(K))
END DO
END SUBROUTINE HRT
SUBROUTINE HSTEP (parameters,NSNOW ,NSOIL ,ISNOW ,DT , &
AI ,BI ,CI ,RHSTS , &
STC )
implicit none
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: ISNOW
REAL, INTENT(IN) :: DT
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: RHSTS
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: AI
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: BI
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: CI
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
INTEGER :: K
REAL, DIMENSION(-NSNOW+1:NSOIL) :: RHSTSIN
REAL, DIMENSION(-NSNOW+1:NSOIL) :: CIIN
DO K = ISNOW+1,NSOIL
RHSTS(K) = RHSTS(K) * DT
AI(K) = AI(K) * DT
BI(K) = 1. + BI(K) * DT
CI(K) = CI(K) * DT
END DO
DO K = ISNOW+1,NSOIL
RHSTSIN(K) = RHSTS(K)
CIIN(K) = CI(K)
END DO
CALL ROSR12 (CI,AI,BI,CIIN,RHSTSIN,RHSTS,ISNOW+1,NSOIL,NSNOW)
DO K = ISNOW+1,NSOIL
STC (K) = STC (K) + CI (K)
END DO
END SUBROUTINE HSTEP
SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW)
IMPLICIT NONE
INTEGER, INTENT(IN) :: NTOP
INTEGER, INTENT(IN) :: NSOIL,NSNOW
INTEGER :: K, KK
REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(IN):: A, B, D
REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(INOUT):: C,P,DELTA
C (NSOIL) = 0.0
P (NTOP) = - C (NTOP) / B (NTOP)
DELTA (NTOP) = D (NTOP) / B (NTOP)
DO K = NTOP+1,NSOIL
P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) )
DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)&
* P (K -1)))
END DO
P (NSOIL) = DELTA (NSOIL)
DO K = NTOP+1,NSOIL
KK = NSOIL - K + (NTOP-1) + 1
P (KK) = P (KK) * P (KK +1) + DELTA (KK)
END DO
END SUBROUTINE ROSR12
SUBROUTINE PHASECHANGE (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,FACT , &
DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , &
STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , &
SMC ,SH2O , &
QMELT ,IMELT ,PONDING )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: ISNOW
INTEGER, INTENT(IN) :: IST
REAL, INTENT(IN) :: DT
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: FACT
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT
INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT
REAL, INTENT(OUT) :: QMELT
REAL, INTENT(OUT) :: PONDING
REAL, INTENT(INOUT) :: SNEQV
REAL, INTENT(INOUT) :: SNOWH
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC
REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNICE
REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNLIQ
INTEGER :: J
REAL, DIMENSION(-NSNOW+1:NSOIL) :: HM
REAL, DIMENSION(-NSNOW+1:NSOIL) :: XM
REAL, DIMENSION(-NSNOW+1:NSOIL) :: WMASS0
REAL, DIMENSION(-NSNOW+1:NSOIL) :: WICE0
REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0
REAL, DIMENSION(-NSNOW+1:NSOIL) :: MICE
REAL, DIMENSION(-NSNOW+1:NSOIL) :: MLIQ
REAL, DIMENSION(-NSNOW+1:NSOIL) :: SUPERCOOL
REAL :: HEATR
REAL :: TEMP1
REAL :: PROPOR
REAL :: SMP
REAL :: XMF
QMELT = 0.
PONDING = 0.
XMF = 0.
DO J = -NSNOW+1, NSOIL
SUPERCOOL(J) = 0.0
END DO
DO J = ISNOW+1,0
MICE(J) = SNICE(J)
MLIQ(J) = SNLIQ(J)
END DO
DO J = 1, NSOIL
MLIQ(J) = SH2O(J) * DZSNSO(J) * 1000.
MICE(J) = (SMC(J) - SH2O(J)) * DZSNSO(J) * 1000.
END DO
DO J = ISNOW+1,NSOIL
IMELT(J) = 0
HM(J) = 0.
XM(J) = 0.
WICE0(J) = MICE(J)
WLIQ0(J) = MLIQ(J)
WMASS0(J) = MICE(J) + MLIQ(J)
ENDDO
if(ist == 1) then
DO J = 1,NSOIL
IF (OPT_FRZ == 1) THEN
IF(STC(J) < TFRZ) THEN
SMP = HFUS*(TFRZ-STC(J))/(GRAV*STC(J))
SUPERCOOL(J) = parameters%SMCMAX(J)*(SMP/parameters%PSISAT(J))**(-1./parameters%BEXP(J))
SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000.
END IF
END IF
IF (OPT_FRZ == 2) THEN
CALL FRH2O (parameters,J,SUPERCOOL(J),STC(J),SMC(J),SH2O(J))
SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000.
END IF
ENDDO
end if
DO J = ISNOW+1,NSOIL
IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN
IMELT(J) = 1
ENDIF
IF (MLIQ(J) > SUPERCOOL(J) .AND. STC(J) < TFRZ) THEN
IMELT(J) = 2
ENDIF
IF (ISNOW == 0 .AND. SNEQV > 0. .AND. J == 1) THEN
IF (STC(J) >= TFRZ) THEN
IMELT(J) = 1
ENDIF
ENDIF
ENDDO
DO J = ISNOW+1,NSOIL
IF (IMELT(J) > 0) THEN
HM(J) = (STC(J)-TFRZ)/FACT(J)
STC(J) = TFRZ
ENDIF
IF (IMELT(J) == 1 .AND. HM(J) < 0.) THEN
HM(J) = 0.
IMELT(J) = 0
ENDIF
IF (IMELT(J) == 2 .AND. HM(J) > 0.) THEN
HM(J) = 0.
IMELT(J) = 0
ENDIF
XM(J) = HM(J)*DT/HFUS
ENDDO
IF (ISNOW == 0 .AND. SNEQV > 0. .AND. XM(1) > 0.) THEN
TEMP1 = SNEQV
SNEQV = MAX(0.,TEMP1-XM(1))
PROPOR = SNEQV/TEMP1
SNOWH = MAX(0.,PROPOR * SNOWH)
HEATR = HM(1) - HFUS*(TEMP1-SNEQV)/DT
IF (HEATR > 0.) THEN
XM(1) = HEATR*DT/HFUS
HM(1) = HEATR
ELSE
XM(1) = 0.
HM(1) = 0.
ENDIF
QMELT = MAX(0.,(TEMP1-SNEQV))/DT
XMF = HFUS*QMELT
PONDING = TEMP1-SNEQV
ENDIF
DO J = ISNOW+1,NSOIL
IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN
HEATR = 0.
IF (XM(J) > 0.) THEN
MICE(J) = MAX(0., WICE0(J)-XM(J))
HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT
ELSE IF (XM(J) < 0.) THEN
IF (J <= 0) THEN
MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J))
ELSE
IF (WMASS0(J) < SUPERCOOL(J)) THEN
MICE(J) = 0.
ELSE
MICE(J) = MIN(WMASS0(J) - SUPERCOOL(J),WICE0(J)-XM(J))
MICE(J) = MAX(MICE(J),0.0)
ENDIF
ENDIF
HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT
ENDIF
MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J))
IF (ABS(HEATR) > 0.) THEN
STC(J) = STC(J) + FACT(J)*HEATR
IF (J <= 0) THEN
IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ
END IF
ENDIF
XMF = XMF + HFUS * (WICE0(J)-MICE(J))/DT
IF (J < 1) THEN
QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT
ENDIF
ENDIF
ENDDO
DO J = ISNOW+1,0
SNLIQ(J) = MLIQ(J)
SNICE(J) = MICE(J)
END DO
DO J = 1, NSOIL
SH2O(J) = MLIQ(J) / (1000. * DZSNSO(J))
SMC(J) = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J))
END DO
END SUBROUTINE PHASECHANGE
SUBROUTINE FRH2O (parameters,ISOIL,FREE,TKELV,SMC,SH2O)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER,INTENT(IN) :: ISOIL
REAL, INTENT(IN) :: SH2O,SMC,TKELV
REAL, INTENT(OUT) :: FREE
REAL :: BX,DENOM,DF,DSWL,FK,SWL,SWLK
INTEGER :: NLOG,KCOUNT
REAL, PARAMETER :: CK = 8.0, BLIM = 5.5, ERROR = 0.005, &
DICE = 920.0
CHARACTER(LEN=80) :: message
BX = parameters%BEXP(ISOIL)
IF (parameters%BEXP(ISOIL) > BLIM) BX = BLIM
NLOG = 0
KCOUNT = 0
IF (TKELV > (TFRZ- 1.E-3)) THEN
FREE = SMC
ELSE
IF (CK /= 0.0) THEN
SWL = SMC - SH2O
IF (SWL > (SMC -0.02)) SWL = SMC -0.02
IF (SWL < 0.) SWL = 0.
1001 Continue
IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0))) goto 1002
NLOG = NLOG +1
DF = ALOG ( ( parameters%PSISAT(ISOIL) * GRAV / HFUS ) * ( ( 1. + CK * SWL )**2.) * &
( parameters%SMCMAX(ISOIL) / (SMC - SWL) )** BX) - ALOG ( - ( &
TKELV - TFRZ)/ TKELV)
DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL )
SWLK = SWL - DF / DENOM
IF (SWLK > (SMC -0.02)) SWLK = SMC - 0.02
IF (SWLK < 0.) SWLK = 0.
DSWL = ABS (SWLK - SWL)
SWL = SWLK
IF ( DSWL <= ERROR ) THEN
KCOUNT = KCOUNT +1
END IF
goto 1001
1002 continue
FREE = SMC - SWL
END IF
IF (KCOUNT == 0) THEN
write(message, '("Flerchinger used in NEW version. Iterations=", I6)') NLOG
call wrf_message(trim(message))
FK = ( ( (HFUS / (GRAV * ( - parameters%PSISAT(ISOIL))))* &
( (TKELV - TFRZ)/ TKELV))** ( -1/ BX))* parameters%SMCMAX(ISOIL)
IF (FK < 0.02) FK = 0.02
FREE = MIN (FK, SMC)
END IF
END IF
END SUBROUTINE FRH2O
SUBROUTINE WATER (parameters,VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , &
VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , &
ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , &
FICEOLD,PONDING,TG ,IST ,FVEG ,ILOC ,JLOC ,SMCEQ , &
BDFALL ,FP ,RAIN ,SNOW, &
QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, &
ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , &
SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , &
SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , &
SMCWTD ,DEEPRECH,RECH , &
CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , &
QIN ,QDIS ,PONDING1 ,PONDING2, &
QSNBOT &
)
implicit none
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: VEGTYP
INTEGER, INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: IST
INTEGER, INTENT(IN) :: NSOIL
INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: UU
REAL, INTENT(IN) :: VV
REAL, INTENT(IN) :: FCEV
REAL, INTENT(IN) :: FCTR
REAL, INTENT(IN) :: QPRECC
REAL, INTENT(IN) :: QPRECL
REAL, INTENT(IN) :: ELAI
REAL, INTENT(IN) :: ESAI
REAL, INTENT(IN) :: SFCTMP
REAL, INTENT(IN) :: QVAP
REAL, INTENT(IN) :: QDEW
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: BTRANI
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD
REAL , INTENT(IN) :: TG
REAL , INTENT(IN) :: FVEG
REAL , INTENT(IN) :: BDFALL
REAL , INTENT(IN) :: FP
REAL , INTENT(IN) :: RAIN
REAL , INTENT(IN) :: SNOW
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ
REAL , INTENT(IN) :: QSNOW
REAL , INTENT(IN) :: QRAIN
REAL , INTENT(IN) :: SNOWHIN
INTEGER, INTENT(INOUT) :: ISNOW
REAL, INTENT(INOUT) :: CANLIQ
REAL, INTENT(INOUT) :: CANICE
REAL, INTENT(INOUT) :: TV
REAL, INTENT(INOUT) :: SNOWH
REAL, INTENT(INOUT) :: SNEQV
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC
REAL, INTENT(INOUT) :: ZWT
REAL, INTENT(INOUT) :: WA
REAL, INTENT(INOUT) :: WT
REAL, INTENT(INOUT) :: WSLAKE
REAL , INTENT(INOUT) :: PONDING
REAL, INTENT(INOUT) :: SMCWTD
REAL, INTENT(INOUT) :: DEEPRECH
REAL, INTENT(INOUT) :: RECH
REAL, INTENT(OUT) :: CMC
REAL, INTENT(OUT) :: ECAN
REAL, INTENT(OUT) :: ETRAN
REAL, INTENT(OUT) :: FWET
REAL, INTENT(OUT) :: RUNSRF
REAL, INTENT(OUT) :: RUNSUB
REAL, INTENT(OUT) :: QIN
REAL, INTENT(OUT) :: QDIS
REAL, INTENT(OUT) :: PONDING1
REAL, INTENT(OUT) :: PONDING2
REAL, INTENT(OUT) :: QSNBOT
REAL , INTENT(IN) :: LATHEAV
REAL , INTENT(IN) :: LATHEAG
LOGICAL , INTENT(IN) :: FROZEN_GROUND
LOGICAL , INTENT(IN) :: FROZEN_CANOPY
INTEGER :: IZ
REAL :: QINSUR
REAL :: QSEVA
REAL :: QSDEW
REAL :: QSNFRO
REAL :: QSNSUB
REAL, DIMENSION( 1:NSOIL) :: ETRANI
REAL, DIMENSION( 1:NSOIL) :: WCND
REAL :: QDRAIN
REAL :: SNOFLOW
REAL :: FCRMAX
REAL, PARAMETER :: WSLMAX = 5000.
ETRANI(1:NSOIL) = 0.
SNOFLOW = 0.
RUNSUB = 0.
QINSUR = 0.
CALL CANWATER (parameters,VEGTYP ,DT , &
FCEV ,FCTR ,ELAI , &
ESAI ,TG ,FVEG ,ILOC , JLOC, &
BDFALL ,FROZEN_CANOPY , &
CANLIQ ,CANICE ,TV , &
CMC ,ECAN ,ETRAN , &
FWET )
QSNSUB = 0.
IF (SNEQV > 0.) THEN
QSNSUB = MIN(QVAP, SNEQV/DT)
ENDIF
QSEVA = QVAP-QSNSUB
QSNFRO = 0.
IF (SNEQV > 0.) THEN
QSNFRO = QDEW
ENDIF
QSDEW = QDEW - QSNFRO
CALL SNOWWATER (parameters,NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , &
& SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , &
& QRAIN ,FICEOLD,ILOC ,JLOC , &
& ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , &
& SH2O ,SICE ,STC ,ZSNSO ,DZSNSO , &
& QSNBOT ,SNOFLOW,PONDING1 ,PONDING2)
IF(FROZEN_GROUND) THEN
SICE(1) = SICE(1) + (QSDEW-QSEVA)*DT/(DZSNSO(1)*1000.)
QSDEW = 0.0
QSEVA = 0.0
IF(SICE(1) < 0.) THEN
SH2O(1) = SH2O(1) + SICE(1)
SICE(1) = 0.
END IF
END IF
QINSUR = (PONDING+PONDING1+PONDING2)/DT * 0.001
IF(ISNOW == 0) THEN
QINSUR = QINSUR+(QSNBOT + QSDEW + QRAIN) * 0.001
ELSE
QINSUR = QINSUR+(QSNBOT + QSDEW) * 0.001
ENDIF
QSEVA = QSEVA * 0.001
DO IZ = 1, parameters%NROOT
ETRANI(IZ) = ETRAN * BTRANI(IZ) * 0.001
ENDDO
IF (IST == 2) THEN
RUNSRF = 0.
IF(WSLAKE >= WSLMAX) RUNSRF = QINSUR*1000.
WSLAKE = WSLAKE + (QINSUR-QSEVA)*1000.*DT -RUNSRF*DT
ELSE
CALL SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , &
QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC , &
SH2O ,SMC ,ZWT ,VEGTYP , &
SMCWTD, DEEPRECH , &
RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX )
IF(OPT_RUN == 1) THEN
CALL GROUNDWATER (parameters,NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , &
STC ,WCND ,FCRMAX ,ILOC ,JLOC , &
SH2O ,ZWT ,WA ,WT , &
QIN ,QDIS )
RUNSUB = QDIS
END IF
IF(OPT_RUN == 3 .or. OPT_RUN == 4) THEN
RUNSUB = RUNSUB + QDRAIN
END IF
DO IZ = 1,NSOIL
SMC(IZ) = SH2O(IZ) + SICE(IZ)
ENDDO
IF(OPT_RUN == 5) THEN
CALL SHALLOWWATERTABLE (parameters,NSNOW ,NSOIL, ZSOIL, DT , &
DZSNSO ,SMCEQ ,ILOC , JLOC , &
SMC ,ZWT ,SMCWTD ,RECH, QDRAIN )
SH2O(NSOIL) = SMC(NSOIL) - SICE(NSOIL)
RUNSUB = RUNSUB + QDRAIN
WA = 0.
ENDIF
ENDIF
RUNSUB = RUNSUB + SNOFLOW
END SUBROUTINE WATER
SUBROUTINE CANWATER (parameters,VEGTYP ,DT , &
FCEV ,FCTR ,ELAI , &
ESAI ,TG ,FVEG ,ILOC , JLOC , &
BDFALL ,FROZEN_CANOPY , &
CANLIQ ,CANICE ,TV , &
CMC ,ECAN ,ETRAN , &
FWET )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER,INTENT(IN) :: ILOC
INTEGER,INTENT(IN) :: JLOC
INTEGER,INTENT(IN) :: VEGTYP
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: FCEV
REAL, INTENT(IN) :: FCTR
REAL, INTENT(IN) :: ELAI
REAL, INTENT(IN) :: ESAI
REAL, INTENT(IN) :: TG
REAL, INTENT(IN) :: FVEG
LOGICAL , INTENT(IN) :: FROZEN_CANOPY
REAL , INTENT(IN) :: BDFALL
REAL, INTENT(INOUT) :: CANLIQ
REAL, INTENT(INOUT) :: CANICE
REAL, INTENT(INOUT) :: TV
REAL, INTENT(OUT) :: CMC
REAL, INTENT(OUT) :: ECAN
REAL, INTENT(OUT) :: ETRAN
REAL, INTENT(OUT) :: FWET
REAL :: MAXSNO
REAL :: MAXLIQ
REAL :: QEVAC
REAL :: QDEWC
REAL :: QFROC
REAL :: QSUBC
REAL :: QMELTC
REAL :: QFRZC
REAL :: CANMAS
ECAN = 0.0
MAXLIQ = parameters%CH2OP * (ELAI+ ESAI)
IF (.NOT.FROZEN_CANOPY) THEN
ETRAN = MAX( FCTR/HVAP, 0. )
QEVAC = MAX( FCEV/HVAP, 0. )
QDEWC = ABS( MIN( FCEV/HVAP, 0. ) )
QSUBC = 0.
QFROC = 0.
ELSE
ETRAN = MAX( FCTR/HSUB, 0. )
QEVAC = 0.
QDEWC = 0.
QSUBC = MAX( FCEV/HSUB, 0. )
QFROC = ABS( MIN( FCEV/HSUB, 0. ) )
ENDIF
QEVAC = MIN(CANLIQ/DT,QEVAC)
CANLIQ=MAX(0.,CANLIQ+(QDEWC-QEVAC)*DT)
IF(CANLIQ <= 1.E-06) CANLIQ = 0.0
MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI)
QSUBC = MIN(CANICE/DT,QSUBC)
CANICE= MAX(0.,CANICE + (QFROC-QSUBC)*DT)
IF(CANICE.LE.1.E-6) CANICE = 0.
IF(CANICE.GT.0.) THEN
FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06)
ELSE
FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06)
ENDIF
FWET = MIN(FWET, 1.) ** 0.667
QMELTC = 0.
QFRZC = 0.
IF(CANICE.GT.1.E-6.AND.TV.GT.TFRZ) THEN
QMELTC = MIN(CANICE/DT,(TV-TFRZ)*CICE*CANICE/DENICE/(DT*HFUS))
CANICE = MAX(0.,CANICE - QMELTC*DT)
CANLIQ = MAX(0.,CANLIQ + QMELTC*DT)
TV = FWET*TFRZ + (1.-FWET)*TV
ENDIF
IF(CANLIQ.GT.1.E-6.AND.TV.LT.TFRZ) THEN
QFRZC = MIN(CANLIQ/DT,(TFRZ-TV)*CWAT*CANLIQ/DENH2O/(DT*HFUS))
CANLIQ = MAX(0.,CANLIQ - QFRZC*DT)
CANICE = MAX(0.,CANICE + QFRZC*DT)
TV = FWET*TFRZ + (1.-FWET)*TV
ENDIF
CMC = CANLIQ + CANICE
ECAN = QEVAC + QSUBC - QDEWC - QFROC
END SUBROUTINE CANWATER
SUBROUTINE SNOWWATER (parameters,NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , &
SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , &
QRAIN ,FICEOLD,ILOC ,JLOC , &
ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , &
SH2O ,SICE ,STC ,ZSNSO ,DZSNSO , &
QSNBOT ,SNOFLOW,PONDING1 ,PONDING2)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT
REAL, INTENT(IN) :: DT
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL, INTENT(IN) :: SFCTMP
REAL, INTENT(IN) :: SNOWHIN
REAL, INTENT(IN) :: QSNOW
REAL, INTENT(IN) :: QSNFRO
REAL, INTENT(IN) :: QSNSUB
REAL, INTENT(IN) :: QRAIN
REAL, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: FICEOLD
INTEGER, INTENT(INOUT) :: ISNOW
REAL, INTENT(INOUT) :: SNOWH
REAL, INTENT(INOUT) :: SNEQV
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO
REAL, INTENT(OUT) :: QSNBOT
REAL, INTENT(OUT) :: SNOFLOW
REAL, INTENT(OUT) :: PONDING1
REAL, INTENT(OUT) :: PONDING2
INTEGER :: IZ,i
REAL :: BDSNOW
SNOFLOW = 0.0
PONDING1 = 0.0
PONDING2 = 0.0
CALL SNOWFALL (parameters,NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN, &
SFCTMP ,ILOC ,JLOC , &
ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , &
SNLIQ ,SNEQV )
IF(ISNOW < 0) &
CALL COMPACT (parameters,NSNOW ,NSOIL ,DT ,STC ,SNICE , &
SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC ,&
ISNOW ,DZSNSO ,ZSNSO )
IF(ISNOW < 0) &
CALL COMBINE (parameters,NSNOW ,NSOIL ,ILOC ,JLOC , &
ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , &
DZSNSO ,SICE ,SNOWH ,SNEQV , &
PONDING1 ,PONDING2)
IF(ISNOW < 0) &
CALL DIVIDE (parameters,NSNOW ,NSOIL , &
ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO )
CALL SNOWH2O (parameters,NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , &
QRAIN ,ILOC ,JLOC , &
ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , &
SNLIQ ,SH2O ,SICE ,STC , &
QSNBOT ,PONDING1 ,PONDING2)
do iz = -nsnow+1, isnow
snice(iz) = 0.
snliq(iz) = 0.
stc(iz) = 0.
dzsnso(iz)= 0.
zsnso(iz) = 0.
enddo
IF(SNEQV > 2000.) THEN
BDSNOW = SNICE(0) / DZSNSO(0)
SNOFLOW = (SNEQV - 2000.)
SNICE(0) = SNICE(0) - SNOFLOW
DZSNSO(0) = DZSNSO(0) - SNOFLOW/BDSNOW
SNOFLOW = SNOFLOW / DT
END IF
IF(ISNOW < 0) THEN
SNEQV = 0.
DO IZ = ISNOW+1,0
SNEQV = SNEQV + SNICE(IZ) + SNLIQ(IZ)
ENDDO
END IF
DO IZ = ISNOW+1, 0
DZSNSO(IZ) = -DZSNSO(IZ)
END DO
DZSNSO(1) = ZSOIL(1)
DO IZ = 2,NSOIL
DZSNSO(IZ) = (ZSOIL(IZ) - ZSOIL(IZ-1))
END DO
ZSNSO(ISNOW+1) = DZSNSO(ISNOW+1)
DO IZ = ISNOW+2 ,NSOIL
ZSNSO(IZ) = ZSNSO(IZ-1) + DZSNSO(IZ)
ENDDO
DO IZ = ISNOW+1 ,NSOIL
DZSNSO(IZ) = -DZSNSO(IZ)
END DO
END SUBROUTINE SNOWWATER
SUBROUTINE SNOWFALL (parameters,NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN , &
SFCTMP ,ILOC ,JLOC , &
ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , &
SNLIQ ,SNEQV )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NSNOW
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: QSNOW
REAL, INTENT(IN) :: SNOWHIN
REAL, INTENT(IN) :: SFCTMP
INTEGER, INTENT(INOUT) :: ISNOW
REAL, INTENT(INOUT) :: SNOWH
REAL, INTENT(INOUT) :: SNEQV
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ
INTEGER :: NEWNODE
NEWNODE = 0
IF(ISNOW == 0 .and. QSNOW > 0.) THEN
SNOWH = SNOWH + SNOWHIN * DT
SNEQV = SNEQV + QSNOW * DT
END IF
IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.025) THEN
ISNOW = -1
NEWNODE = 1
DZSNSO(0)= SNOWH
SNOWH = 0.
STC(0) = MIN(273.16, SFCTMP)
SNICE(0) = SNEQV
SNLIQ(0) = 0.
END IF
IF(ISNOW < 0 .AND. NEWNODE == 0 .AND. QSNOW > 0.) then
SNICE(ISNOW+1) = SNICE(ISNOW+1) + QSNOW * DT
DZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) + SNOWHIN * DT
ENDIF
END SUBROUTINE SNOWFALL
SUBROUTINE COMBINE (parameters,NSNOW ,NSOIL ,ILOC ,JLOC , &
ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , &
DZSNSO ,SICE ,SNOWH ,SNEQV , &
PONDING1 ,PONDING2)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(INOUT) :: ISNOW
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO
REAL, INTENT(INOUT) :: sneqv
REAL, INTENT(INOUT) :: snowh
REAL, INTENT(OUT) :: PONDING1
REAL, INTENT(OUT) :: PONDING2
INTEGER :: I,J,K,L
INTEGER :: ISNOW_OLD
INTEGER :: MSSI
INTEGER :: NEIBOR
REAL :: ZWICE
REAL :: ZWLIQ
REAL :: DZMIN(3)
DATA DZMIN /0.025, 0.025, 0.1/
ISNOW_OLD = ISNOW
DO J = ISNOW_OLD+1,0
IF (SNICE(J) <= .1) THEN
IF(J /= 0) THEN
SNLIQ(J+1) = SNLIQ(J+1) + SNLIQ(J)
SNICE(J+1) = SNICE(J+1) + SNICE(J)
ELSE
IF (ISNOW_OLD < -1) THEN
SNLIQ(J-1) = SNLIQ(J-1) + SNLIQ(J)
SNICE(J-1) = SNICE(J-1) + SNICE(J)
ELSE
IF(SNICE(J) >= 0.) THEN
PONDING1 = SNLIQ(J)
SNEQV = SNICE(J)
SNOWH = DZSNSO(J)
ELSE
PONDING1 = SNLIQ(J) + SNICE(J)
IF(PONDING1 < 0.) THEN
SICE(1) = MAX(0.0,SICE(1)+PONDING1/(DZSNSO(1)*1000.))
PONDING1 = 0.0
END IF
SNEQV = 0.0
SNOWH = 0.0
END IF
SNLIQ(J) = 0.0
SNICE(J) = 0.0
DZSNSO(J) = 0.0
ENDIF
ENDIF
IF (J > ISNOW+1 .AND. ISNOW < -1) THEN
DO I = J, ISNOW+2, -1
STC(I) = STC(I-1)
SNLIQ(I) = SNLIQ(I-1)
SNICE(I) = SNICE(I-1)
DZSNSO(I)= DZSNSO(I-1)
END DO
END IF
ISNOW = ISNOW + 1
END IF
END DO
IF(SICE(1) < 0.) THEN
SH2O(1) = SH2O(1) + SICE(1)
SICE(1) = 0.
END IF
IF(ISNOW ==0) RETURN
SNEQV = 0.
SNOWH = 0.
ZWICE = 0.
ZWLIQ = 0.
DO J = ISNOW+1,0
SNEQV = SNEQV + SNICE(J) + SNLIQ(J)
SNOWH = SNOWH + DZSNSO(J)
ZWICE = ZWICE + SNICE(J)
ZWLIQ = ZWLIQ + SNLIQ(J)
END DO
IF (SNOWH < 0.025 .AND. ISNOW < 0 ) THEN
ISNOW = 0
SNEQV = ZWICE
PONDING2 = ZWLIQ
IF(SNEQV <= 0.) SNOWH = 0.
END IF
IF (ISNOW < -1) THEN
ISNOW_OLD = ISNOW
MSSI = 1
DO I = ISNOW_OLD+1,0
IF (DZSNSO(I) < DZMIN(MSSI)) THEN
IF (I == ISNOW+1) THEN
NEIBOR = I + 1
ELSE IF (I == 0) THEN
NEIBOR = I - 1
ELSE
NEIBOR = I + 1
IF ((DZSNSO(I-1)+DZSNSO(I)) < (DZSNSO(I+1)+DZSNSO(I))) NEIBOR = I-1
END IF
IF (NEIBOR > I) THEN
J = NEIBOR
L = I
ELSE
J = I
L = NEIBOR
END IF
CALL COMBO (parameters,DZSNSO(J), SNLIQ(J), SNICE(J), &
STC(J), DZSNSO(L), SNLIQ(L), SNICE(L), STC(L) )
IF (J-1 > ISNOW+1) THEN
DO K = J-1, ISNOW+2, -1
STC(K) = STC(K-1)
SNICE(K) = SNICE(K-1)
SNLIQ(K) = SNLIQ(K-1)
DZSNSO(K) = DZSNSO(K-1)
END DO
END IF
ISNOW = ISNOW + 1
IF (ISNOW >= -1) EXIT
ELSE
MSSI = MSSI + 1
END IF
END DO
END IF
END SUBROUTINE COMBINE
SUBROUTINE DIVIDE (parameters,NSNOW ,NSOIL , &
ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
INTEGER , INTENT(INOUT) :: ISNOW
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO
INTEGER :: J
INTEGER :: MSNO
REAL :: DRR
REAL, DIMENSION( 1:NSNOW) :: DZ
REAL, DIMENSION( 1:NSNOW) :: SWICE
REAL, DIMENSION( 1:NSNOW) :: SWLIQ
REAL, DIMENSION( 1:NSNOW) :: TSNO
REAL :: ZWICE
REAL :: ZWLIQ
REAL :: PROPOR
REAL :: DTDZ
DO J = 1,NSNOW
IF (J <= ABS(ISNOW)) THEN
DZ(J) = DZSNSO(J+ISNOW)
SWICE(J) = SNICE(J+ISNOW)
SWLIQ(J) = SNLIQ(J+ISNOW)
TSNO(J) = STC(J+ISNOW)
END IF
END DO
MSNO = ABS(ISNOW)
IF (MSNO == 1) THEN
IF (DZ(1) > 0.05) THEN
MSNO = 2
DZ(1) = DZ(1)/2.
SWICE(1) = SWICE(1)/2.
SWLIQ(1) = SWLIQ(1)/2.
DZ(2) = DZ(1)
SWICE(2) = SWICE(1)
SWLIQ(2) = SWLIQ(1)
TSNO(2) = TSNO(1)
END IF
END IF
IF (MSNO > 1) THEN
IF (DZ(1) > 0.05) THEN
DRR = DZ(1) - 0.05
PROPOR = DRR/DZ(1)
ZWICE = PROPOR*SWICE(1)
ZWLIQ = PROPOR*SWLIQ(1)
PROPOR = 0.05/DZ(1)
SWICE(1) = PROPOR*SWICE(1)
SWLIQ(1) = PROPOR*SWLIQ(1)
DZ(1) = 0.05
CALL COMBO (parameters,DZ(2), SWLIQ(2), SWICE(2), TSNO(2), DRR, &
ZWLIQ, ZWICE, TSNO(1))
IF (MSNO <= 2 .AND. DZ(2) > 0.20) THEN
MSNO = 3
DTDZ = (TSNO(1) - TSNO(2))/((DZ(1)+DZ(2))/2.)
DZ(2) = DZ(2)/2.
SWICE(2) = SWICE(2)/2.
SWLIQ(2) = SWLIQ(2)/2.
DZ(3) = DZ(2)
SWICE(3) = SWICE(2)
SWLIQ(3) = SWLIQ(2)
TSNO(3) = TSNO(2) - DTDZ*DZ(2)/2.
IF (TSNO(3) >= TFRZ) THEN
TSNO(3) = TSNO(2)
ELSE
TSNO(2) = TSNO(2) + DTDZ*DZ(2)/2.
ENDIF
END IF
END IF
END IF
IF (MSNO > 2) THEN
IF (DZ(2) > 0.2) THEN
DRR = DZ(2) - 0.2
PROPOR = DRR/DZ(2)
ZWICE = PROPOR*SWICE(2)
ZWLIQ = PROPOR*SWLIQ(2)
PROPOR = 0.2/DZ(2)
SWICE(2) = PROPOR*SWICE(2)
SWLIQ(2) = PROPOR*SWLIQ(2)
DZ(2) = 0.2
CALL COMBO (parameters,DZ(3), SWLIQ(3), SWICE(3), TSNO(3), DRR, &
ZWLIQ, ZWICE, TSNO(2))
END IF
END IF
ISNOW = -MSNO
DO J = ISNOW+1,0
DZSNSO(J) = DZ(J-ISNOW)
SNICE(J) = SWICE(J-ISNOW)
SNLIQ(J) = SWLIQ(J-ISNOW)
STC(J) = TSNO(J-ISNOW)
END DO
END SUBROUTINE DIVIDE
SUBROUTINE COMBO(parameters,DZ, WLIQ, WICE, T, DZ2, WLIQ2, WICE2, T2)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
REAL, INTENT(IN) :: DZ2
REAL, INTENT(IN) :: WLIQ2
REAL, INTENT(IN) :: WICE2
REAL, INTENT(IN) :: T2
REAL, INTENT(INOUT) :: DZ
REAL, INTENT(INOUT) :: WLIQ
REAL, INTENT(INOUT) :: WICE
REAL, INTENT(INOUT) :: T
REAL :: DZC
REAL :: WLIQC
REAL :: WICEC
REAL :: TC
REAL :: H
REAL :: H2
REAL :: HC
DZC = DZ+DZ2
WICEC = (WICE+WICE2)
WLIQC = (WLIQ+WLIQ2)
H = (CICE*WICE+CWAT*WLIQ) * (T-TFRZ)+HFUS*WLIQ
H2= (CICE*WICE2+CWAT*WLIQ2) * (T2-TFRZ)+HFUS*WLIQ2
HC = H + H2
IF(HC < 0.)THEN
TC = TFRZ + HC/(CICE*WICEC + CWAT*WLIQC)
ELSE IF (HC.LE.HFUS*WLIQC) THEN
TC = TFRZ
ELSE
TC = TFRZ + (HC - HFUS*WLIQC) / (CICE*WICEC + CWAT*WLIQC)
END IF
DZ = DZC
WICE = WICEC
WLIQ = WLIQC
T = TC
END SUBROUTINE COMBO
SUBROUTINE COMPACT (parameters,NSNOW ,NSOIL ,DT ,STC ,SNICE , &
SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC , &
ISNOW ,DZSNSO ,ZSNSO )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NSNOW
INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT
REAL, INTENT(IN) :: DT
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD
INTEGER, INTENT(INOUT) :: ISNOW
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO
REAL, PARAMETER :: C2 = 21.e-3
REAL, PARAMETER :: C3 = 2.5e-6
REAL, PARAMETER :: C4 = 0.04
REAL, PARAMETER :: C5 = 2.0
REAL, PARAMETER :: DM = 100.0
REAL, PARAMETER :: ETA0 = 0.8e+6
REAL :: BURDEN
REAL :: DDZ1
REAL :: DDZ2
REAL :: DDZ3
REAL :: DEXPF
REAL :: TD
REAL :: PDZDTC
REAL :: VOID
REAL :: WX
REAL :: BI
REAL, DIMENSION(-NSNOW+1:0) :: FICE
INTEGER :: J
BURDEN = 0.0
DO J = ISNOW+1, 0
WX = SNICE(J) + SNLIQ(J)
FICE(J) = SNICE(J) / WX
VOID = 1. - (SNICE(J)/DENICE + SNLIQ(J)/DENH2O) / DZSNSO(J)
IF (VOID > 0.001 .AND. SNICE(J) > 0.1) THEN
BI = SNICE(J) / DZSNSO(J)
TD = MAX(0.,TFRZ-STC(J))
DEXPF = EXP(-C4*TD)
DDZ1 = -C3*DEXPF
IF (BI > DM) DDZ1 = DDZ1*EXP(-46.0E-3*(BI-DM))
IF (SNLIQ(J) > 0.01*DZSNSO(J)) DDZ1=DDZ1*C5
DDZ2 = -(BURDEN+0.5*WX)*EXP(-0.08*TD-C2*BI)/ETA0
IF (IMELT(J) == 1) THEN
DDZ3 = MAX(0.,(FICEOLD(J) - FICE(J))/MAX(1.E-6,FICEOLD(J)))
DDZ3 = - DDZ3/DT
ELSE
DDZ3 = 0.
END IF
PDZDTC = (DDZ1 + DDZ2 + DDZ3)*DT
PDZDTC = MAX(-0.5,PDZDTC)
DZSNSO(J) = DZSNSO(J)*(1.+PDZDTC)
END IF
BURDEN = BURDEN + WX
END DO
END SUBROUTINE COMPACT
SUBROUTINE SNOWH2O (parameters,NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , &
QRAIN ,ILOC ,JLOC , &
ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , &
SNLIQ ,SH2O ,SICE ,STC , &
QSNBOT ,PONDING1 ,PONDING2)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: QSNFRO
REAL, INTENT(IN) :: QSNSUB
REAL, INTENT(IN) :: QRAIN
REAL, INTENT(OUT) :: QSNBOT
INTEGER, INTENT(INOUT) :: ISNOW
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO
REAL, INTENT(INOUT) :: SNOWH
REAL, INTENT(INOUT) :: SNEQV
REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNICE
REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNLIQ
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC
INTEGER :: J
REAL :: QIN
REAL :: QOUT
REAL :: WGDIF
REAL, DIMENSION(-NSNOW+1:0) :: VOL_LIQ
REAL, DIMENSION(-NSNOW+1:0) :: VOL_ICE
REAL, DIMENSION(-NSNOW+1:0) :: EPORE
REAL :: PROPOR, TEMP
REAL :: PONDING1, PONDING2
IF(SNEQV == 0.) THEN
SICE(1) = SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.)
IF(SICE(1) < 0.) THEN
SH2O(1) = SH2O(1) + SICE(1)
SICE(1) = 0.
END IF
END IF
IF(ISNOW == 0 .and. SNEQV > 0.) THEN
TEMP = SNEQV
SNEQV = SNEQV - QSNSUB*DT + QSNFRO*DT
PROPOR = SNEQV/TEMP
SNOWH = MAX(0.,PROPOR * SNOWH)
IF(SNEQV < 0.) THEN
SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.)
SNEQV = 0.
SNOWH = 0.
END IF
IF(SICE(1) < 0.) THEN
SH2O(1) = SH2O(1) + SICE(1)
SICE(1) = 0.
END IF
END IF
IF(SNOWH <= 1.E-8 .OR. SNEQV <= 1.E-6) THEN
SNOWH = 0.0
SNEQV = 0.0
END IF
IF ( ISNOW < 0 ) THEN
WGDIF = SNICE(ISNOW+1) - QSNSUB*DT + QSNFRO*DT
SNICE(ISNOW+1) = WGDIF
IF (WGDIF < 1.e-6 .and. ISNOW <0) THEN
CALL COMBINE (parameters,NSNOW ,NSOIL ,ILOC, JLOC , &
ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , &
DZSNSO ,SICE ,SNOWH ,SNEQV , &
PONDING1, PONDING2 )
ENDIF
IF ( ISNOW < 0 ) THEN
SNLIQ(ISNOW+1) = SNLIQ(ISNOW+1) + QRAIN * DT
SNLIQ(ISNOW+1) = MAX(0., SNLIQ(ISNOW+1))
ENDIF
ENDIF
DO J = -NSNOW+1, 0
IF (J >= ISNOW+1) THEN
VOL_ICE(J) = MIN(1., SNICE(J)/(DZSNSO(J)*DENICE))
EPORE(J) = 1. - VOL_ICE(J)
VOL_LIQ(J) = MIN(EPORE(J),SNLIQ(J)/(DZSNSO(J)*DENH2O))
END IF
END DO
QIN = 0.
QOUT = 0.
DO J = -NSNOW+1, 0
IF (J >= ISNOW+1) THEN
SNLIQ(J) = SNLIQ(J) + QIN
IF (J <= -1) THEN
IF (EPORE(J) < 0.05 .OR. EPORE(J+1) < 0.05) THEN
QOUT = 0.
ELSE
QOUT = MAX(0.,(VOL_LIQ(J)-parameters%SSI*EPORE(J))*DZSNSO(J))
QOUT = MIN(QOUT,(1.-VOL_ICE(J+1)-VOL_LIQ(J+1))*DZSNSO(J+1))
END IF
ELSE
QOUT = MAX(0.,(VOL_LIQ(J) - parameters%SSI*EPORE(J))*DZSNSO(J))
END IF
QOUT = QOUT*1000.
SNLIQ(J) = SNLIQ(J) - QOUT
QIN = QOUT
END IF
END DO
QSNBOT = QOUT / DT
END SUBROUTINE SNOWH2O
SUBROUTINE SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , &
QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC, &
SH2O ,SMC ,ZWT ,VEGTYP ,&
SMCWTD, DEEPRECH ,&
RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NSNOW
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: QINSUR
REAL, INTENT(IN) :: QSEVA
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ETRANI
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE
INTEGER, INTENT(IN) :: VEGTYP
REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O
REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC
REAL, INTENT(INOUT) :: ZWT
REAL, INTENT(INOUT) :: SMCWTD
REAL , INTENT(INOUT) :: DEEPRECH
REAL, INTENT(OUT) :: QDRAIN
REAL, INTENT(OUT) :: RUNSRF
REAL, INTENT(OUT) :: RUNSUB
REAL, INTENT(OUT) :: FCRMAX
REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND
INTEGER :: K,IZ
INTEGER :: ITER
REAl :: DTFINE
REAL, DIMENSION(1:NSOIL) :: RHSTT
REAL, DIMENSION(1:NSOIL) :: AI
REAL, DIMENSION(1:NSOIL) :: BI
REAL, DIMENSION(1:NSOIL) :: CI
REAL :: FFF
REAL :: RSBMX
REAL :: PDDUM
REAL :: FICE
REAL :: WPLUS
REAL :: RSAT
REAL :: SICEMAX
REAL :: SH2OMIN
REAL :: WTSUB
REAL :: MH2O
REAL :: FSAT
REAL, DIMENSION(1:NSOIL) :: MLIQ
REAL :: XS
REAL :: WATMIN
REAL :: QDRAIN_SAVE
REAL :: RUNSRF_SAVE
REAL :: EPORE
REAL, DIMENSION(1:NSOIL) :: FCR
INTEGER :: NITER
REAL :: SMCTOT
REAL :: DZTOT
REAL, PARAMETER :: A = 4.0
RUNSRF = 0.0
PDDUM = 0.0
RSAT = 0.0
DO K = 1,NSOIL
EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) )
RSAT = RSAT + MAX(0.,SH2O(K)-EPORE)*DZSNSO(K)
SH2O(K) = MIN(EPORE,SH2O(K))
END DO
DO K = 1,NSOIL
FICE = MIN(1.0,SICE(K)/parameters%SMCMAX(K))
FCR(K) = MAX(0.0,EXP(-A*(1.-FICE))- EXP(-A)) / &
(1.0 - EXP(-A))
END DO
SICEMAX = 0.0
FCRMAX = 0.0
SH2OMIN = parameters%SMCMAX(1)
DO K = 1,NSOIL
IF (SICE(K) > SICEMAX) SICEMAX = SICE(K)
IF (FCR(K) > FCRMAX) FCRMAX = FCR(K)
IF (SH2O(K) < SH2OMIN) SH2OMIN = SH2O(K)
END DO
IF(OPT_RUN == 2) THEN
FFF = 2.0
RSBMX = 4.0
CALL ZWTEQ (parameters,NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT)
RUNSUB = (1.0-FCRMAX) * RSBMX * EXP(-parameters%TIMEAN) * EXP(-FFF*ZWT)
END IF
IF ( parameters%urban_flag ) FCR(1)= 0.95
IF(OPT_RUN == 1) THEN
FFF = 6.0
FSAT = parameters%FSATMX*EXP(-0.5*FFF*(ZWT-2.0))
IF(QINSUR > 0.) THEN
RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) )
PDDUM = QINSUR - RUNSRF
END IF
END IF
IF(OPT_RUN == 5) THEN
FFF = 6.0
FSAT = parameters%FSATMX*EXP(-0.5*FFF*MAX(-2.0-ZWT,0.))
IF(QINSUR > 0.) THEN
RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) )
PDDUM = QINSUR - RUNSRF
END IF
END IF
IF(OPT_RUN == 2) THEN
FFF = 2.0
FSAT = parameters%FSATMX*EXP(-0.5*FFF*ZWT)
IF(QINSUR > 0.) THEN
RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) )
PDDUM = QINSUR - RUNSRF
END IF
END IF
IF(OPT_RUN == 3) THEN
CALL INFIL (parameters,NSOIL ,DT ,ZSOIL ,SH2O ,SICE , &
SICEMAX,QINSUR , &
PDDUM ,RUNSRF )
END IF
IF(OPT_RUN == 4) THEN
SMCTOT = 0.
DZTOT = 0.
DO K = 1,NSOIL
DZTOT = DZTOT + DZSNSO(K)
SMCTOT = SMCTOT + SMC(K)/parameters%SMCMAX(K)*DZSNSO(K)
IF(DZTOT >= 2.0) EXIT
END DO
SMCTOT = SMCTOT/DZTOT
FSAT = MAX(0.01,SMCTOT) ** 4.
IF(QINSUR > 0.) THEN
RUNSRF = QINSUR * ((1.0-FCR(1))*FSAT+FCR(1))
PDDUM = QINSUR - RUNSRF
END IF
END IF
NITER = 1
NITER = 3
IF (PDDUM*DT>DZSNSO(1)*parameters%SMCMAX(1) ) THEN
NITER = NITER*2
END IF
DTFINE = DT / NITER
QDRAIN_SAVE = 0.0
RUNSRF_SAVE = 0.0
DO ITER = 1, NITER
IF(QINSUR > 0. .and. OPT_RUN == 3) THEN
CALL INFIL (parameters,NSOIL ,DTFINE ,ZSOIL ,SH2O ,SICE , &
SICEMAX,QINSUR , &
PDDUM ,RUNSRF )
END IF
CALL SRT (parameters,NSOIL ,ZSOIL ,DTFINE ,PDDUM ,ETRANI , &
QSEVA ,SH2O ,SMC ,ZWT ,FCR , &
SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , &
RHSTT ,AI ,BI ,CI ,QDRAIN , &
WCND )
CALL SSTEP (parameters,NSOIL ,NSNOW ,DTFINE ,ZSOIL ,DZSNSO , &
SICE ,ILOC ,JLOC ,ZWT , &
SH2O ,SMC ,AI ,BI ,CI , &
RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, &
WPLUS)
RSAT = RSAT + WPLUS
QDRAIN_SAVE = QDRAIN_SAVE + QDRAIN
RUNSRF_SAVE = RUNSRF_SAVE + RUNSRF
END DO
QDRAIN = QDRAIN_SAVE/NITER
RUNSRF = RUNSRF_SAVE/NITER
RUNSRF = RUNSRF * 1000. + RSAT * 1000./DT
QDRAIN = QDRAIN * 1000.
IF(OPT_RUN == 2) THEN
WTSUB = 0.
DO K = 1, NSOIL
WTSUB = WTSUB + WCND(K)*DZSNSO(K)
END DO
DO K = 1, NSOIL
MH2O = RUNSUB*DT*(WCND(K)*DZSNSO(K))/WTSUB
SH2O(K) = SH2O(K) - MH2O/(DZSNSO(K)*1000.)
END DO
END IF
IF(OPT_RUN /= 1) THEN
DO IZ = 1, NSOIL
MLIQ(IZ) = SH2O(IZ)*DZSNSO(IZ)*1000.
END DO
WATMIN = 0.01
DO IZ = 1, NSOIL-1
IF (MLIQ(IZ) .LT. 0.) THEN
XS = WATMIN-MLIQ(IZ)
ELSE
XS = 0.
END IF
MLIQ(IZ ) = MLIQ(IZ ) + XS
MLIQ(IZ+1) = MLIQ(IZ+1) - XS
END DO
IZ = NSOIL
IF (MLIQ(IZ) .LT. WATMIN) THEN
XS = WATMIN-MLIQ(IZ)
ELSE
XS = 0.
END IF
MLIQ(IZ) = MLIQ(IZ) + XS
RUNSUB = RUNSUB - XS/DT
IF(OPT_RUN == 5)DEEPRECH = DEEPRECH - XS*1.E-3
DO IZ = 1, NSOIL
SH2O(IZ) = MLIQ(IZ) / (DZSNSO(IZ)*1000.)
END DO
END IF
END SUBROUTINE SOILWATER
SUBROUTINE ZWTEQ (parameters,NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NSNOW
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O
REAL, INTENT(OUT) :: ZWT
INTEGER :: K
INTEGER, PARAMETER :: NFINE = 100
REAL :: WD1
REAL :: WD2
REAL :: DZFINE
REAL :: TEMP
REAL, DIMENSION(1:NFINE) :: ZFINE
WD1 = 0.
DO K = 1,NSOIL
WD1 = WD1 + (parameters%SMCMAX(K)-SH2O(K)) * DZSNSO(K)
ENDDO
DZFINE = 3.0 * (-ZSOIL(NSOIL)) / NFINE
do K =1,NFINE
ZFINE(K) = FLOAT(K) * DZFINE
ENDDO
ZWT = -3.*ZSOIL(NSOIL) - 0.001
WD2 = 0.
DO K = 1,NFINE
TEMP = 1. + (ZWT-ZFINE(K))/parameters%PSISAT(K)
WD2 = WD2 + parameters%SMCMAX(K)*(1.-TEMP**(-1./parameters%BEXP(K)))*DZFINE
IF(ABS(WD2-WD1).LE.0.01) THEN
ZWT = ZFINE(K)
EXIT
ENDIF
ENDDO
END SUBROUTINE ZWTEQ
SUBROUTINE INFIL (parameters,NSOIL ,DT ,ZSOIL ,SH2O ,SICE , &
SICEMAX,QINSUR , &
PDDUM ,RUNSRF )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: NSOIL
REAL, INTENT(IN) :: DT
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE
REAL, INTENT(IN) :: QINSUR
REAL, INTENT(IN) :: SICEMAX
REAL, INTENT(OUT) :: RUNSRF
REAL, INTENT(OUT) :: PDDUM
INTEGER :: IALP1, J, JJ, K
REAL :: VAL
REAL :: DDT
REAL :: PX
REAL :: DT1, DD, DICE
REAL :: FCR
REAL :: SUM
REAL :: ACRT
REAL :: WDF
REAL :: WCND
REAL :: SMCAV
REAL :: INFMAX
REAL, DIMENSION(1:NSOIL) :: DMAX
INTEGER, PARAMETER :: CVFRZ = 3
IF (QINSUR > 0.0) THEN
DT1 = DT /86400.
SMCAV = parameters%SMCMAX(1) - parameters%SMCWLT(1)
DMAX(1)= -ZSOIL(1) * SMCAV
DICE = -ZSOIL(1) * SICE(1)
DMAX(1)= DMAX(1)* (1.0-(SH2O(1) + SICE(1) - parameters%SMCWLT(1))/SMCAV)
DD = DMAX(1)
DO K = 2,NSOIL
DICE = DICE + (ZSOIL(K-1) - ZSOIL(K) ) * SICE(K)
DMAX(K) = (ZSOIL(K-1) - ZSOIL(K)) * SMCAV
DMAX(K) = DMAX(K) * (1.0-(SH2O(K) + SICE(K) - parameters%SMCWLT(K))/SMCAV)
DD = DD + DMAX(K)
END DO
VAL = (1. - EXP ( - parameters%KDT * DT1))
DDT = DD * VAL
PX = MAX(0.,QINSUR * DT)
INFMAX = (PX * (DDT / (PX + DDT)))/ DT
FCR = 1.
IF (DICE > 1.E-2) THEN
ACRT = CVFRZ * parameters%FRZX / DICE
SUM = 1.
IALP1 = CVFRZ - 1
DO J = 1,IALP1
K = 1
DO JJ = J +1,IALP1
K = K * JJ
END DO
SUM = SUM + (ACRT ** (CVFRZ - J)) / FLOAT(K)
END DO
FCR = 1. - EXP (-ACRT) * SUM
END IF
INFMAX = INFMAX * FCR
CALL WDFCND2 (parameters,WDF,WCND,SH2O(1),SICEMAX,1)
INFMAX = MAX (INFMAX,WCND)
INFMAX = MIN (INFMAX,PX)
RUNSRF= MAX(0., QINSUR - INFMAX)
PDDUM = QINSUR - RUNSRF
END IF
END SUBROUTINE INFIL
SUBROUTINE SRT (parameters,NSOIL ,ZSOIL ,DT ,PDDUM ,ETRANI , &
QSEVA ,SH2O ,SMC ,ZWT ,FCR , &
SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , &
RHSTT ,AI ,BI ,CI ,QDRAIN , &
WCND )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSOIL
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: PDDUM
REAL, INTENT(IN) :: QSEVA
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ETRANI
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC
REAL, INTENT(IN) :: ZWT
REAL, DIMENSION(1:NSOIL), INTENT(IN) :: FCR
REAL, INTENT(IN) :: FCRMAX
REAL, INTENT(IN) :: SICEMAX
REAL, INTENT(IN) :: SMCWTD
REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT
REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI
REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: BI
REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: CI
REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND
REAL, INTENT(OUT) :: QDRAIN
INTEGER :: K
REAL, DIMENSION(1:NSOIL) :: DDZ
REAL, DIMENSION(1:NSOIL) :: DENOM
REAL, DIMENSION(1:NSOIL) :: DSMDZ
REAL, DIMENSION(1:NSOIL) :: WFLUX
REAL, DIMENSION(1:NSOIL) :: WDF
REAL, DIMENSION(1:NSOIL) :: SMX
REAL :: TEMP1
REAL :: SMXWTD
REAL :: SMXBOT
IF(OPT_INF == 1) THEN
DO K = 1, NSOIL
CALL WDFCND1 (parameters,WDF(K),WCND(K),SMC(K),FCR(K),K)
SMX(K) = SMC(K)
END DO
IF(OPT_RUN == 5)SMXWTD=SMCWTD
END IF
IF(OPT_INF == 2) THEN
DO K = 1, NSOIL
CALL WDFCND2 (parameters,WDF(K),WCND(K),SH2O(K),SICEMAX,K)
SMX(K) = SH2O(K)
END DO
IF(OPT_RUN == 5)SMXWTD=SMCWTD*SH2O(NSOIL)/SMC(NSOIL)
END IF
DO K = 1, NSOIL
IF(K == 1) THEN
DENOM(K) = - ZSOIL (K)
TEMP1 = - ZSOIL (K+1)
DDZ(K) = 2.0 / TEMP1
DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1
WFLUX(K) = WDF(K) * DSMDZ(K) + WCND(K) - PDDUM + ETRANI(K) + QSEVA
ELSE IF (K < NSOIL) THEN
DENOM(k) = (ZSOIL(K-1) - ZSOIL(K))
TEMP1 = (ZSOIL(K-1) - ZSOIL(K+1))
DDZ(K) = 2.0 / TEMP1
DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1
WFLUX(K) = WDF(K ) * DSMDZ(K ) + WCND(K ) &
- WDF(K-1) * DSMDZ(K-1) - WCND(K-1) + ETRANI(K)
ELSE
DENOM(K) = (ZSOIL(K-1) - ZSOIL(K))
IF(OPT_RUN == 1 .or. OPT_RUN == 2) THEN
QDRAIN = 0.
END IF
IF(OPT_RUN == 3) THEN
QDRAIN = parameters%SLOPE*WCND(K)
END IF
IF(OPT_RUN == 4) THEN
QDRAIN = (1.0-FCRMAX)*WCND(K)
END IF
IF(OPT_RUN == 5) THEN
TEMP1 = 2.0 * DENOM(K)
IF(ZWT < ZSOIL(NSOIL)-DENOM(NSOIL))THEN
SMXBOT = SMX(K) - (SMX(K)-SMXWTD) * DENOM(K) * 2./ (DENOM(K) + ZSOIL(K) - ZWT)
ELSE
SMXBOT = SMXWTD
ENDIF
DSMDZ(K) = 2.0 * (SMX(K) - SMXBOT) / TEMP1
QDRAIN = WDF(K ) * DSMDZ(K ) + WCND(K )
END IF
WFLUX(K) = -(WDF(K-1)*DSMDZ(K-1))-WCND(K-1)+ETRANI(K) + QDRAIN
END IF
END DO
DO K = 1, NSOIL
IF(K == 1) THEN
AI(K) = 0.0
BI(K) = WDF(K ) * DDZ(K ) / DENOM(K)
CI(K) = - BI (K)
ELSE IF (K < NSOIL) THEN
AI(K) = - WDF(K-1) * DDZ(K-1) / DENOM(K)
CI(K) = - WDF(K ) * DDZ(K ) / DENOM(K)
BI(K) = - ( AI (K) + CI (K) )
ELSE
AI(K) = - WDF(K-1) * DDZ(K-1) / DENOM(K)
CI(K) = 0.0
BI(K) = - ( AI (K) + CI (K) )
END IF
RHSTT(K) = WFLUX(K) / (-DENOM(K))
END DO
END SUBROUTINE SRT
SUBROUTINE SSTEP (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , &
SICE ,ILOC ,JLOC ,ZWT , &
SH2O ,SMC ,AI ,BI ,CI , &
RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, &
WPLUS )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: NSNOW
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: ZWT
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SICE
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O
REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC
REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI
REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: BI
REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: CI
REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT
REAL , INTENT(INOUT) :: SMCWTD
REAL , INTENT(INOUT) :: QDRAIN
REAL , INTENT(INOUT) :: DEEPRECH
REAL, INTENT(OUT) :: WPLUS
INTEGER :: K
REAL, DIMENSION(1:NSOIL) :: RHSTTIN
REAL, DIMENSION(1:NSOIL) :: CIIN
REAL :: STOT
REAL :: EPORE
REAL :: WMINUS
WPLUS = 0.0
DO K = 1,NSOIL
RHSTT (K) = RHSTT(K) * DT
AI (K) = AI(K) * DT
BI (K) = 1. + BI(K) * DT
CI (K) = CI(K) * DT
END DO
DO K = 1,NSOIL
RHSTTIN(k) = RHSTT(K)
CIIN(k) = CI(K)
END DO
CALL ROSR12 (CI,AI,BI,CIIN,RHSTTIN,RHSTT,1,NSOIL,0)
DO K = 1,NSOIL
SH2O(K) = SH2O(K) + CI(K)
ENDDO
IF(OPT_RUN == 5) THEN
IF(ZWT < ZSOIL(NSOIL)-DZSNSO(NSOIL))THEN
DEEPRECH = DEEPRECH + DT * QDRAIN
ELSE
SMCWTD = SMCWTD + DT * QDRAIN / DZSNSO(NSOIL)
WPLUS = MAX((SMCWTD-parameters%SMCMAX(NSOIL)), 0.0) * DZSNSO(NSOIL)
WMINUS = MAX((1.E-4-SMCWTD), 0.0) * DZSNSO(NSOIL)
SMCWTD = MAX( MIN(SMCWTD,parameters%SMCMAX(NSOIL)) , 1.E-4)
SH2O(NSOIL) = SH2O(NSOIL) + WPLUS/DZSNSO(NSOIL)
QDRAIN = QDRAIN - WPLUS/DT
DEEPRECH = DEEPRECH - WMINUS
ENDIF
ENDIF
DO K = NSOIL,2,-1
EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) )
WPLUS = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K)
SH2O(K) = MIN(EPORE,SH2O(K))
SH2O(K-1) = SH2O(K-1) + WPLUS/DZSNSO(K-1)
END DO
EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(1) - SICE(1) ) )
WPLUS = MAX((SH2O(1)-EPORE), 0.0) * DZSNSO(1)
SH2O(1) = MIN(EPORE,SH2O(1))
IF(WPLUS > 0.0) THEN
SH2O(2) = SH2O(2) + WPLUS/DZSNSO(2)
DO K = 2,NSOIL-1
EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) )
WPLUS = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K)
SH2O(K) = MIN(EPORE,SH2O(K))
SH2O(K+1) = SH2O(K+1) + WPLUS/DZSNSO(K+1)
END DO
EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(NSOIL) - SICE(NSOIL) ) )
WPLUS = MAX((SH2O(NSOIL)-EPORE), 0.0) * DZSNSO(NSOIL)
SH2O(NSOIL) = MIN(EPORE,SH2O(NSOIL))
END IF
SMC = SH2O + SICE
END SUBROUTINE SSTEP
SUBROUTINE WDFCND1 (parameters,WDF,WCND,SMC,FCR,ISOIL)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
REAL,INTENT(IN) :: SMC
REAL,INTENT(IN) :: FCR
INTEGER,INTENT(IN) :: ISOIL
REAL,INTENT(OUT) :: WCND
REAL,INTENT(OUT) :: WDF
REAL :: EXPON
REAL :: FACTR
REAL :: VKWGT
FACTR = MAX(0.01, SMC/parameters%SMCMAX(ISOIL))
EXPON = parameters%BEXP(ISOIL) + 2.0
WDF = parameters%DWSAT(ISOIL) * FACTR ** EXPON
WDF = WDF * (1.0 - FCR)
EXPON = 2.0*parameters%BEXP(ISOIL) + 3.0
WCND = parameters%DKSAT(ISOIL) * FACTR ** EXPON
WCND = WCND * (1.0 - FCR)
END SUBROUTINE WDFCND1
SUBROUTINE WDFCND2 (parameters,WDF,WCND,SMC,SICE,ISOIL)
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
REAL,INTENT(IN) :: SMC
REAL,INTENT(IN) :: SICE
INTEGER,INTENT(IN) :: ISOIL
REAL,INTENT(OUT) :: WCND
REAL,INTENT(OUT) :: WDF
REAL :: EXPON
REAL :: FACTR1,FACTR2
REAL :: VKWGT
FACTR1 = 0.05/parameters%SMCMAX(ISOIL)
FACTR2 = MAX(0.01, SMC/parameters%SMCMAX(ISOIL))
FACTR1 = MIN(FACTR1,FACTR2)
EXPON = parameters%BEXP(ISOIL) + 2.0
WDF = parameters%DWSAT(ISOIL) * FACTR2 ** EXPON
IF (SICE > 0.0) THEN
VKWGT = 1./ (1. + (500.* SICE)**3.)
WDF = VKWGT * WDF + (1.-VKWGT)*parameters%DWSAT(ISOIL)*(FACTR1)**EXPON
END IF
EXPON = 2.0*parameters%BEXP(ISOIL) + 3.0
WCND = parameters%DKSAT(ISOIL) * FACTR2 ** EXPON
END SUBROUTINE WDFCND2
SUBROUTINE GROUNDWATER(parameters,NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , &
STC ,WCND ,FCRMAX ,ILOC ,JLOC , &
SH2O ,ZWT ,WA ,WT , &
QIN ,QDIS )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: ILOC
INTEGER, INTENT(IN) :: JLOC
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
REAL, INTENT(IN) :: DT
REAL, INTENT(IN) :: FCRMAX
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SICE
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: WCND
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O
REAL, INTENT(INOUT) :: ZWT
REAL, INTENT(INOUT) :: WA
REAL, INTENT(INOUT) :: WT
REAL, INTENT(OUT) :: QIN
REAL, INTENT(OUT) :: QDIS
REAL :: FFF
REAL :: RSBMX
INTEGER :: IZ
INTEGER :: IWT
REAL, DIMENSION( 1:NSOIL) :: DZMM
REAL, DIMENSION( 1:NSOIL) :: ZNODE
REAL, DIMENSION( 1:NSOIL) :: MLIQ
REAL, DIMENSION( 1:NSOIL) :: EPORE
REAL, DIMENSION( 1:NSOIL) :: HK
REAL, DIMENSION( 1:NSOIL) :: SMC
REAL(KIND=8) :: S_NODE
REAL :: DZSUM
REAL :: SMPFZ
REAL :: KA
REAL :: WH_ZWT
REAL :: WH
REAL :: WS
REAL :: WTSUB
REAL :: WATMIN
REAL :: XS
REAL, PARAMETER :: ROUS = 0.2
REAL, PARAMETER :: CMIC = 0.20
QDIS = 0.0
QIN = 0.0
DZMM(1) = -ZSOIL(1)*1.E3
DO IZ = 2, NSOIL
DZMM(IZ) = 1.E3 * (ZSOIL(IZ - 1) - ZSOIL(IZ))
ENDDO
ZNODE(1) = -ZSOIL(1) / 2.
DO IZ = 2, NSOIL
ZNODE(IZ) = -ZSOIL(IZ-1) + 0.5 * (ZSOIL(IZ-1) - ZSOIL(IZ))
ENDDO
DO IZ = 1, NSOIL
SMC(IZ) = SH2O(IZ) + SICE(IZ)
MLIQ(IZ) = SH2O(IZ) * DZMM(IZ)
EPORE(IZ) = MAX(0.01,parameters%SMCMAX(IZ) - SICE(IZ))
HK(IZ) = 1.E3*WCND(IZ)
ENDDO
IWT = NSOIL
DO IZ = 2,NSOIL
IF(ZWT .LE. -ZSOIL(IZ) ) THEN
IWT = IZ-1
EXIT
END IF
ENDDO
FFF = 6.0
RSBMX = 5.0
QDIS = (1.0-FCRMAX)*RSBMX*EXP(-parameters%TIMEAN)*EXP(-FFF*(ZWT-2.0))
S_NODE = MIN(1.0,SMC(IWT)/parameters%SMCMAX(IWT) )
S_NODE = MAX(S_NODE,REAL(0.01,KIND=8))
SMPFZ = -parameters%PSISAT(IWT)*1000.*S_NODE**(-parameters%BEXP(IWT))
SMPFZ = MAX(-120000.0,CMIC*SMPFZ)
KA = HK(IWT)
WH_ZWT = - ZWT * 1.E3
WH = SMPFZ - ZNODE(IWT)*1.E3
QIN = - KA * (WH_ZWT-WH) /((ZWT-ZNODE(IWT))*1.E3)
QIN = MAX(-10.0/DT,MIN(10./DT,QIN))
WT = WT + (QIN - QDIS) * DT
IF(IWT.EQ.NSOIL) THEN
WA = WA + (QIN - QDIS) * DT
WT = WA
ZWT = (-ZSOIL(NSOIL) + 25.) - WA/1000./ROUS
MLIQ(NSOIL) = MLIQ(NSOIL) - QIN * DT
MLIQ(NSOIL) = MLIQ(NSOIL) + MAX(0.,(WA - 5000.))
WA = MIN(WA, 5000.)
ELSE
IF (IWT.EQ.NSOIL-1) THEN
ZWT = -ZSOIL(NSOIL) &
- (WT-ROUS*1000*25.) / (EPORE(NSOIL))/1000.
ELSE
WS = 0.
DO IZ = IWT+2,NSOIL
WS = WS + EPORE(IZ) * DZMM(IZ)
ENDDO
ZWT = -ZSOIL(IWT+1) &
- (WT-ROUS*1000.*25.-WS) /(EPORE(IWT+1))/1000.
ENDIF
WTSUB = 0.
DO IZ = 1, NSOIL
WTSUB = WTSUB + HK(IZ)*DZMM(IZ)
END DO
DO IZ = 1, NSOIL
MLIQ(IZ) = MLIQ(IZ) - QDIS*DT*HK(IZ)*DZMM(IZ)/WTSUB
END DO
END IF
ZWT = MAX(1.5,ZWT)
WATMIN = 0.01
DO IZ = 1, NSOIL-1
IF (MLIQ(IZ) .LT. 0.) THEN
XS = WATMIN-MLIQ(IZ)
ELSE
XS = 0.
END IF
MLIQ(IZ ) = MLIQ(IZ ) + XS
MLIQ(IZ+1) = MLIQ(IZ+1) - XS
END DO
IZ = NSOIL
IF (MLIQ(IZ) .LT. WATMIN) THEN
XS = WATMIN-MLIQ(IZ)
ELSE
XS = 0.
END IF
MLIQ(IZ) = MLIQ(IZ) + XS
WA = WA - XS
WT = WT - XS
DO IZ = 1, NSOIL
SH2O(IZ) = MLIQ(IZ) / DZMM(IZ)
END DO
END SUBROUTINE GROUNDWATER
SUBROUTINE SHALLOWWATERTABLE (parameters,NSNOW ,NSOIL ,ZSOIL, DT , &
DZSNSO ,SMCEQ ,ILOC ,JLOC , &
SMC ,WTD ,SMCWTD ,RECH, QDRAIN )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER, INTENT(IN) :: NSNOW
INTEGER, INTENT(IN) :: NSOIL
INTEGER, INTENT(IN) :: ILOC,JLOC
REAL, INTENT(IN) :: DT
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ
REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC
REAL, INTENT(INOUT) :: WTD
REAL, INTENT(INOUT) :: SMCWTD
REAL, INTENT(OUT) :: RECH
REAL, INTENT(INOUT) :: QDRAIN
INTEGER :: IZ
INTEGER :: IWTD
INTEGER :: KWTD
REAL :: WTDOLD
REAL :: DZUP
REAL :: SMCEQDEEP
REAL, DIMENSION( 0:NSOIL) :: ZSOIL0
ZSOIL0(1:NSOIL) = ZSOIL(1:NSOIL)
ZSOIL0(0) = 0.
DO IZ=NSOIL,1,-1
IF(WTD + 1.E-6 < ZSOIL0(IZ)) EXIT
ENDDO
IWTD=IZ
KWTD=IWTD+1
IF(KWTD.LE.NSOIL)THEN
WTDOLD=WTD
IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN
IF(SMC(KWTD).EQ.parameters%SMCMAX(KWTD))THEN
WTD=ZSOIL0(IWTD)
RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD))
IWTD=IWTD-1
KWTD=KWTD-1
IF(KWTD.GE.1)THEN
IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN
WTDOLD=WTD
WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) &
- SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / &
( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ), ZSOIL0(IWTD))
RECH=RECH-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD))
ENDIF
ENDIF
ELSE
WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) &
- SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / &
( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ), ZSOIL0(IWTD))
RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD))
ENDIF
ELSE
WTD=ZSOIL0(KWTD)
RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD))
KWTD=KWTD+1
IWTD=IWTD+1
IF(KWTD.LE.NSOIL)THEN
WTDOLD=WTD
IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN
WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) &
- SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / &
( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ) , ZSOIL0(IWTD) )
ELSE
WTD=ZSOIL0(KWTD)
ENDIF
RECH = RECH - (WTDOLD-WTD) * &
(parameters%SMCMAX(KWTD)-SMCEQ(KWTD))
ELSE
WTDOLD=WTD
SMCEQDEEP = parameters%SMCMAX(NSOIL) * ( -parameters%PSISAT(NSOIL) / ( -parameters%PSISAT(NSOIL) - DZSNSO(NSOIL) ) ) ** (1./parameters%BEXP(NSOIL))
WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) &
- SMCEQDEEP*ZSOIL0(NSOIL) + parameters%SMCMAX(NSOIL)*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / &
( parameters%SMCMAX(NSOIL)-SMCEQDEEP ) , ZSOIL0(NSOIL) )
RECH = RECH - (WTDOLD-WTD) * &
(parameters%SMCMAX(NSOIL)-SMCEQDEEP)
ENDIF
ENDIF
ELSEIF(WTD.GE.ZSOIL0(NSOIL)-DZSNSO(NSOIL))THEN
WTDOLD=WTD
SMCEQDEEP = parameters%SMCMAX(NSOIL) * ( -parameters%PSISAT(NSOIL) / ( -parameters%PSISAT(NSOIL) - DZSNSO(NSOIL) ) ) ** (1./parameters%BEXP(NSOIL))
IF(SMCWTD.GT.SMCEQDEEP)THEN
WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) &
- SMCEQDEEP*ZSOIL0(NSOIL) + parameters%SMCMAX(NSOIL)*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / &
( parameters%SMCMAX(NSOIL)-SMCEQDEEP ) , ZSOIL0(NSOIL) )
RECH = -(WTDOLD-WTD) * (parameters%SMCMAX(NSOIL)-SMCEQDEEP)
ELSE
RECH = -(WTDOLD-(ZSOIL0(NSOIL)-DZSNSO(NSOIL))) * (parameters%SMCMAX(NSOIL)-SMCEQDEEP)
WTDOLD=ZSOIL0(NSOIL)-DZSNSO(NSOIL)
DZUP=(SMCEQDEEP-SMCWTD)*DZSNSO(NSOIL)/(parameters%SMCMAX(NSOIL)-SMCEQDEEP)
WTD=WTDOLD-DZUP
RECH = RECH - (parameters%SMCMAX(NSOIL)-SMCEQDEEP)*DZUP
SMCWTD=SMCEQDEEP
ENDIF
ENDIF
IF(IWTD.LT.NSOIL .AND. IWTD.GT.0) THEN
SMCWTD=parameters%SMCMAX(IWTD)
ELSEIF(IWTD.LT.NSOIL .AND. IWTD.LE.0) THEN
SMCWTD=parameters%SMCMAX(1)
END IF
END SUBROUTINE SHALLOWWATERTABLE
SUBROUTINE CARBON (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , &
DZSNSO ,STC ,SMC ,TV ,TG ,PSN , &
FOLN ,BTRAN ,APAR ,FVEG ,IGS , &
TROOT ,IST ,LAT ,ILOC ,JLOC , &
LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , &
GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , &
TOTLB ,XLAI ,XSAI )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER , INTENT(IN) :: ILOC
INTEGER , INTENT(IN) :: JLOC
INTEGER , INTENT(IN) :: VEGTYP
INTEGER , INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: NSOIL
REAL , INTENT(IN) :: LAT
REAL , INTENT(IN) :: DT
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC
REAL , INTENT(IN) :: TV
REAL , INTENT(IN) :: TG
REAL , INTENT(IN) :: FOLN
REAL , INTENT(IN) :: BTRAN
REAL , INTENT(IN) :: PSN
REAL , INTENT(IN) :: APAR
REAL , INTENT(IN) :: IGS
REAL , INTENT(IN) :: FVEG
REAL , INTENT(IN) :: TROOT
INTEGER , INTENT(IN) :: IST
REAL , INTENT(INOUT) :: LFMASS
REAL , INTENT(INOUT) :: RTMASS
REAL , INTENT(INOUT) :: STMASS
REAL , INTENT(INOUT) :: WOOD
REAL , INTENT(INOUT) :: STBLCP
REAL , INTENT(INOUT) :: FASTCP
REAL , INTENT(OUT) :: GPP
REAL , INTENT(OUT) :: NPP
REAL , INTENT(OUT) :: NEE
REAL , INTENT(OUT) :: AUTORS
REAL , INTENT(OUT) :: HETERS
REAL , INTENT(OUT) :: TOTSC
REAL , INTENT(OUT) :: TOTLB
REAL , INTENT(OUT) :: XLAI
REAL , INTENT(OUT) :: XSAI
INTEGER :: J
REAL :: WROOT
REAL :: WSTRES
REAL :: LAPM
IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. &
( VEGTYP == parameters%ISICE ) .or. (parameters%urban_flag) ) THEN
XLAI = 0.
XSAI = 0.
GPP = 0.
NPP = 0.
NEE = 0.
AUTORS = 0.
HETERS = 0.
TOTSC = 0.
TOTLB = 0.
LFMASS = 0.
RTMASS = 0.
STMASS = 0.
WOOD = 0.
STBLCP = 0.
FASTCP = 0.
RETURN
END IF
LAPM = parameters%SLA / 1000.
WSTRES = 1.- BTRAN
WROOT = 0.
DO J=1,parameters%NROOT
WROOT = WROOT + SMC(J)/parameters%SMCMAX(J) * DZSNSO(J) / (-ZSOIL(parameters%NROOT))
ENDDO
CALL CO2FLUX (parameters,NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , &
DZSNSO ,STC ,PSN ,TROOT ,TV , &
WROOT ,WSTRES ,FOLN ,LAPM , &
LAT ,ILOC ,JLOC ,FVEG , &
XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , &
FASTCP ,STBLCP ,WOOD , &
GPP ,NPP ,NEE ,AUTORS ,HETERS , &
TOTSC ,TOTLB )
END SUBROUTINE CARBON
SUBROUTINE CO2FLUX (parameters,NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , &
DZSNSO ,STC ,PSN ,TROOT ,TV , &
WROOT ,WSTRES ,FOLN ,LAPM , &
LAT ,ILOC ,JLOC ,FVEG , &
XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , &
FASTCP ,STBLCP ,WOOD , &
GPP ,NPP ,NEE ,AUTORS ,HETERS , &
TOTSC ,TOTLB )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER , INTENT(IN) :: ILOC
INTEGER , INTENT(IN) :: JLOC
INTEGER , INTENT(IN) :: VEGTYP
INTEGER , INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: NSOIL
REAL , INTENT(IN) :: DT
REAL , INTENT(IN) :: LAT
REAL , INTENT(IN) :: IGS
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL , INTENT(IN) :: PSN
REAL , INTENT(IN) :: TROOT
REAL , INTENT(IN) :: TV
REAL , INTENT(IN) :: WROOT
REAL , INTENT(IN) :: WSTRES
REAL , INTENT(IN) :: FOLN
REAL , INTENT(IN) :: LAPM
REAL , INTENT(IN) :: FVEG
REAL , INTENT(INOUT) :: XLAI
REAL , INTENT(INOUT) :: XSAI
REAL , INTENT(INOUT) :: LFMASS
REAL , INTENT(INOUT) :: RTMASS
REAL , INTENT(INOUT) :: STMASS
REAL , INTENT(INOUT) :: FASTCP
REAL , INTENT(INOUT) :: STBLCP
REAL , INTENT(INOUT) :: WOOD
REAL , INTENT(OUT) :: GPP
REAL , INTENT(OUT) :: NPP
REAL , INTENT(OUT) :: NEE
REAL , INTENT(OUT) :: AUTORS
REAL , INTENT(OUT) :: HETERS
REAL , INTENT(OUT) :: TOTSC
REAL , INTENT(OUT) :: TOTLB
REAL :: CFLUX
REAL :: LFMSMN
REAL :: RSWOOD
REAL :: RSLEAF
REAL :: RSROOT
REAL :: NPPL
REAL :: NPPR
REAL :: NPPW
REAL :: NPPS
REAL :: DIELF
REAL :: ADDNPPLF
REAL :: ADDNPPST
REAL :: CARBFX
REAL :: GRLEAF
REAL :: GRROOT
REAL :: GRWOOD
REAL :: GRSTEM
REAL :: LEAFPT
REAL :: LFDEL
REAL :: LFTOVR
REAL :: STTOVR
REAL :: WDTOVR
REAL :: RSSOIL
REAL :: RTTOVR
REAL :: STABLC
REAL :: WOODF
REAL :: NONLEF
REAL :: ROOTPT
REAL :: WOODPT
REAL :: STEMPT
REAL :: RESP
REAL :: RSSTEM
REAL :: FSW
REAL :: FST
REAL :: FNF
REAL :: TF
REAL :: RF
REAL :: STDEL
REAL :: STMSMN
REAL :: SAPM
REAL :: DIEST
REAL :: BF
REAL :: RSWOODC
REAL :: STOVRC
REAL :: RSDRYC
REAL :: RTOVRC
REAL :: WSTRC
REAL :: LAIMIN
REAL :: XSAMIN
REAL :: SC
REAL :: SD
REAL :: VEGFRAC
real :: r,x
r(x) = exp(0.08*(x-298.16))
RTOVRC = 2.0E-8
RSDRYC = 40.0
RSWOODC = 3.0E-10
BF = 0.90
WSTRC = 100.0
LAIMIN = 0.05
XSAMIN = 0.05
SAPM = 3.*0.001
LFMSMN = laimin/lapm
STMSMN = xsamin/sapm
IF(IGS .EQ. 0.) THEN
RF = 0.5
ELSE
RF = 1.0
ENDIF
FNF = MIN( FOLN/MAX(1.E-06,parameters%FOLNMX), 1.0 )
TF = parameters%ARM**( (TV-298.16)/10. )
RESP = parameters%RMF25 * TF * FNF * XLAI * RF * (1.-WSTRES)
RSLEAF = MIN((LFMASS-LFMSMN)/DT,RESP*12.e-6)
RSROOT = parameters%RMR25*(RTMASS*1E-3)*TF *RF* 12.e-6
RSSTEM = parameters%RMS25*((STMASS-STMSMN)*1E-3)*TF *RF* 12.e-6
RSWOOD = RSWOODC * R(TV) * WOOD*parameters%WDPOOL
CARBFX = PSN * 12.e-6
LEAFPT = EXP(0.01*(1.-EXP(0.75*XLAI))*XLAI)
IF(VEGTYP == parameters%EBLFOREST) LEAFPT = EXP(0.01*(1.-EXP(0.50*XLAI))*XLAI)
NONLEF = 1.0 - LEAFPT
STEMPT = XLAI/10.0*LEAFPT
LEAFPT = LEAFPT - STEMPT
IF(WOOD > 1.e-6) THEN
WOODF = (1.-EXP(-BF*(parameters%WRRAT*RTMASS/WOOD))/BF)*parameters%WDPOOL
ELSE
WOODF = parameters%WDPOOL
ENDIF
ROOTPT = NONLEF*(1.-WOODF)
WOODPT = NONLEF*WOODF
LFTOVR = parameters%LTOVRC*5.E-7*LFMASS
STTOVR = parameters%LTOVRC*5.E-7*STMASS
RTTOVR = RTOVRC*RTMASS
WDTOVR = 9.5E-10*WOOD
SC = EXP(-0.3*MAX(0.,TV-parameters%TDLEF)) * (LFMASS/120.)
SD = EXP((WSTRES-1.)*WSTRC)
DIELF = LFMASS*1.E-6*(parameters%DILEFW * SD + parameters%DILEFC*SC)
DIEST = STMASS*1.E-6*(parameters%DILEFW * SD + parameters%DILEFC*SC)
GRLEAF = MAX(0.0,parameters%FRAGR*(LEAFPT*CARBFX - RSLEAF))
GRSTEM = MAX(0.0,parameters%FRAGR*(STEMPT*CARBFX - RSSTEM))
GRROOT = MAX(0.0,parameters%FRAGR*(ROOTPT*CARBFX - RSROOT))
GRWOOD = MAX(0.0,parameters%FRAGR*(WOODPT*CARBFX - RSWOOD))
ADDNPPLF = MAX(0.,LEAFPT*CARBFX - GRLEAF-RSLEAF)
ADDNPPST = MAX(0.,STEMPT*CARBFX - GRSTEM-RSSTEM)
IF(TV.LT.parameters%TMIN) ADDNPPLF =0.
IF(TV.LT.parameters%TMIN) ADDNPPST =0.
LFDEL = (LFMASS - LFMSMN)/DT
STDEL = (STMASS - STMSMN)/DT
DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR)
DIEST = MIN(DIEST,STDEL+ADDNPPST-STTOVR)
NPPL = MAX(ADDNPPLF,-LFDEL)
NPPS = MAX(ADDNPPST,-STDEL)
NPPR = ROOTPT*CARBFX - RSROOT - GRROOT
NPPW = WOODPT*CARBFX - RSWOOD - GRWOOD
LFMASS = LFMASS + (NPPL-LFTOVR-DIELF)*DT
STMASS = STMASS + (NPPS-STTOVR-DIEST)*DT
RTMASS = RTMASS + (NPPR-RTTOVR) *DT
IF(RTMASS.LT.0.0) THEN
RTTOVR = NPPR
RTMASS = 0.0
ENDIF
WOOD = (WOOD+(NPPW-WDTOVR)*DT)*parameters%WDPOOL
FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+WDTOVR+DIELF+DIEST)*DT
FST = 2.0**( (STC(1)-283.16)/10. )
FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT)
RSSOIL = FSW * FST * parameters%MRP* MAX(0.,FASTCP*1.E-3)*12.E-6
STABLC = 0.1*RSSOIL
FASTCP = FASTCP - (RSSOIL + STABLC)*DT
STBLCP = STBLCP + STABLC*DT
CFLUX = - CARBFX + RSLEAF + RSROOT + RSWOOD + RSSTEM &
+ 0.9*RSSOIL + GRLEAF + GRROOT + GRWOOD + GRSTEM
GPP = CARBFX
NPP = NPPL + NPPW + NPPR +NPPS
AUTORS = RSROOT + RSWOOD + RSLEAF + RSSTEM + &
GRLEAF + GRROOT + GRWOOD + GRSTEM
HETERS = 0.9*RSSOIL
NEE = (AUTORS + HETERS - GPP)*44./12.
TOTSC = FASTCP + STBLCP
TOTLB = LFMASS + RTMASS +STMASS + WOOD
XLAI = MAX(LFMASS*LAPM,LAIMIN)
XSAI = MAX(STMASS*SAPM,XSAMIN)
END SUBROUTINE CO2FLUX
SUBROUTINE CARBON_CROP (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL ,JULIAN , &
DZSNSO ,STC ,SMC ,TV ,PSN ,FOLN ,BTRAN , &
SOLDN ,T2M , &
LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP ,GRAIN , &
XLAI ,XSAI ,GDD , &
GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC ,TOTLB, PGS )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
INTEGER , INTENT(IN) :: NSNOW
INTEGER , INTENT(IN) :: NSOIL
INTEGER , INTENT(IN) :: VEGTYP
REAL , INTENT(IN) :: DT
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL
REAL , INTENT(IN) :: JULIAN
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO
REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC
REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC
REAL , INTENT(IN) :: TV
REAL , INTENT(IN) :: PSN
REAL , INTENT(IN) :: FOLN
REAL , INTENT(IN) :: BTRAN
REAL , INTENT(IN) :: SOLDN
REAL , INTENT(IN) :: T2M
REAL , INTENT(INOUT) :: LFMASS
REAL , INTENT(INOUT) :: RTMASS
REAL , INTENT(INOUT) :: STMASS
REAL , INTENT(INOUT) :: WOOD
REAL , INTENT(INOUT) :: STBLCP
REAL , INTENT(INOUT) :: FASTCP
REAL , INTENT(INOUT) :: GRAIN
REAL , INTENT(INOUT) :: XLAI
REAL , INTENT(INOUT) :: XSAI
REAL , INTENT(INOUT) :: GDD
REAL , INTENT(OUT) :: GPP
REAL , INTENT(OUT) :: NPP
REAL , INTENT(OUT) :: NEE
REAL , INTENT(OUT) :: AUTORS
REAL , INTENT(OUT) :: HETERS
REAL , INTENT(OUT) :: TOTSC
REAL , INTENT(OUT) :: TOTLB
INTEGER :: J
REAL :: WROOT
REAL :: WSTRES
INTEGER :: IPA
INTEGER :: IHA
INTEGER, INTENT(OUT) :: PGS
REAL :: PSNCROP
IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. &
( VEGTYP == parameters%ISICE ) .or. (parameters%urban_flag) ) THEN
XLAI = 0.
XSAI = 0.
GPP = 0.
NPP = 0.
NEE = 0.
AUTORS = 0.
HETERS = 0.
TOTSC = 0.
TOTLB = 0.
LFMASS = 0.
RTMASS = 0.
STMASS = 0.
WOOD = 0.
STBLCP = 0.
FASTCP = 0.
GRAIN = 0.
RETURN
END IF
WSTRES = 1.- BTRAN
WROOT = 0.
DO J=1,parameters%NROOT
WROOT = WROOT + SMC(J)/parameters%SMCMAX(J) * DZSNSO(J) / (-ZSOIL(parameters%NROOT))
ENDDO
CALL PSN_CROP ( parameters, &
SOLDN, XLAI, T2M, &
PSNCROP )
CALL GROWING_GDD (parameters, &
T2M , DT, JULIAN, &
GDD , &
IPA , IHA, PGS)
CALL CO2FLUX_CROP (parameters, &
DT ,STC(1) ,PSN ,TV ,WROOT ,WSTRES ,FOLN , &
IPA ,IHA ,PGS , &
XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , &
FASTCP ,STBLCP ,WOOD ,GRAIN ,GDD , &
GPP ,NPP ,NEE ,AUTORS ,HETERS , &
TOTSC ,TOTLB )
END SUBROUTINE CARBON_CROP
SUBROUTINE CO2FLUX_CROP (parameters, &
DT ,STC ,PSN ,TV ,WROOT ,WSTRES ,FOLN , &
IPA ,IHA ,PGS , &
XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , &
FASTCP ,STBLCP ,WOOD ,GRAIN ,GDD, &
GPP ,NPP ,NEE ,AUTORS ,HETERS , &
TOTSC ,TOTLB )
IMPLICIT NONE
type (noahmp_parameters), intent(in) :: parameters
REAL , INTENT(IN) :: DT
REAL , INTENT(IN) :: STC
REAL , INTENT(IN) :: PSN
REAL , INTENT(IN) :: TV
REAL , INTENT(IN) :: WROOT
REAL , INTENT(IN) :: WSTRES
REAL , INTENT(IN) :: FOLN
INTEGER , INTENT(IN) :: IPA
INTEGER , INTENT(IN) :: IHA
INTEGER , INTENT(IN) :: PGS
REAL , INTENT(INOUT) :: XLAI
REAL , INTENT(INOUT) :: XSAI
REAL , INTENT(INOUT) :: LFMASS
REAL , INTENT(INOUT) :: RTMASS
REAL , INTENT(INOUT) :: STMASS
REAL , INTENT(INOUT) :: FASTCP
REAL , INTENT(INOUT) :: STBLCP
REAL , INTENT(INOUT) :: WOOD
REAL , INTENT(INOUT) :: GRAIN
REAL , INTENT(INOUT) :: GDD
REAL , INTENT(OUT) :: GPP
REAL , INTENT(OUT) :: NPP
REAL , INTENT(OUT) :: NEE
REAL , INTENT(OUT) :: AUTORS
REAL , INTENT(OUT) :: HETERS
REAL , INTENT(OUT) :: TOTSC
REAL , INTENT(OUT) :: TOTLB
REAL :: CFLUX
REAL :: LFMSMN
REAL :: RSWOOD
REAL :: RSLEAF
REAL :: RSROOT
REAL :: RSGRAIN
REAL :: NPPL
REAL :: NPPR
REAL :: NPPW
REAL :: NPPS
REAL :: NPPG
REAL :: DIELF
REAL :: ADDNPPLF
REAL :: ADDNPPST
REAL :: CARBFX
REAL :: CBHYDRAFX
REAL :: GRLEAF
REAL :: GRROOT
REAL :: GRWOOD
REAL :: GRSTEM
REAL :: GRGRAIN
REAL :: LEAFPT
REAL :: LFDEL
REAL :: LFTOVR
REAL :: STTOVR
REAL :: WDTOVR
REAL :: GRTOVR
REAL :: RSSOIL
REAL :: RTTOVR
REAL :: STABLC
REAL :: WOODF
REAL :: NONLEF
REAL :: RESP
REAL :: RSSTEM
REAL :: FSW
REAL :: FST
REAL :: FNF
REAL :: TF
REAL :: STDEL
REAL :: STMSMN
REAL :: SAPM
REAL :: DIEST
REAL :: STCONVERT
REAL :: RTCONVERT
REAL :: BF
REAL :: RSWOODC
REAL :: STOVRC
REAL :: RSDRYC
REAL :: RTOVRC
REAL :: WSTRC
REAL :: LAIMIN
REAL :: XSAMIN
REAL :: SC
REAL :: SD
REAL :: VEGFRAC
REAL :: TEMP
real :: r,x
r(x) = exp(0.08*(x-298.16))
RSDRYC = 40.0
RSWOODC = 3.0E-10
BF = 0.90
WSTRC = 100.0
LAIMIN = 0.05
XSAMIN = 0.05
SAPM = 3.*0.001
LFMSMN = laimin/0.035
STMSMN = xsamin/sapm
CARBFX = PSN*12.e-6
CBHYDRAFX = PSN*30.e-6
FNF = MIN( FOLN/MAX(1.E-06,parameters%FOLN_MX), 1.0 )
TF = parameters%Q10MR**( (TV-298.16)/10. )
RESP = parameters%LFMR25 * TF * FNF * XLAI * (1.-WSTRES)
RSLEAF = MIN((LFMASS-LFMSMN)/DT,RESP*30.e-6)
RSROOT = parameters%RTMR25*(RTMASS*1E-3)*TF * 30.e-6
RSSTEM = parameters%STMR25*(STMASS*1E-3)*TF * 30.e-6
RSGRAIN = parameters%GRAINMR25*(GRAIN*1E-3)*TF * 30.e-6
GRLEAF = MAX(0.0,parameters%FRA_GR*(parameters%LFPT(PGS)*CBHYDRAFX - RSLEAF))
GRSTEM = MAX(0.0,parameters%FRA_GR*(parameters%STPT(PGS)*CBHYDRAFX - RSSTEM))
GRROOT = MAX(0.0,parameters%FRA_GR*(parameters%RTPT(PGS)*CBHYDRAFX - RSROOT))
GRGRAIN = MAX(0.0,parameters%FRA_GR*(parameters%GRAINPT(PGS)*CBHYDRAFX - RSGRAIN))
LFTOVR = parameters%LF_OVRC(PGS)*1.E-6*LFMASS
RTTOVR = parameters%RT_OVRC(PGS)*1.E-6*RTMASS
STTOVR = parameters%ST_OVRC(PGS)*1.E-6*STMASS
SC = EXP(-0.3*MAX(0.,TV-parameters%LEFREEZ)) * (LFMASS/120.)
SD = EXP((WSTRES-1.)*WSTRC)
DIELF = LFMASS*1.E-6*(parameters%DILE_FW(PGS) * SD + parameters%DILE_FC(PGS)*SC)
ADDNPPLF = MAX(0.,parameters%LFPT(PGS)*CBHYDRAFX - GRLEAF-RSLEAF)
ADDNPPLF = parameters%LFPT(PGS)*CBHYDRAFX - GRLEAF-RSLEAF
ADDNPPST = MAX(0.,parameters%STPT(PGS)*CBHYDRAFX - GRSTEM-RSSTEM)
ADDNPPST = parameters%STPT(PGS)*CBHYDRAFX - GRSTEM-RSSTEM
LFDEL = (LFMASS - LFMSMN)/DT
STDEL = (STMASS - STMSMN)/DT
LFTOVR = MIN(LFTOVR,LFDEL+ADDNPPLF)
STTOVR = MIN(STTOVR,STDEL+ADDNPPST)
DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR)
NPPL = MAX(ADDNPPLF,-LFDEL)
NPPL = ADDNPPLF
NPPS = MAX(ADDNPPST,-STDEL)
NPPS = ADDNPPST
NPPR = parameters%RTPT(PGS)*CBHYDRAFX - RSROOT - GRROOT
NPPG = parameters%GRAINPT(PGS)*CBHYDRAFX - RSGRAIN - GRGRAIN
LFMASS = LFMASS + (NPPL-LFTOVR-DIELF)*DT
STMASS = STMASS + (NPPS-STTOVR)*DT
RTMASS = RTMASS + (NPPR-RTTOVR)*DT
GRAIN = GRAIN + NPPG*DT
GPP = CBHYDRAFX* 0.4
STCONVERT = 0.0
RTCONVERT = 0.0
IF(PGS==6) THEN
STCONVERT = STMASS*(0.00005*DT/3600.0)
STMASS = STMASS - STCONVERT
RTCONVERT = RTMASS*(0.0005*DT/3600.0)
RTMASS = RTMASS - RTCONVERT
GRAIN = GRAIN + STCONVERT + RTCONVERT
END IF
IF(RTMASS.LT.0.0) THEN
RTTOVR = NPPR
RTMASS = 0.0
ENDIF
IF(GRAIN.LT.0.0) THEN
GRAIN = 0.0
ENDIF
FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+DIELF)*DT
FST = 2.0**( (STC-283.16)/10. )
FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT)
RSSOIL = FSW * FST * parameters%MRP* MAX(0.,FASTCP*1.E-3)*12.E-6
STABLC = 0.1*RSSOIL
FASTCP = FASTCP - (RSSOIL + STABLC)*DT
STBLCP = STBLCP + STABLC*DT
CFLUX = - CARBFX + RSLEAF + RSROOT + RSSTEM &
+ RSSOIL + GRLEAF + GRROOT
NPP = (NPPL + NPPS+ NPPR +NPPG)*0.4
AUTORS = RSROOT + RSGRAIN + RSLEAF + &
GRLEAF + GRROOT + GRGRAIN
HETERS = RSSOIL
NEE = (AUTORS + HETERS - GPP)*44./30.
TOTSC = FASTCP + STBLCP
TOTLB = LFMASS + RTMASS + GRAIN
XLAI = MAX(LFMASS*parameters%BIO2LAI,LAIMIN)
XSAI = MAX(STMASS*SAPM,XSAMIN)
IF(PGS == 8 .and. (GRAIN > 0. .or. LFMASS > 0 .or. STMASS > 0 .or. RTMASS > 0)) THEN
XLAI = 0.05
XSAI = 0.05
LFMASS = LFMSMN
STMASS = STMSMN
RTMASS = 0
GRAIN = 0
END IF
END SUBROUTINE CO2FLUX_CROP
SUBROUTINE GROWING_GDD (parameters, &
T2M , DT, JULIAN, &
GDD , &
IPA, IHA, PGS)
type (noahmp_parameters), intent(in) :: parameters
REAL , INTENT(IN) :: T2M
REAL , INTENT(IN) :: DT
REAL , INTENT(IN) :: JULIAN
REAL , INTENT(INOUT) :: GDD
INTEGER , INTENT(OUT) :: IPA
INTEGER , INTENT(OUT) :: IHA
INTEGER , INTENT(OUT) :: PGS
REAL :: GDDDAY
REAL :: DAYOFS2
REAL :: TDIFF
REAL :: TC
TC = T2M - 273.15
IPA = 1
IHA = 1
IF(JULIAN < parameters%PLTDAY) IPA = 0
IF(JULIAN >= parameters%HSDAY) IHA = 0
IF(TC < parameters%GDDTBASE) THEN
TDIFF = 0.0
ELSEIF(TC >= parameters%GDDTCUT) THEN
TDIFF = parameters%GDDTCUT - parameters%GDDTBASE
ELSE
TDIFF = TC - parameters%GDDTBASE
END IF
GDD = (GDD + TDIFF) * IPA * IHA
GDDDAY = GDD / (86400.0 / DT)
PGS = 1
IF(GDDDAY > 0.0) PGS = 2
IF(GDDDAY >= parameters%GDDS1) PGS = 3
IF(GDDDAY >= parameters%GDDS2) PGS = 4
IF(GDDDAY >= parameters%GDDS3) PGS = 5
IF(GDDDAY >= parameters%GDDS4) PGS = 6
IF(GDDDAY >= parameters%GDDS5) PGS = 7
IF(JULIAN >= parameters%HSDAY) PGS = 8
IF(JULIAN < parameters%PLTDAY) PGS = 1
END SUBROUTINE GROWING_GDD
SUBROUTINE PSN_CROP ( parameters, &
SOLDN, XLAI,T2M, &
PSNCROP )
type (noahmp_parameters), intent(in) :: parameters
REAL , INTENT(IN) :: SOLDN
REAL , INTENT(IN) :: XLAI
REAL , INTENT(IN) :: T2M
REAL , INTENT(OUT) :: PSNCROP
REAL :: PAR
REAL :: Amax
REAL :: L1
REAL :: L2
REAL :: L3
REAL :: I1
REAL :: I2
REAL :: I3
REAL :: A1
REAL :: A2
REAL :: A3
REAL :: A
REAL :: TC
TC = T2M - 273.15
PAR = parameters%I2PAR * SOLDN * 0.0036
IF(TC < parameters%TASSIM0) THEN
Amax = 1E-10
ELSEIF(TC >= parameters%TASSIM0 .and. TC < parameters%TASSIM1) THEN
Amax = (TC - parameters%TASSIM0) * parameters%Aref / (parameters%TASSIM1 - parameters%TASSIM0)
ELSEIF(TC >= parameters%TASSIM1 .and. TC < parameters%TASSIM2) THEN
Amax = parameters%Aref
ELSE
Amax= parameters%Aref - 0.2 * (T2M - parameters%TASSIM2)
ENDIF
Amax = max(amax,0.01)
IF(XLAI <= 0.05) THEN
L1 = 0.1127 * 0.05
L2 = 0.5 * 0.05
L3 = 0.8873 * 0.05
ELSE
L1 = 0.1127 * XLAI
L2 = 0.5 * XLAI
L3 = 0.8873 * XLAI
END IF
I1 = parameters%k * PAR * exp(-parameters%k * L1)
I2 = parameters%k * PAR * exp(-parameters%k * L2)
I3 = parameters%k * PAR * exp(-parameters%k * L3)
I1 = max(I1,1E-10)
I2 = max(I2,1E-10)
I3 = max(I3,1E-10)
A1 = Amax * (1 - exp(-parameters%epsi * I1 / Amax))
A2 = Amax * (1 - exp(-parameters%epsi * I2 / Amax)) * 1.6
A3 = Amax * (1 - exp(-parameters%epsi * I3 / Amax))
IF (XLAI <= 0.05) THEN
A = (A1+A2+A3) / 3.6 * 0.05
ELSEIF (XLAI > 0.05 .and. XLAI <= 4.0) THEN
A = (A1+A2+A3) / 3.6 * XLAI
ELSE
A = (A1+A2+A3) / 3.6 * 4
END IF
A = A * parameters%PSNRF
PSNCROP = 6.313 * A
END SUBROUTINE PSN_CROP
subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , &
iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, &
iopt_rsf )
implicit none
INTEGER, INTENT(IN) :: idveg
INTEGER, INTENT(IN) :: iopt_crs
INTEGER, INTENT(IN) :: iopt_btr
INTEGER, INTENT(IN) :: iopt_run
INTEGER, INTENT(IN) :: iopt_sfc
INTEGER, INTENT(IN) :: iopt_frz
INTEGER, INTENT(IN) :: iopt_inf
INTEGER, INTENT(IN) :: iopt_rad
INTEGER, INTENT(IN) :: iopt_alb
INTEGER, INTENT(IN) :: iopt_snf
INTEGER, INTENT(IN) :: iopt_tbot
INTEGER, INTENT(IN) :: iopt_stc
INTEGER, INTENT(IN) :: iopt_rsf
dveg = idveg
opt_crs = iopt_crs
opt_btr = iopt_btr
opt_run = iopt_run
opt_sfc = iopt_sfc
opt_frz = iopt_frz
opt_inf = iopt_inf
opt_rad = iopt_rad
opt_alb = iopt_alb
opt_snf = iopt_snf
opt_tbot = iopt_tbot
opt_stc = iopt_stc
opt_rsf = iopt_rsf
end subroutine noahmp_options
END MODULE MODULE_SF_NOAHMPLSM
MODULE NOAHMP_TABLES
IMPLICIT NONE
INTEGER, PRIVATE, PARAMETER :: MVT = 27
INTEGER, PRIVATE, PARAMETER :: MBAND = 2
INTEGER, PRIVATE, PARAMETER :: MSC = 8
INTEGER, PRIVATE, PARAMETER :: MAX_SOILTYP = 30
INTEGER, PRIVATE, PARAMETER :: NCROP = 5
INTEGER, PRIVATE, PARAMETER :: NSTAGE = 8
INTEGER :: ISURBAN_TABLE
INTEGER :: ISWATER_TABLE
INTEGER :: ISBARREN_TABLE
INTEGER :: ISICE_TABLE
INTEGER :: ISCROP_TABLE
INTEGER :: EBLFOREST_TABLE
INTEGER :: NATURAL_TABLE
INTEGER :: LOW_DENSITY_RESIDENTIAL_TABLE
INTEGER :: HIGH_DENSITY_RESIDENTIAL_TABLE
INTEGER :: HIGH_INTENSITY_INDUSTRIAL_TABLE
REAL :: CH2OP_TABLE(MVT)
REAL :: DLEAF_TABLE(MVT)
REAL :: Z0MVT_TABLE(MVT)
REAL :: HVT_TABLE(MVT)
REAL :: HVB_TABLE(MVT)
REAL :: DEN_TABLE(MVT)
REAL :: RC_TABLE(MVT)
REAL :: MFSNO_TABLE(MVT)
REAL :: SAIM_TABLE(MVT,12)
REAL :: LAIM_TABLE(MVT,12)
REAL :: SLA_TABLE(MVT)
REAL :: DILEFC_TABLE(MVT)
REAL :: DILEFW_TABLE(MVT)
REAL :: FRAGR_TABLE(MVT)
REAL :: LTOVRC_TABLE(MVT)
REAL :: C3PSN_TABLE(MVT)
REAL :: KC25_TABLE(MVT)
REAL :: AKC_TABLE(MVT)
REAL :: KO25_TABLE(MVT)
REAL :: AKO_TABLE(MVT)
REAL :: VCMX25_TABLE(MVT)
REAL :: AVCMX_TABLE(MVT)
REAL :: BP_TABLE(MVT)
REAL :: MP_TABLE(MVT)
REAL :: QE25_TABLE(MVT)
REAL :: AQE_TABLE(MVT)
REAL :: RMF25_TABLE(MVT)
REAL :: RMS25_TABLE(MVT)
REAL :: RMR25_TABLE(MVT)
REAL :: ARM_TABLE(MVT)
REAL :: FOLNMX_TABLE(MVT)
REAL :: TMIN_TABLE(MVT)
REAL :: XL_TABLE(MVT)
REAL :: RHOL_TABLE(MVT,MBAND)
REAL :: RHOS_TABLE(MVT,MBAND)
REAL :: TAUL_TABLE(MVT,MBAND)
REAL :: TAUS_TABLE(MVT,MBAND)
REAL :: MRP_TABLE(MVT)
REAL :: CWPVT_TABLE(MVT)
REAL :: WRRAT_TABLE(MVT)
REAL :: WDPOOL_TABLE(MVT)
REAL :: TDLEF_TABLE(MVT)
REAL :: NROOT_TABLE(MVT)
REAL :: RGL_TABLE(MVT)
REAL :: RS_TABLE(MVT)
REAL :: HS_TABLE(MVT)
REAL :: TOPT_TABLE(MVT)
REAL :: RSMAX_TABLE(MVT)
INTEGER :: SLCATS
REAL :: BEXP_TABLE(MAX_SOILTYP)
REAL :: SMCDRY_TABLE(MAX_SOILTYP)
REAL :: F1_TABLE(MAX_SOILTYP)
REAL :: SMCMAX_TABLE(MAX_SOILTYP)
REAL :: SMCREF_TABLE(MAX_SOILTYP)
REAL :: PSISAT_TABLE(MAX_SOILTYP)
REAL :: DKSAT_TABLE(MAX_SOILTYP)
REAL :: DWSAT_TABLE(MAX_SOILTYP)
REAL :: SMCWLT_TABLE(MAX_SOILTYP)
REAL :: QUARTZ_TABLE(MAX_SOILTYP)
REAL :: SLOPE_TABLE(9)
REAL :: CSOIL_TABLE
REAL :: REFDK_TABLE
REAL :: REFKDT_TABLE
REAL :: FRZK_TABLE
REAL :: ZBOT_TABLE
REAL :: CZIL_TABLE
REAL :: ALBSAT_TABLE(MSC,MBAND)
REAL :: ALBDRY_TABLE(MSC,MBAND)
REAL :: ALBICE_TABLE(MBAND)
REAL :: ALBLAK_TABLE(MBAND)
REAL :: OMEGAS_TABLE(MBAND)
REAL :: BETADS_TABLE
REAL :: BETAIS_TABLE
REAL :: EG_TABLE(2)
REAL :: CO2_TABLE
REAL :: O2_TABLE
REAL :: TIMEAN_TABLE
REAL :: FSATMX_TABLE
REAL :: Z0SNO_TABLE
REAL :: SSI_TABLE
REAL :: SWEMX_TABLE
REAL :: RSURF_SNOW_TABLE
INTEGER :: DEFAULT_CROP_TABLE
INTEGER :: PLTDAY_TABLE(NCROP)
INTEGER :: HSDAY_TABLE(NCROP)
REAL :: PLANTPOP_TABLE(NCROP)
REAL :: IRRI_TABLE(NCROP)
REAL :: GDDTBASE_TABLE(NCROP)
REAL :: GDDTCUT_TABLE(NCROP)
REAL :: GDDS1_TABLE(NCROP)
REAL :: GDDS2_TABLE(NCROP)
REAL :: GDDS3_TABLE(NCROP)
REAL :: GDDS4_TABLE(NCROP)
REAL :: GDDS5_TABLE(NCROP)
INTEGER :: C3C4_TABLE(NCROP)
REAL :: AREF_TABLE(NCROP)
REAL :: PSNRF_TABLE(NCROP)
REAL :: I2PAR_TABLE(NCROP)
REAL :: TASSIM0_TABLE(NCROP)
REAL :: TASSIM1_TABLE(NCROP)
REAL :: TASSIM2_TABLE(NCROP)
REAL :: K_TABLE(NCROP)
REAL :: EPSI_TABLE(NCROP)
REAL :: Q10MR_TABLE(NCROP)
REAL :: FOLN_MX_TABLE(NCROP)
REAL :: LEFREEZ_TABLE(NCROP)
REAL :: DILE_FC_TABLE(NCROP,NSTAGE)
REAL :: DILE_FW_TABLE(NCROP,NSTAGE)
REAL :: FRA_GR_TABLE(NCROP)
REAL :: LF_OVRC_TABLE(NCROP,NSTAGE)
REAL :: ST_OVRC_TABLE(NCROP,NSTAGE)
REAL :: RT_OVRC_TABLE(NCROP,NSTAGE)
REAL :: LFMR25_TABLE(NCROP)
REAL :: STMR25_TABLE(NCROP)
REAL :: RTMR25_TABLE(NCROP)
REAL :: GRAINMR25_TABLE(NCROP)
REAL :: LFPT_TABLE(NCROP,NSTAGE)
REAL :: STPT_TABLE(NCROP,NSTAGE)
REAL :: RTPT_TABLE(NCROP,NSTAGE)
REAL :: GRAINPT_TABLE(NCROP,NSTAGE)
REAL :: BIO2LAI_TABLE(NCROP)
CONTAINS
subroutine read_mp_veg_parameters(DATASET_IDENTIFIER)
implicit none
character(len=*), intent(in) :: DATASET_IDENTIFIER
integer :: ierr
INTEGER :: IK,IM
integer :: NVEG
character(len=256) :: VEG_DATASET_DESCRIPTION
INTEGER :: ISURBAN
INTEGER :: ISWATER
INTEGER :: ISBARREN
INTEGER :: ISICE
INTEGER :: ISCROP
INTEGER :: EBLFOREST
INTEGER :: NATURAL
INTEGER :: LOW_DENSITY_RESIDENTIAL
INTEGER :: HIGH_DENSITY_RESIDENTIAL
INTEGER :: HIGH_INTENSITY_INDUSTRIAL
REAL, DIMENSION(MVT) :: SAI_JAN,SAI_FEB,SAI_MAR,SAI_APR,SAI_MAY,SAI_JUN, &
SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC
REAL, DIMENSION(MVT) :: LAI_JAN,LAI_FEB,LAI_MAR,LAI_APR,LAI_MAY,LAI_JUN, &
LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC
REAL, DIMENSION(MVT) :: RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, &
TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR
REAL, DIMENSION(MVT) :: CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, &
AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , &
BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, &
SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5
NAMELIST / noahmp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG
NAMELIST / noahmp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, &
LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL, &
CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, &
LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, &
FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, &
SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, &
LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, &
RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5
NAMELIST / noahmp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG
NAMELIST / noahmp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, &
LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL, &
CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, &
LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, &
FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, &
SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, &
LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, &
RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5
CH2OP_TABLE = -1.E36
DLEAF_TABLE = -1.E36
Z0MVT_TABLE = -1.E36
HVT_TABLE = -1.E36
HVB_TABLE = -1.E36
DEN_TABLE = -1.E36
RC_TABLE = -1.E36
MFSNO_TABLE = -1.E36
RHOL_TABLE = -1.E36
RHOS_TABLE = -1.E36
TAUL_TABLE = -1.E36
TAUS_TABLE = -1.E36
XL_TABLE = -1.E36
CWPVT_TABLE = -1.E36
C3PSN_TABLE = -1.E36
KC25_TABLE = -1.E36
AKC_TABLE = -1.E36
KO25_TABLE = -1.E36
AKO_TABLE = -1.E36
AVCMX_TABLE = -1.E36
AQE_TABLE = -1.E36
LTOVRC_TABLE = -1.E36
DILEFC_TABLE = -1.E36
DILEFW_TABLE = -1.E36
RMF25_TABLE = -1.E36
SLA_TABLE = -1.E36
FRAGR_TABLE = -1.E36
TMIN_TABLE = -1.E36
VCMX25_TABLE = -1.E36
TDLEF_TABLE = -1.E36
BP_TABLE = -1.E36
MP_TABLE = -1.E36
QE25_TABLE = -1.E36
RMS25_TABLE = -1.E36
RMR25_TABLE = -1.E36
ARM_TABLE = -1.E36
FOLNMX_TABLE = -1.E36
WDPOOL_TABLE = -1.E36
WRRAT_TABLE = -1.E36
MRP_TABLE = -1.E36
SAIM_TABLE = -1.E36
LAIM_TABLE = -1.E36
NROOT_TABLE = -1.E36
RGL_TABLE = -1.E36
RS_TABLE = -1.E36
HS_TABLE = -1.E36
TOPT_TABLE = -1.E36
RSMAX_TABLE = -1.E36
ISURBAN_TABLE = -99999
ISWATER_TABLE = -99999
ISBARREN_TABLE = -99999
ISICE_TABLE = -99999
ISCROP_TABLE = -99999
EBLFOREST_TABLE = -99999
NATURAL_TABLE = -99999
LOW_DENSITY_RESIDENTIAL_TABLE = -99999
HIGH_DENSITY_RESIDENTIAL_TABLE = -99999
HIGH_INTENSITY_INDUSTRIAL_TABLE = -99999
open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr)
if (ierr /= 0) then
write(*,'("****** Error ******************************************************")')
write(*,'("Cannot find file MPTABLE.TBL")')
write(*,'("STOP")')
write(*,'("*******************************************************************")')
call wrf_error_fatal3("<stdin>",9219,&
"STOP in Noah-MP read_mp_veg_parameters")
endif
if ( trim(DATASET_IDENTIFIER) == "USGS" ) then
read(15,noahmp_usgs_veg_categories)
read(15,noahmp_usgs_parameters)
else if ( trim(DATASET_IDENTIFIER) == "MODIFIED_IGBP_MODIS_NOAH" ) then
read(15,noahmp_modis_veg_categories)
read(15,noahmp_modis_parameters)
else
write(*,'("Unrecognized DATASET_IDENTIFIER in subroutine READ_MP_VEG_PARAMETERS")')
write(*,'("DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER)
call wrf_error_fatal3("<stdin>",9232,&
"STOP in Noah-MP read_mp_veg_parameters")
endif
close(15)
ISURBAN_TABLE = ISURBAN
ISWATER_TABLE = ISWATER
ISBARREN_TABLE = ISBARREN
ISICE_TABLE = ISICE
ISCROP_TABLE = ISCROP
EBLFOREST_TABLE = EBLFOREST
NATURAL_TABLE = NATURAL
LOW_DENSITY_RESIDENTIAL_TABLE = LOW_DENSITY_RESIDENTIAL
HIGH_DENSITY_RESIDENTIAL_TABLE = HIGH_DENSITY_RESIDENTIAL
HIGH_INTENSITY_INDUSTRIAL_TABLE = HIGH_INTENSITY_INDUSTRIAL
CH2OP_TABLE(1:NVEG) = CH2OP(1:NVEG)
DLEAF_TABLE(1:NVEG) = DLEAF(1:NVEG)
Z0MVT_TABLE(1:NVEG) = Z0MVT(1:NVEG)
HVT_TABLE(1:NVEG) = HVT(1:NVEG)
HVB_TABLE(1:NVEG) = HVB(1:NVEG)
DEN_TABLE(1:NVEG) = DEN(1:NVEG)
RC_TABLE(1:NVEG) = RC(1:NVEG)
MFSNO_TABLE(1:NVEG) = MFSNO(1:NVEG)
XL_TABLE(1:NVEG) = XL(1:NVEG)
CWPVT_TABLE(1:NVEG) = CWPVT(1:NVEG)
C3PSN_TABLE(1:NVEG) = C3PSN(1:NVEG)
KC25_TABLE(1:NVEG) = KC25(1:NVEG)
AKC_TABLE(1:NVEG) = AKC(1:NVEG)
KO25_TABLE(1:NVEG) = KO25(1:NVEG)
AKO_TABLE(1:NVEG) = AKO(1:NVEG)
AVCMX_TABLE(1:NVEG) = AVCMX(1:NVEG)
AQE_TABLE(1:NVEG) = AQE(1:NVEG)
LTOVRC_TABLE(1:NVEG) = LTOVRC(1:NVEG)
DILEFC_TABLE(1:NVEG) = DILEFC(1:NVEG)
DILEFW_TABLE(1:NVEG) = DILEFW(1:NVEG)
RMF25_TABLE(1:NVEG) = RMF25(1:NVEG)
SLA_TABLE(1:NVEG) = SLA(1:NVEG)
FRAGR_TABLE(1:NVEG) = FRAGR(1:NVEG)
TMIN_TABLE(1:NVEG) = TMIN(1:NVEG)
VCMX25_TABLE(1:NVEG) = VCMX25(1:NVEG)
TDLEF_TABLE(1:NVEG) = TDLEF(1:NVEG)
BP_TABLE(1:NVEG) = BP(1:NVEG)
MP_TABLE(1:NVEG) = MP(1:NVEG)
QE25_TABLE(1:NVEG) = QE25(1:NVEG)
RMS25_TABLE(1:NVEG) = RMS25(1:NVEG)
RMR25_TABLE(1:NVEG) = RMR25(1:NVEG)
ARM_TABLE(1:NVEG) = ARM(1:NVEG)
FOLNMX_TABLE(1:NVEG) = FOLNMX(1:NVEG)
WDPOOL_TABLE(1:NVEG) = WDPOOL(1:NVEG)
WRRAT_TABLE(1:NVEG) = WRRAT(1:NVEG)
MRP_TABLE(1:NVEG) = MRP(1:NVEG)
NROOT_TABLE(1:NVEG) = NROOT(1:NVEG)
RGL_TABLE(1:NVEG) = RGL(1:NVEG)
RS_TABLE(1:NVEG) = RS(1:NVEG)
HS_TABLE(1:NVEG) = HS(1:NVEG)
TOPT_TABLE(1:NVEG) = TOPT(1:NVEG)
RSMAX_TABLE(1:NVEG) = RSMAX(1:NVEG)
SAIM_TABLE(1:NVEG, 1) = SAI_JAN(1:NVEG)
SAIM_TABLE(1:NVEG, 2) = SAI_FEB(1:NVEG)
SAIM_TABLE(1:NVEG, 3) = SAI_MAR(1:NVEG)
SAIM_TABLE(1:NVEG, 4) = SAI_APR(1:NVEG)
SAIM_TABLE(1:NVEG, 5) = SAI_MAY(1:NVEG)
SAIM_TABLE(1:NVEG, 6) = SAI_JUN(1:NVEG)
SAIM_TABLE(1:NVEG, 7) = SAI_JUL(1:NVEG)
SAIM_TABLE(1:NVEG, 8) = SAI_AUG(1:NVEG)
SAIM_TABLE(1:NVEG, 9) = SAI_SEP(1:NVEG)
SAIM_TABLE(1:NVEG,10) = SAI_OCT(1:NVEG)
SAIM_TABLE(1:NVEG,11) = SAI_NOV(1:NVEG)
SAIM_TABLE(1:NVEG,12) = SAI_DEC(1:NVEG)
LAIM_TABLE(1:NVEG, 1) = LAI_JAN(1:NVEG)
LAIM_TABLE(1:NVEG, 2) = LAI_FEB(1:NVEG)
LAIM_TABLE(1:NVEG, 3) = LAI_MAR(1:NVEG)
LAIM_TABLE(1:NVEG, 4) = LAI_APR(1:NVEG)
LAIM_TABLE(1:NVEG, 5) = LAI_MAY(1:NVEG)
LAIM_TABLE(1:NVEG, 6) = LAI_JUN(1:NVEG)
LAIM_TABLE(1:NVEG, 7) = LAI_JUL(1:NVEG)
LAIM_TABLE(1:NVEG, 8) = LAI_AUG(1:NVEG)
LAIM_TABLE(1:NVEG, 9) = LAI_SEP(1:NVEG)
LAIM_TABLE(1:NVEG,10) = LAI_OCT(1:NVEG)
LAIM_TABLE(1:NVEG,11) = LAI_NOV(1:NVEG)
LAIM_TABLE(1:NVEG,12) = LAI_DEC(1:NVEG)
RHOL_TABLE(1:NVEG,1) = RHOL_VIS(1:NVEG)
RHOL_TABLE(1:NVEG,2) = RHOL_NIR(1:NVEG)
RHOS_TABLE(1:NVEG,1) = RHOS_VIS(1:NVEG)
RHOS_TABLE(1:NVEG,2) = RHOS_NIR(1:NVEG)
TAUL_TABLE(1:NVEG,1) = TAUL_VIS(1:NVEG)
TAUL_TABLE(1:NVEG,2) = TAUL_NIR(1:NVEG)
TAUS_TABLE(1:NVEG,1) = TAUS_VIS(1:NVEG)
TAUS_TABLE(1:NVEG,2) = TAUS_NIR(1:NVEG)
end subroutine read_mp_veg_parameters
subroutine read_mp_soil_parameters()
IMPLICIT NONE
INTEGER :: IERR
CHARACTER*4 :: SLTYPE
INTEGER :: ITMP, NUM_SLOPE, LC
CHARACTER(len=256) :: message
BEXP_TABLE = -1.E36
SMCDRY_TABLE = -1.E36
F1_TABLE = -1.E36
SMCMAX_TABLE = -1.E36
SMCREF_TABLE = -1.E36
PSISAT_TABLE = -1.E36
DKSAT_TABLE = -1.E36
DWSAT_TABLE = -1.E36
SMCWLT_TABLE = -1.E36
QUARTZ_TABLE = -1.E36
SLOPE_TABLE = -1.E36
CSOIL_TABLE = -1.E36
REFDK_TABLE = -1.E36
REFKDT_TABLE = -1.E36
FRZK_TABLE = -1.E36
ZBOT_TABLE = -1.E36
CZIL_TABLE = -1.E36
OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
IF(ierr .NE. 0 ) THEN
WRITE(message,FMT='(A)') 'module_sf_noahmpdrv.F: read_mp_soil_parameters: failure opening SOILPARM.TBL'
CALL wrf_error_fatal3("<stdin>",9363,&
message )
END IF
READ (19,*)
READ (19,*) SLTYPE
READ (19,*) SLCATS
WRITE( message , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', &
SLCATS,' CATEGORIES'
CALL wrf_message ( message )
DO LC=1,SLCATS
READ (19,*) ITMP,BEXP_TABLE(LC),SMCDRY_TABLE(LC),F1_TABLE(LC),SMCMAX_TABLE(LC), &
SMCREF_TABLE(LC),PSISAT_TABLE(LC),DKSAT_TABLE(LC), DWSAT_TABLE(LC), &
SMCWLT_TABLE(LC), QUARTZ_TABLE(LC)
ENDDO
CLOSE (19)
OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr)
IF(ierr .NE. 0 ) THEN
WRITE(message,FMT='(A)') 'module_sf_noahlsm.F: read_mp_soil_parameters: failure opening GENPARM.TBL'
CALL wrf_error_fatal3("<stdin>",9388,&
message )
END IF
READ (19,*)
READ (19,*)
READ (19,*) NUM_SLOPE
DO LC=1,NUM_SLOPE
READ (19,*) SLOPE_TABLE(LC)
ENDDO
READ (19,*)
READ (19,*)
READ (19,*)
READ (19,*)
READ (19,*)
READ (19,*) CSOIL_TABLE
READ (19,*)
READ (19,*)
READ (19,*)
READ (19,*) REFDK_TABLE
READ (19,*)
READ (19,*) REFKDT_TABLE
READ (19,*)
READ (19,*) FRZK_TABLE
READ (19,*)
READ (19,*) ZBOT_TABLE
READ (19,*)
READ (19,*) CZIL_TABLE
READ (19,*)
READ (19,*)
READ (19,*)
READ (19,*)
CLOSE (19)
end subroutine read_mp_soil_parameters
subroutine read_mp_rad_parameters()
implicit none
integer :: ierr
REAL :: ALBICE(MBAND),ALBLAK(MBAND),OMEGAS(MBAND),BETADS,BETAIS,EG(2)
REAL :: ALBSAT_VIS(MSC)
REAL :: ALBSAT_NIR(MSC)
REAL :: ALBDRY_VIS(MSC)
REAL :: ALBDRY_NIR(MSC)
NAMELIST / noahmp_rad_parameters / ALBSAT_VIS,ALBSAT_NIR,ALBDRY_VIS,ALBDRY_NIR,ALBICE,ALBLAK,OMEGAS,BETADS,BETAIS,EG
ALBSAT_TABLE = -1.E36
ALBDRY_TABLE = -1.E36
ALBICE_TABLE = -1.E36
ALBLAK_TABLE = -1.E36
OMEGAS_TABLE = -1.E36
BETADS_TABLE = -1.E36
BETAIS_TABLE = -1.E36
EG_TABLE = -1.E36
open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr)
if (ierr /= 0) then
write(*,'("****** Error ******************************************************")')
write(*,'("Cannot find file MPTABLE.TBL")')
write(*,'("STOP")')
write(*,'("*******************************************************************")')
call wrf_error_fatal3("<stdin>",9456,&
"STOP in Noah-MP read_mp_rad_parameters")
endif
read(15,noahmp_rad_parameters)
close(15)
ALBSAT_TABLE(:,1) = ALBSAT_VIS
ALBSAT_TABLE(:,2) = ALBSAT_NIR
ALBDRY_TABLE(:,1) = ALBDRY_VIS
ALBDRY_TABLE(:,2) = ALBDRY_NIR
ALBICE_TABLE = ALBICE
ALBLAK_TABLE = ALBLAK
OMEGAS_TABLE = OMEGAS
BETADS_TABLE = BETADS
BETAIS_TABLE = BETAIS
EG_TABLE = EG
end subroutine read_mp_rad_parameters
subroutine read_mp_global_parameters()
implicit none
integer :: ierr
REAL :: CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SWEMX,RSURF_SNOW
NAMELIST / noahmp_global_parameters / CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SWEMX,RSURF_SNOW
CO2_TABLE = -1.E36
O2_TABLE = -1.E36
TIMEAN_TABLE = -1.E36
FSATMX_TABLE = -1.E36
Z0SNO_TABLE = -1.E36
SSI_TABLE = -1.E36
SWEMX_TABLE = -1.E36
RSURF_SNOW_TABLE = -1.E36
open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr)
if (ierr /= 0) then
write(*,'("****** Error ******************************************************")')
write(*,'("Cannot find file MPTABLE.TBL")')
write(*,'("STOP")')
write(*,'("*******************************************************************")')
call wrf_error_fatal3("<stdin>",9501,&
"STOP in Noah-MP read_mp_global_parameters")
endif
read(15,noahmp_global_parameters)
close(15)
CO2_TABLE = CO2
O2_TABLE = O2
TIMEAN_TABLE = TIMEAN
FSATMX_TABLE = FSATMX
Z0SNO_TABLE = Z0SNO
SSI_TABLE = SSI
SWEMX_TABLE = SWEMX
RSURF_SNOW_TABLE = RSURF_SNOW
end subroutine read_mp_global_parameters
subroutine read_mp_crop_parameters()
implicit none
integer :: ierr
INTEGER :: DEFAULT_CROP
INTEGER, DIMENSION(NCROP) :: PLTDAY
INTEGER, DIMENSION(NCROP) :: HSDAY
REAL, DIMENSION(NCROP) :: PLANTPOP
REAL, DIMENSION(NCROP) :: IRRI
REAL, DIMENSION(NCROP) :: GDDTBASE
REAL, DIMENSION(NCROP) :: GDDTCUT
REAL, DIMENSION(NCROP) :: GDDS1
REAL, DIMENSION(NCROP) :: GDDS2
REAL, DIMENSION(NCROP) :: GDDS3
REAL, DIMENSION(NCROP) :: GDDS4
REAL, DIMENSION(NCROP) :: GDDS5
INTEGER, DIMENSION(NCROP) :: C3C4
REAL, DIMENSION(NCROP) :: AREF
REAL, DIMENSION(NCROP) :: PSNRF
REAL, DIMENSION(NCROP) :: I2PAR
REAL, DIMENSION(NCROP) :: TASSIM0
REAL, DIMENSION(NCROP) :: TASSIM1
REAL, DIMENSION(NCROP) :: TASSIM2
REAL, DIMENSION(NCROP) :: K
REAL, DIMENSION(NCROP) :: EPSI
REAL, DIMENSION(NCROP) :: Q10MR
REAL, DIMENSION(NCROP) :: FOLN_MX
REAL, DIMENSION(NCROP) :: LEFREEZ
REAL, DIMENSION(NCROP) :: DILE_FC_S1,DILE_FC_S2,DILE_FC_S3,DILE_FC_S4,DILE_FC_S5,DILE_FC_S6,DILE_FC_S7,DILE_FC_S8
REAL, DIMENSION(NCROP) :: DILE_FW_S1,DILE_FW_S2,DILE_FW_S3,DILE_FW_S4,DILE_FW_S5,DILE_FW_S6,DILE_FW_S7,DILE_FW_S8
REAL, DIMENSION(NCROP) :: FRA_GR
REAL, DIMENSION(NCROP) :: LF_OVRC_S1,LF_OVRC_S2,LF_OVRC_S3,LF_OVRC_S4,LF_OVRC_S5,LF_OVRC_S6,LF_OVRC_S7,LF_OVRC_S8
REAL, DIMENSION(NCROP) :: ST_OVRC_S1,ST_OVRC_S2,ST_OVRC_S3,ST_OVRC_S4,ST_OVRC_S5,ST_OVRC_S6,ST_OVRC_S7,ST_OVRC_S8
REAL, DIMENSION(NCROP) :: RT_OVRC_S1,RT_OVRC_S2,RT_OVRC_S3,RT_OVRC_S4,RT_OVRC_S5,RT_OVRC_S6,RT_OVRC_S7,RT_OVRC_S8
REAL, DIMENSION(NCROP) :: LFMR25
REAL, DIMENSION(NCROP) :: STMR25
REAL, DIMENSION(NCROP) :: RTMR25
REAL, DIMENSION(NCROP) :: GRAINMR25
REAL, DIMENSION(NCROP) :: LFPT_S1,LFPT_S2,LFPT_S3,LFPT_S4,LFPT_S5,LFPT_S6,LFPT_S7,LFPT_S8
REAL, DIMENSION(NCROP) :: STPT_S1,STPT_S2,STPT_S3,STPT_S4,STPT_S5,STPT_S6,STPT_S7,STPT_S8
REAL, DIMENSION(NCROP) :: RTPT_S1,RTPT_S2,RTPT_S3,RTPT_S4,RTPT_S5,RTPT_S6,RTPT_S7,RTPT_S8
REAL, DIMENSION(NCROP) :: GRAINPT_S1,GRAINPT_S2,GRAINPT_S3,GRAINPT_S4,GRAINPT_S5,GRAINPT_S6,GRAINPT_S7,GRAINPT_S8
REAL, DIMENSION(NCROP) :: BIO2LAI
NAMELIST / noahmp_crop_parameters /DEFAULT_CROP, PLTDAY, HSDAY, PLANTPOP, IRRI, GDDTBASE, GDDTCUT, GDDS1, GDDS2, &
GDDS3, GDDS4, GDDS5, C3C4, AREF, PSNRF, I2PAR, TASSIM0, &
TASSIM1, TASSIM2, K, EPSI, Q10MR, FOLN_MX, LEFREEZ, &
DILE_FC_S1,DILE_FC_S2,DILE_FC_S3,DILE_FC_S4,DILE_FC_S5,DILE_FC_S6,DILE_FC_S7,DILE_FC_S8, &
DILE_FW_S1,DILE_FW_S2,DILE_FW_S3,DILE_FW_S4,DILE_FW_S5,DILE_FW_S6,DILE_FW_S7,DILE_FW_S8, &
FRA_GR, &
LF_OVRC_S1,LF_OVRC_S2,LF_OVRC_S3,LF_OVRC_S4,LF_OVRC_S5,LF_OVRC_S6,LF_OVRC_S7,LF_OVRC_S8, &
ST_OVRC_S1,ST_OVRC_S2,ST_OVRC_S3,ST_OVRC_S4,ST_OVRC_S5,ST_OVRC_S6,ST_OVRC_S7,ST_OVRC_S8, &
RT_OVRC_S1,RT_OVRC_S2,RT_OVRC_S3,RT_OVRC_S4,RT_OVRC_S5,RT_OVRC_S6,RT_OVRC_S7,RT_OVRC_S8, &
LFMR25, STMR25, RTMR25, GRAINMR25, &
LFPT_S1, LFPT_S2, LFPT_S3, LFPT_S4, LFPT_S5, LFPT_S6, LFPT_S7, LFPT_S8, &
STPT_S1, STPT_S2, STPT_S3, STPT_S4, STPT_S5, STPT_S6, STPT_S7, STPT_S8, &
RTPT_S1, RTPT_S2, RTPT_S3, RTPT_S4, RTPT_S5, RTPT_S6, RTPT_S7, RTPT_S8, &
GRAINPT_S1,GRAINPT_S2,GRAINPT_S3,GRAINPT_S4,GRAINPT_S5,GRAINPT_S6,GRAINPT_S7,GRAINPT_S8, &
BIO2LAI
DEFAULT_CROP_TABLE = -99999
PLTDAY_TABLE = -99999
HSDAY_TABLE = -99999
PLANTPOP_TABLE = -1.E36
IRRI_TABLE = -1.E36
GDDTBASE_TABLE = -1.E36
GDDTCUT_TABLE = -1.E36
GDDS1_TABLE = -1.E36
GDDS2_TABLE = -1.E36
GDDS3_TABLE = -1.E36
GDDS4_TABLE = -1.E36
GDDS5_TABLE = -1.E36
C3C4_TABLE = -99999
AREF_TABLE = -1.E36
PSNRF_TABLE = -1.E36
I2PAR_TABLE = -1.E36
TASSIM0_TABLE = -1.E36
TASSIM1_TABLE = -1.E36
TASSIM2_TABLE = -1.E36
K_TABLE = -1.E36
EPSI_TABLE = -1.E36
Q10MR_TABLE = -1.E36
FOLN_MX_TABLE = -1.E36
LEFREEZ_TABLE = -1.E36
DILE_FC_TABLE = -1.E36
DILE_FW_TABLE = -1.E36
FRA_GR_TABLE = -1.E36
LF_OVRC_TABLE = -1.E36
ST_OVRC_TABLE = -1.E36
RT_OVRC_TABLE = -1.E36
LFMR25_TABLE = -1.E36
STMR25_TABLE = -1.E36
RTMR25_TABLE = -1.E36
GRAINMR25_TABLE = -1.E36
LFPT_TABLE = -1.E36
STPT_TABLE = -1.E36
RTPT_TABLE = -1.E36
GRAINPT_TABLE = -1.E36
BIO2LAI_TABLE = -1.E36
open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr)
if (ierr /= 0) then
write(*,'("****** Error ******************************************************")')
write(*,'("Cannot find file MPTABLE.TBL")')
write(*,'("STOP")')
write(*,'("*******************************************************************")')
call wrf_error_fatal3("<stdin>",9629,&
"STOP in Noah-MP read_mp_crop_parameters")
endif
read(15,noahmp_crop_parameters)
close(15)
DEFAULT_CROP_TABLE = DEFAULT_CROP
PLTDAY_TABLE = PLTDAY
HSDAY_TABLE = HSDAY
PLANTPOP_TABLE = PLANTPOP
IRRI_TABLE = IRRI
GDDTBASE_TABLE = GDDTBASE
GDDTCUT_TABLE = GDDTCUT
GDDS1_TABLE = GDDS1
GDDS2_TABLE = GDDS2
GDDS3_TABLE = GDDS3
GDDS4_TABLE = GDDS4
GDDS5_TABLE = GDDS5
C3C4_TABLE = C3C4
AREF_TABLE = AREF
PSNRF_TABLE = PSNRF
I2PAR_TABLE = I2PAR
TASSIM0_TABLE = TASSIM0
TASSIM1_TABLE = TASSIM1
TASSIM2_TABLE = TASSIM2
K_TABLE = K
EPSI_TABLE = EPSI
Q10MR_TABLE = Q10MR
FOLN_MX_TABLE = FOLN_MX
LEFREEZ_TABLE = LEFREEZ
DILE_FC_TABLE(:,1) = DILE_FC_S1
DILE_FC_TABLE(:,2) = DILE_FC_S2
DILE_FC_TABLE(:,3) = DILE_FC_S3
DILE_FC_TABLE(:,4) = DILE_FC_S4
DILE_FC_TABLE(:,5) = DILE_FC_S5
DILE_FC_TABLE(:,6) = DILE_FC_S6
DILE_FC_TABLE(:,7) = DILE_FC_S7
DILE_FC_TABLE(:,8) = DILE_FC_S8
DILE_FW_TABLE(:,1) = DILE_FW_S1
DILE_FW_TABLE(:,2) = DILE_FW_S2
DILE_FW_TABLE(:,3) = DILE_FW_S3
DILE_FW_TABLE(:,4) = DILE_FW_S4
DILE_FW_TABLE(:,5) = DILE_FW_S5
DILE_FW_TABLE(:,6) = DILE_FW_S6
DILE_FW_TABLE(:,7) = DILE_FW_S7
DILE_FW_TABLE(:,8) = DILE_FW_S8
FRA_GR_TABLE = FRA_GR
LF_OVRC_TABLE(:,1) = LF_OVRC_S1
LF_OVRC_TABLE(:,2) = LF_OVRC_S2
LF_OVRC_TABLE(:,3) = LF_OVRC_S3
LF_OVRC_TABLE(:,4) = LF_OVRC_S4
LF_OVRC_TABLE(:,5) = LF_OVRC_S5
LF_OVRC_TABLE(:,6) = LF_OVRC_S6
LF_OVRC_TABLE(:,7) = LF_OVRC_S7
LF_OVRC_TABLE(:,8) = LF_OVRC_S8
ST_OVRC_TABLE(:,1) = ST_OVRC_S1
ST_OVRC_TABLE(:,2) = ST_OVRC_S2
ST_OVRC_TABLE(:,3) = ST_OVRC_S3
ST_OVRC_TABLE(:,4) = ST_OVRC_S4
ST_OVRC_TABLE(:,5) = ST_OVRC_S5
ST_OVRC_TABLE(:,6) = ST_OVRC_S6
ST_OVRC_TABLE(:,7) = ST_OVRC_S7
ST_OVRC_TABLE(:,8) = ST_OVRC_S8
RT_OVRC_TABLE(:,1) = RT_OVRC_S1
RT_OVRC_TABLE(:,2) = RT_OVRC_S2
RT_OVRC_TABLE(:,3) = RT_OVRC_S3
RT_OVRC_TABLE(:,4) = RT_OVRC_S4
RT_OVRC_TABLE(:,5) = RT_OVRC_S5
RT_OVRC_TABLE(:,6) = RT_OVRC_S6
RT_OVRC_TABLE(:,7) = RT_OVRC_S7
RT_OVRC_TABLE(:,8) = RT_OVRC_S8
LFMR25_TABLE = LFMR25
STMR25_TABLE = STMR25
RTMR25_TABLE = RTMR25
GRAINMR25_TABLE = GRAINMR25
LFPT_TABLE(:,1) = LFPT_S1
LFPT_TABLE(:,2) = LFPT_S2
LFPT_TABLE(:,3) = LFPT_S3
LFPT_TABLE(:,4) = LFPT_S4
LFPT_TABLE(:,5) = LFPT_S5
LFPT_TABLE(:,6) = LFPT_S6
LFPT_TABLE(:,7) = LFPT_S7
LFPT_TABLE(:,8) = LFPT_S8
STPT_TABLE(:,1) = STPT_S1
STPT_TABLE(:,2) = STPT_S2
STPT_TABLE(:,3) = STPT_S3
STPT_TABLE(:,4) = STPT_S4
STPT_TABLE(:,5) = STPT_S5
STPT_TABLE(:,6) = STPT_S6
STPT_TABLE(:,7) = STPT_S7
STPT_TABLE(:,8) = STPT_S8
RTPT_TABLE(:,1) = RTPT_S1
RTPT_TABLE(:,2) = RTPT_S2
RTPT_TABLE(:,3) = RTPT_S3
RTPT_TABLE(:,4) = RTPT_S4
RTPT_TABLE(:,5) = RTPT_S5
RTPT_TABLE(:,6) = RTPT_S6
RTPT_TABLE(:,7) = RTPT_S7
RTPT_TABLE(:,8) = RTPT_S8
GRAINPT_TABLE(:,1) = GRAINPT_S1
GRAINPT_TABLE(:,2) = GRAINPT_S2
GRAINPT_TABLE(:,3) = GRAINPT_S3
GRAINPT_TABLE(:,4) = GRAINPT_S4
GRAINPT_TABLE(:,5) = GRAINPT_S5
GRAINPT_TABLE(:,6) = GRAINPT_S6
GRAINPT_TABLE(:,7) = GRAINPT_S7
GRAINPT_TABLE(:,8) = GRAINPT_S8
BIO2LAI_TABLE = BIO2LAI
end subroutine read_mp_crop_parameters
END MODULE NOAHMP_TABLES