SUBROUTINE CLASST (TBARC, TBARG, TBARCS, TBARGS, THLIQC, THLIQG, 1,19
1 THICEC, THICEG, HCPC, HCPG, GZEROC, GZEROG, QLWAVG,
2 GZROCS, GZROGS, G12C, G12G, G12CS, G12GS, G23C, G23G,
3 G23CS, G23GS, QFREZC, QFREZG, QMELTC, QMELTG, EVAPC, EVAPCG,
4 EVAPG, EVAPCS, EVPCSG, EVAPGS, TCANO, TCANS,
5 RAICAN, SNOCAN, RAICNS, SNOCNS, CHCAP, CHCAPS, ILMO, UE,
6 TPONDC, TPONDG, TPNDCS, TPNDGS, TSNOCS, TSNOGS, H,
7 ITERCT, CDH, CDM, QSENS, TFLUX, QEVAP, EVAP, QFLUX,
8 EVPPOT, ACOND, EVAPB, GT, QG, TSURF, ST, SU,
9 SV, SQ, FSGV, FSGS, FSGG, FLGV, FLGS, FLGG,
A HFSC, HFSS, HFSG, HEVC, HEVS, HEVG, HMFC, HTCC,
B HTCS, HTC, WTABLE, ZREFM, ZREFH, ZDIAGM, ZDIAGH,
C VPD, TADP, RHOAIR, QSWINV, QSWINI, QLWIN, UWIND, VWIND,
D TA, QA, PADRY, FC, FG, FCS, FGS, DLEAF,
E AILCAN, AILCNS, FSVF, FSVFS, ALVSCN, ALIRCN, ALVSG, ALIRG,
F ALVSCS, ALIRCS, ALVSSN, ALIRSN, TRVSCN, TRIRCN, TRVSCS, TRIRCS,
G RC, RCS, FRAINC, FSNOWC, CMASSC, CMASCS, DISP, DISPS,
H ZOMLNC, ZOELNC, ZOMLNG, ZOELNG, ZOMLCS, ZOELCS, ZOMLNS, ZOELNS,
I TBAR, THLIQ, THICE, TPOND, ZPOND, TBASE, TCAN, TSNOW,
J ZSNOW, TRSNOW, RHOSNO, THPOR, THLRET, THLMIN, THFC, RADJ,
K HCPS, TCS, DELZW, ZBOTW, ISAND,
L ILW, ILG, IL1, IL2, JL, IC, IG, IZREF,
M ISLFD, NLANDCS,NLANDGS,NLANDC, NLANDG, NLANDI, ITER, NITER )
C
C * AUG 19/04 - Y.DELAGE. REMOVE WORK ARRAYS FROM ARGUMENT LIST
C REGROUP COMMON BLOCKS
C MAKE DECLARATIONS EXPLICIT
C * NOV 07/02 - Y.DELAGE/D.VERSEGHY. CALLS TO NEW DIAGNOSTIC
C * SUBROUTINES "SLDIAG" AND "DIASURF";
C * MODIFICATIONS TO ACCOMMODATE DIFFERENT
C * SURFACE REFERENCE HEIGHT CONVENTIONS.
C * JUL 31/02 - D.VERSEGHY. MOVE CALCULATION OF VEGETATION STOMATAL
C * RESISTANCE FROM TPREP INTO APREP AND
C * CANALB; SHORTENED CLASS3 COMMON BLOCK.
C * JUL 23/02 - D.VERSEGHY. MOVE ADDITION OF AIR TO CANOPY MASS
C * INTO CLASSA; SHORTENED CLASS4
C * COMMON BLOCK.
C * MAR 28/02 - D.VERSEGHY. STREAMLINED SUBROUTINE CALLS.
C * MAR 22/02 - D.VERSEGHY. MOVE CALCULATION OF BACKGROUND SOIL
C * PROPERTIES INTO "CLASSB"; ADD NEW
C * DIAGNOSTIC VARIABLES "EVPPOT", "ACOND"
C * AND "TSURF"; MODIFY CALCULATIONS OF VAC,
C * EVAPB AND QG.
C * JAN 18/02 - D.VERSEGHY. CHANGES TO INCORPORATE NEW BARE SOIL
C * EVAPORATION FORMULATION.
C * APR 11/01 - M.LAZARE. SHORTENED "CLASS2" COMMON BLOCK.
C * SEP 19/00 - D.VERSEGHY. PASS VEGETATION-VARYING COEFFICIENTS
C * TO TPREP FOR CALCULATION OF STOMATAL
C * RESISTANCE.
C * DEC 16/99 - A.WU/D.VERSEGHY. CHANGES MADE TO INCORPORATE NEW SOIL
C * EVAPORATION ALGORITHMS AND NEW CANOPY
C * TURBULENT FLUX FORMULATION. MODIFY
C * CALCULATION OF BULK RICHARDSON NUMBER
C * AND CANOPY MASS.
C * APR 15/99 - M.LAZARE. CORRECT SCREEN-LEVEL CALCULATION FOR WINDS
C * TO HOLD AT ANEMOMETER LEVEL (10M) INSTEAD
C * OF SCREEN LEVEL (2M).
C * JUN 20/97 - D.VERSEGHY. CLASS - VERSION 2.7.
C * CHANGES RELATED TO VARIABLE SOIL DEPTH
C * (MOISTURE HOLDING CAPACITY) AND DEPTH-
C * VARYING SOIL PROPERTIES.
C * ALSO, APPLY UPPER BOUND ON "RATFC1").
C * OCT 11/96 - D.VERSEGHY. CLASS - VERSION 2.6.
C * REVISE CALCULATION OF SLTHKEF AND
C * DEFINITION OF ZREF FOR INTERNAL
C * CONSISTENCY.
C * SEP 27/96 - D.VERSEGHY. FIX BUG IN CALCULATION OF FLUXES
C * BETWEEN SOIL LAYERS (PRESENT SINCE
C * RELEASE OF CLASS VERSION 2.5).
C * MAY 21/96 - K.ABDELLA. CORRECT EXPRESSION FOR ZOSCLH (4 PLACES).
C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5.
C * COMPLETION OF ENERGY BALANCE
C * DIAGNOSTICS; ALSO, PASS IN ZREF AND
C * ILW THROUGH SUBROUTINE CALL.
C * AUG 18/95 - D.VERSEGHY. CLASS - VERSION 2.4.
C * REVISIONS TO ALLOW FOR INHOMOGENEITY
C * BETWEEN SOIL LAYERS AND FRACTIONAL
C * ORGANIC MATTER CONTENT.
C * DEC 16/94 - D.VERSEGHY. CLASS - VERSION 2.3.
C * ADD THREE NEW DIAGNOSTIC FIELDS;
C * REVISE CALCULATION OF HTCS, HTC.
C * DEC 06/94 - M.LAZARE. - PASS "CFLUX" TO TSOLVE INSTEAD OF
C * "CLIMIT" IN CONJUNCTION WITH CHANGES
C * TO THAT ROUTINE.
C * - REVISE CALCULATION OF "ZREF" TO INCLUDE
C * VIRTUAL TEMPERATURE EFFECTS.
C * - REVISE CALCULATION OF "SLTHKEF".
C * NOV 28/94 - M.LAZARE. FORM DRAG "CDOM" MODIFICATION REMOVED.
C * NOV 18/93 - D.VERSEGHY. CLASS - VERSION 2.2.
C * LOCAL VERSION WITH INTERNAL WORK ARRAYS
C * HARD-CODED FOR USE ON PCS.
C * NOV 05/93 - M.LAZARE. ADD NEW DIAGNOSTIC OUTPUT FIELD: DRAG.
C * JUL 27/93 - D.VERSEGHY/M.LAZARE. PREVIOUS VERSION CLASSTO.
IMPLICIT NONE
INTEGER I,ILW, ILG,IL1,IL2,JL, IC, IG, IZREF,ISLFD,J,ISNOW
INTEGER NLANDCS,NLANDGS,NLANDC, NLANDG, NLANDI
REAL THTOT,CA,CB,wacsat,qacsat
C
C * OUTPUT FIELDS.
C
REAL TBARC (ILG,IG),TBARG (ILG,IG),TBARCS(ILG,IG),TBARGS(ILG,IG),
1 THLIQC(ILG,IG),THLIQG(ILG,IG),THICEC(ILG,IG),THICEG(ILG,IG),
2 HCPC (ILG,IG),HCPG (ILG,IG),HTC (ILG,IG)
C
REAL GZEROC(ILG), GZEROG(ILG), GZROCS(ILG), GZROGS(ILG),
1 G12C (ILG), G12G (ILG), G12CS (ILG), G12GS (ILG),
2 G23C (ILG), G23G (ILG), G23CS (ILG), G23GS (ILG),
3 QFREZC(ILG), QFREZG(ILG), QMELTC(ILG), QMELTG(ILG),
4 EVAPC (ILG), EVAPCG(ILG), EVAPG (ILG), EVAPCS(ILG),
5 EVPCSG(ILG), EVAPGS(ILG), TCANO (ILG), TCANS (ILG),
6 RAICAN(ILG), SNOCAN(ILG), RAICNS(ILG), SNOCNS(ILG),
7 CHCAP (ILG), CHCAPS(ILG), TPONDC(ILG), TPONDG(ILG),
8 TPNDCS(ILG), TPNDGS(ILG), TSNOCS(ILG), TSNOGS(ILG),
9 CDH (ILG), CDM (ILG), QSENS (ILG), TFLUX (ILG),
A QEVAP (ILG), EVAP (ILG), QFLUX (ILG),
B EVPPOT(ILG), ACOND (ILG), EVAPB (ILG),
C GT (ILG), QG (ILG), TSURF (ILG), WTABLE(ILG),
D ST (ILG), SU (ILG), SV (ILG), SQ (ILG),
E FSGV (ILG), FSGS (ILG), FSGG (ILG), FLGV (ILG),
F FLGS (ILG), FLGG (ILG), HFSC (ILG), HFSS (ILG),
G HFSG (ILG), HEVC (ILG), HEVS (ILG), HEVG (ILG),
H HMFC (ILG), HTCC (ILG), HTCS (ILG), QLWAVG(ILG),
I ILMO (ILG), UE (ILG), H (ILG)
C
INTEGER ITERCT(ILG,6,50)
C
C * INPUT FIELDS.
C
REAL ZREFM (ILG), ZREFH (ILG), ZDIAGM(ILG), ZDIAGH(ILG),
1 VPD (ILG), TADP (ILG), RHOAIR(ILG), QSWINV(ILG),
2 QSWINI(ILG), QLWIN (ILG), UWIND (ILG), VWIND (ILG),
3 TA (ILG), QA (ILG), PADRY (ILG), FC (ILG),
4 FG (ILG), FCS (ILG), FGS (ILG), DLEAF (ILG),
5 AILCAN(ILG), AILCNS(ILG), FSVF (ILG), FSVFS (ILG),
6 ALVSCN(ILG), ALIRCN(ILG), ALVSG (ILG), ALIRG (ILG),
7 ALVSCS(ILG), ALIRCS(ILG), ALVSSN(ILG), ALIRSN(ILG),
8 TRVSCN(ILG), TRIRCN(ILG), TRVSCS(ILG), TRIRCS(ILG),
9 RC (ILG), RCS (ILG), FRAINC(ILG), FSNOWC(ILG),
A CMASSC(ILG), CMASCS(ILG), DISP (ILG), DISPS (ILG),
B ZOMLNC(ILG), ZOELNC(ILG), ZOMLNG(ILG), ZOELNG(ILG),
C ZOMLCS(ILG), ZOELCS(ILG), ZOMLNS(ILG), ZOELNS(ILG),
D ZPOND (ILG), TBASE (ILG), TCAN (ILG), TSNOW (ILG),
E ZSNOW (ILG), TRSNOW(ILG), RHOSNO(ILG), TPOND (ILG)
C
REAL TBAR (ILG,IG),THLIQ (ILG,IG),THICE (ILG,IG)
C
REAL RADJ (ILG)
C
C * SOIL PROPERTY ARRAYS.
C
REAL THPOR (ILG,IG),THLRET(ILG,IG),THLMIN(ILG,IG),
1 THFC (ILG,IG),HCPS (ILG,IG),TCS (ILG,IG),
1 DELZW (ILG,IG),ZBOTW (ILG,IG)
C
INTEGER ISAND (ILG,IG)
C
C * INTERNAL WORK ARRAYS FOR THIS ROUTINE.
C
REAL TCTOP (ILG, IG),TCBOT (ILG, IG)
C
REAL VA (ILG), ZRSLDM(ILG), ZRSLDH(ILG),
1 ZRSLFM(ILG), ZRSLFH(ILG), ZDSLM (ILG), ZDSLH (ILG),
2 TPOTA (ILG), TVIRTA(ILG), CRIB (ILG), CPHCHC(ILG),
3 CPHCHG(ILG), HCPSNO(ILG), TCSNOW(ILG), CEVAP (ILG),
4 TBAR1P(ILG), HCP1P (ILG), GSNOWC(ILG), GSNOWG(ILG),
5 GDENOM(ILG), GCOEFF(ILG), GCONST(ILG), A1 (ILG),
6 A2 (ILG), A3 (ILG), B1 (ILG), B2 (ILG),
7 B3 (ILG), C2 (ILG), C3 (ILG), D3 (ILG),
8 TSTART(ILG), ZOM (ILG), ZOH (ILG), ZOSCLM(ILG),
9 ZOSCLH(ILG), VAC (ILG), RIB (ILG), FCOR (ILG),
A TAC (ILG), CFLUX (ILG), CDHX (ILG), CDMX (ILG),
B QSWX (ILG), QSWNC (ILG), QSWNG (ILG), QLWX (ILG),
C QLWOC (ILG), QLWOG (ILG), QTRANS(ILG),
D QSENSX(ILG), QSENSC(ILG), QSENSG(ILG), QEVAPX(ILG),
E QEVAPC(ILG), QEVAPG(ILG), QPHCHC(ILG), QCANX (ILG),
F TSURX (ILG), QSURX (ILG), FTEMP (ILG), FVAP (ILG),
G ILMOX (ILG), UEX (ILG), HX (ILG), DRAG (ILG)
C
INTEGER IEVAP (ILG), IWATER(ILG)
C
C * INTERNAL WORK ARRAYS FOR TPREP.
C
REAL FVEG (ILG), TCSAT (ILG)
C
C * INTERNAL WORK ARRAYS FOR TSOLVC/TSOLVE.
C
REAL TSTEP (ILG), TVIRTC(ILG), TVIRTG(ILG), TVIRTS(ILG),
1 EVBETA(ILG), XEVAP (ILG), EVPWET(ILG), Q0SAT (ILG),
2 RB (ILG), RAGINV(ILG), RBINV (ILG),
3 RBTINV(ILG), RBCINV(ILG),
4 QAC (ILG), TVRTAC(ILG), TPOTG (ILG), RESID (ILG),
5 RESIDL(ILG), RESIDO(ILG), TZEROL(ILG), TZEROO(ILG),
6 TCANL (ILG), TCANP (ILG), TRTOP (ILG), QSTOR (ILG),
7 AC (ILG), BC (ILG), ZOMS (ILG), ZOHS (ILG),
8 LZZ0 (ILG), LZZ0T (ILG), FM (ILG), FH (ILG)
C
INTEGER ITER (ILG), NITER (ILG),
1 KF (ILG), KF1 (ILG), KF2 (ILG)
C
#include "class_com.cdk"
C
C----------------------------------------------------------------------
C
C * CALCULATION OF ATMOSPHERIC INPUT FIELDS REQUIRED BY CLASS FROM
C * VARIABLES SUPPLIED BY GCM.
C
DO 50 I=IL1,IL2
VA(I)=MAX(VMIN,SQRT(UWIND(I)*UWIND(I)+VWIND(I)*VWIND(I)))
FCOR(I)=2.0*7.29E-5*SIN(RADJ(I))
C
C * LATENT HEAT OF VAPORIZATION FROM CANOPY.
C
IF(FSNOWC(I).GT.0. .OR. FRAINC(I).GT.0.) THEN
CPHCHC(I)=(FSNOWC(I)*(CLHVAP+CLHMLT)+FRAINC(I)*CLHVAP)/
1 (FSNOWC(I)+FRAINC(I))
ELSE
CPHCHC(I)=CLHVAP
ENDIF
C
C * CHECK DEPTH OF PONDED WATER FOR UNPHYSICAL VALUES.
C
IF(ZPOND(I).LT.1.0E-5) ZPOND(I)=0.0
50 CONTINUE
C
C * CHECK LIQUID AND FROZEN SOIL MOISTURE CONTENTS FOR SMALL
C * ABERRATIONS CAUSED BY PACKING/UNPACKING.
C
DO 60 J=1,IG
DO 60 I=IL1,IL2
IF(ISAND(I,1).GT.-4) THEN
IF(THLIQ(I,J).LT.THLMIN(I,J))
1 THLIQ(I,J)=THLMIN(I,J)
IF(THICE(I,J).LT.0.0) THICE(I,J)=0.0
THTOT=THLIQ(I,J)+THICE(I,J)*RHOICE/RHOW
IF(THTOT.GT.THPOR(I,J)) THEN
THLIQ(I,J)=MAX(THLIQ(I,J)*THPOR(I,J)/
1 THTOT,THLMIN(I,J))
THICE(I,J)=(THPOR(I,J)-THLIQ(I,J))*
1 RHOW/RHOICE
IF(THICE(I,J).LT.0.0) THICE(I,J)=0.0
ENDIF
ENDIF
60 CONTINUE
C
C * DEFINE NUMBER OF PIXELS OF EACH LAND SURFACE SUBAREA
C * (CANOPY-COVERED, CANOPY-AND-SNOW-COVERED, BARE SOIL, AND
C * SNOW OVER BARE SOIL) AND NUMBER OF LAND ICE PIXELS FOR
C * CALCULATIONS IN CLASST/CLASSW.
NLANDC =0
NLANDCS=0
NLANDG =0
NLANDGS=0
NLANDI =0
DO 70 I=IL1,IL2
IF(FC (I).GT.0.) NLANDC =NLANDC +1
IF(FCS(I).GT.0.) NLANDCS=NLANDCS+1
IF(FG (I).GT.0.) NLANDG =NLANDG +1
IF(FGS(I).GT.0.) NLANDGS=NLANDGS+1
IF(ISAND(I,1).EQ.-4) NLANDI =NLANDI +1
70 CONTINUE
C
C * PREPARATION.
C
CALL TPREP (THLIQC, THLIQG, THICEC, THICEG, TBARC, TBARG,
1 TBARCS, TBARGS, HCPC, HCPG, TCTOP, TCBOT,
2 HCPSNO, TCSNOW, TSNOCS, TSNOGS, TCANO, TCANS,
3 CEVAP, IEVAP, TBAR1P, HCP1P, WTABLE, FTEMP,
4 EVAPC, EVAPCG, EVAPG, EVAPCS, EVPCSG, EVAPGS,
5 GSNOWC, GSNOWG, GZEROC, GZEROG, QMELTC, QMELTG,
6 ST, SU, SV, SQ, CDH, CDM,
7 TSURF, QSENS, QEVAP, QLWAVG, ILMO, H,
8 FSGV, FSGS, FSGG, FLGV, FLGS, FLGG,
9 HFSC, HFSS, HFSG, HEVC, HEVS, HEVG,
A HMFC, EVPPOT, ACOND, DRAG, UE, FVAP,
B THLIQ, THICE, TBAR, ZPOND, TPOND,
C THPOR, THLMIN, THLRET, THFC, HCPS, TCS,
D TA, RHOSNO, TSNOW, ZSNOW, TCAN,
E FC, FCS, DELZW, ZBOTW, GZROCS, GZROGS,
F ISAND, ILG, IL1, IL2, JL, IG,
G FVEG, TCSAT )
C
C * CALCULATIONS FOR CANOPY OVER SNOW.
C
IF(NLANDCS.GT.0) THEN
DO 90 I=IL1,IL2
IF(FCS(I).GT.0.) THEN
ZOM(I)=EXP(ZOMLCS(I))
ZOH(I)=EXP(ZOELCS(I))
IF(IZREF.EQ.1) THEN
ZRSLDM(I)=ZREFM(I)
ZRSLDH(I)=ZREFH(I)
ZRSLFM(I)=ZREFM(I)-ZOM(I)-DISPS(I)
ZRSLFH(I)=ZREFH(I)-ZOM(I)-DISPS(I)
ZDSLM(I)=ZDIAGM(I)-ZOM(I)-DISPS(I)
ZDSLH(I)=ZDIAGH(I)-ZOM(I)-DISPS(I)
ELSE
ZRSLDM(I)=ZREFM(I)+ZOM(I)
ZRSLDH(I)=ZREFH(I)+ZOM(I)
ZRSLFM(I)=ZREFM(I)-DISPS(I)
ZRSLFH(I)=ZREFH(I)-DISPS(I)
ZDSLM(I)=ZDIAGM(I)-DISPS(I)
ZDSLH(I)=ZDIAGH(I)-DISPS(I)
ENDIF
endif
90 continue
do 100 I=IL1,IL2
IF(FCS(I).GT.0.) then
ZOSCLM(I)=ZOM(I)/ZRSLDM(I)
ZOSCLH(I)=ZOH(I)/ZRSLDH(I)
TPOTA(I)=TA(I)+ZRSLFM(I)*G/SPHAIR
TVIRTA(I)=TPOTA(I)*(1.0+0.61*QA(I))
VAC(I)=VA(I)*(LOG(10.0*ZOM(I)-DISPS(I))-ZOMLCS(I))/
1 (LOG(ZRSLDM(I)-DISPS(I))-ZOMLCS(I))
CRIB(I)=-G*(ZRSLDM(I)-DISPS(I))/(TVIRTA(I)*
1 VA(I)**2)
DRAG(I)=DRAG(I)+FCS(I)*(VKC/(LOG(ZRSLDM(I)-DISPS(I))-
1 ZOMLCS(I)))**2
ENDIF
100 CONTINUE
C
CALL CWCALC(TCANS,RAICNS,SNOCNS,CHCAPS,HMFC,HTCC,
1 FCS,CMASCS,ILG,IL1,IL2,JL)
CALL TSPREP(A1,A2,A3,B1,B2,B3,C2,C3,D3,GDENOM,GCOEFF,
1 GCONST,CPHCHG,TSTART,IWATER,
2 TBAR,TCTOP,TCBOT,FCS,ZPOND,ZSNOW,TSNOW,TCSNOW,
3 TBAR1P,ILG,IL1,IL2,JL,IG )
ISNOW=1
CALL TSOLVC(ISNOW,FCS,
1 QSWX,QSWNC,QSWNG,QLWX,QLWOC,QLWOG,QTRANS,
2 QSENSX,QSENSC,QSENSG,QEVAPX,QEVAPC,QEVAPG,EVAPCS,
3 EVPCSG,TCANS,QCANX,TSURX,QSURX,GSNOWC,QPHCHC,
4 QMELTC,RAICNS,SNOCNS,CDHX,CDMX,RIB,TAC,CFLUX,
5 FTEMP,FVAP,ILMOX,UEX,HX,
6 QSWINV,QSWINI,QLWIN,TPOTA,QA,VA,VAC,PADRY,RHOAIR,
7 ALVSCS,ALIRCS,ALVSSN,ALIRSN,TRVSCS,TRIRCS,FSVFS,
8 CRIB,CPHCHC,CPHCHG,CEVAP,TADP,TVIRTA,RCS,DLEAF,
9 AILCNS,ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM,
A FCOR,GCONST,GCOEFF,TSTART,TRSNOW,FSNOWC,FRAINC,
B CHCAPS,CMASCS,IWATER,IEVAP,ITERCT,
C ISLFD,ILW,ILG,IL1,IL2,JL,
D TSTEP,TVIRTC,TVIRTG,EVBETA,XEVAP,EVPWET,Q0SAT,
E RB,RAGINV,RBINV,RBTINV,RBCINV,QAC,TVRTAC,TPOTG,
F RESID,RESIDL,RESIDO,TZEROL,TZEROO,TCANL,TCANP,
G TRTOP,QSTOR,AC,BC,ZOMS,ZOHS,LZZ0,LZZ0T,FM,FH,
H ITER,NITER,KF1,KF2)
CALL TSPOST(TBARCS,GZROCS,G12CS,G23CS,TPNDCS,GSNOWC,TSNOCS,
1 QMELTC,GCONST,GCOEFF,TBAR,TCTOP,TCBOT,
2 HCPC,ZPOND,ZSNOW,TSURX,TBASE,TBAR1P,
3 HCPSNO,QTRANS,A1,A2,A3,B1,B2,B3,C2,C3,D3,
4 FCS,DELZW,ILG,IL1,IL2,JL,IG )
C
C * DIAGNOSTICS.
C
IF(ISLFD.EQ.2) THEN
CALL DIASURFZ(SU,SV,ST,SQ,ILG,UWIND,VWIND,TAC,QAC,
1 ZOM,ZOH,ILMOX,ZRSLFM,HX,UEX,FTEMP,FVAP,
2 ZDSLM,ZDSLH,RADJ,FCS,IL1,IL2)
ENDIF
C
DO 175 I=IL1,IL2
IF(FCS(I).GT.0.) THEN
IF(TAC(I).GE.TFREZ) THEN
CA=17.269
CB=35.86
ELSE
CA=21.874
CB=7.66
ENDIF
WACSAT=0.622*611.0*EXP(CA*(TAC(I)-TFREZ)/
1 (TAC(I)-CB))/PADRY(I)
QACSAT=WACSAT/(1.0+WACSAT)
EVPPOT(I)=EVPPOT(I)+FCS(I)*RHOAIR(I)*CFLUX(I)*
1 (QACSAT-QA(I))
ACOND(I)=ACOND(I)+FCS(I)*CFLUX(I)
H(I)=H(I)+FCS(I)*HX(I)
UE(I)=UE(I)+FCS(I)*UEX(I)
ILMO(I)=ILMO(I)+FCS(I)*ILMOX(I)
CDH (I) =CDH(I)+FCS(I)*CDHX(I)
CDM (I) =CDM(I)+FCS(I)*CDMX(I)
TSURF(I)=TSURF(I)+FCS(I)*TSURX(I)
QSENS(I)=QSENS(I)+FCS(I)*QSENSX(I)
QEVAP(I)=QEVAP(I)+FCS(I)*QEVAPX(I)
QLWAVG(I)=QLWAVG(I)+FCS(I)*QLWX(I)
FSGV(I) =FSGV(I)+FCS(I)*QSWNC(I)
FSGS(I) =FSGS(I)+FCS(I)*QSWNG(I)
FSGG(I) =FSGG(I)+FCS(I)*QTRANS(I)
FLGV(I) =FLGV(I)+FCS(I)*(QLWIN(I)+QLWOG(I)-2.0*
1 QLWOC(I))*(1.0-FSVFS(I))
FLGS(I) =FLGS(I)+FCS(I)*(QLWOC(I)*(1.0-FSVFS(I))+
1 QLWIN(I)*FSVFS(I)-QLWOG(I))
HFSC(I) =HFSC(I)+FCS(I)*QSENSC(I)
HFSS(I) =HFSS(I)+FCS(I)*QSENSG(I)
HEVC(I) =HEVC(I)+FCS(I)*QEVAPC(I)
HEVS(I) =HEVS(I)+FCS(I)*QEVAPG(I)
HMFC(I) =HMFC(I)+FCS(I)*QPHCHC(I)
HTCS(I) =HTCS(I)+FCS(I)*(-GZROCS(I)+
1 QTRANS(I))
HTC(I,1)=HTC(I,1)+FCS(I)*(GZROCS(I)-QTRANS(I)-
1 G12CS(I))
HTC(I,2)=HTC(I,2)+FCS(I)*(G12CS(I)-G23CS(I))
HTC(I,3)=HTC(I,3)+FCS(I)*G23CS(I)
ENDIF
175 CONTINUE
ENDIF
C
C * CALCULATIONS FOR SNOW-COVERED GROUND.
C
IF(NLANDGS.GT.0) THEN
DO 200 I=IL1,IL2
IF(FGS(I).GT.0.) THEN
ZOM(I)=EXP(ZOMLNS(I))
ZOH(I)=EXP(ZOELNS(I))
IF(IZREF.EQ.1) THEN
ZRSLDM(I)=ZREFM(I)
ZRSLDH(I)=ZREFH(I)
ZRSLFM(I)=ZREFM(I)-ZOM(I)
ZRSLFH(I)=ZREFH(I)-ZOM(I)
ZDSLM(I)=ZDIAGM(I)-ZOM(I)
ZDSLH(I)=ZDIAGH(I)-ZOM(I)
ELSE
ZRSLDM(I)=ZREFM(I)+ZOM(I)
ZRSLDH(I)=ZREFH(I)+ZOM(I)
ZRSLFM(I)=ZREFM(I)
ZRSLFH(I)=ZREFH(I)
ZDSLM(I)=ZDIAGM(I)
ZDSLH(I)=ZDIAGH(I)
ENDIF
ZOSCLM(I)=ZOM(I)/ZRSLDM(I)
ZOSCLH(I)=ZOH(I)/ZRSLDH(I)
TPOTA(I)=TA(I)+ZRSLFM(I)*G/SPHAIR
TVIRTA(I)=TPOTA(I)*(1.0+0.61*QA(I))
CRIB(I)=-G*ZRSLDM(I)/(TVIRTA(I)*VA(I)**2)
DRAG(I)=DRAG(I)+FGS(I)*(VKC/(LOG(ZRSLDM(I))-
1 ZOMLNS(I)))**2
ENDIF
200 CONTINUE
C
CALL TSPREP(A1,A2,A3,B1,B2,B3,C2,C3,D3,GDENOM,GCOEFF,
1 GCONST,CPHCHG,TSTART,IWATER,
2 TBAR,TCTOP,TCBOT,FGS,ZPOND,ZSNOW,TSNOW,TCSNOW,
3 TBAR1P,ILG,IL1,IL2,JL,IG )
ISNOW=1
CALL TSOLVE(ISNOW,FGS,
1 QSWX,QLWX,QTRANS,QSENSX,QEVAPX,EVAPGS,
2 TSURX,QSURX,GSNOWG,QMELTG,CDHX,CDMX,RIB,CFLUX,
3 FTEMP,FVAP,ILMOX,UEX,HX,
4 QSWINV,QSWINI,QLWIN,TPOTA,QA,VA,PADRY,RHOAIR,
5 ALVSSN,ALIRSN,CRIB,CPHCHG,CEVAP,TADP,TVIRTA,
6 ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM,FCOR,
7 GCONST,GCOEFF,TSTART,TRSNOW,
8 IWATER,IEVAP,ITERCT,
9 ISLFD,ILW,ILG,IL1,IL2,JL,
A TSTEP,TVIRTS,EVBETA,Q0SAT,RESID,RESIDL,RESIDO,
B TZEROL,TZEROO,TRTOP,AC,BC,ZOMS,ZOHS,LZZ0,LZZ0T,
C FM,FH,ITER,NITER,KF )
CALL TSPOST(TBARGS,GZROGS,G12GS,G23GS,TPNDGS,GSNOWG,TSNOGS,
1 QMELTG,GCONST,GCOEFF,TBAR,TCTOP,TCBOT,
2 HCPG,ZPOND,ZSNOW,TSURX,TBASE,TBAR1P,
3 HCPSNO,QTRANS,A1,A2,A3,B1,B2,B3,C2,C3,D3,
4 FGS,DELZW,ILG,IL1,IL2,JL,IG )
C
C * DIAGNOSTICS.
C
IF(ISLFD.EQ.2) THEN
CALL DIASURFZ(SU,SV,ST,SQ,ILG,UWIND,VWIND,TSURX,QSURX,
1 ZOM,ZOH,ILMOX,ZRSLFM,HX,UEX,FTEMP,FVAP,
2 ZDSLM,ZDSLH,RADJ,FGS,IL1,IL2)
ENDIF
C
DO 275 I=IL1,IL2
IF(FGS(I).GT.0.) THEN
EVPPOT(I)=EVPPOT(I)+FGS(I)*RHOAIR(I)*CFLUX(I)*
1 (QSURX(I)-QA(I))
ACOND(I)=ACOND(I)+FGS(I)*CFLUX(I)
H(I)=H(I)+FGS(I)*HX(I)
UE(I)=UE(I)+FGS(I)*UEX(I)
ILMO(I)=ILMO(I)+FGS(I)*ILMOX(I)
CDH (I) =CDH(I)+FGS(I)*CDHX(I)
CDM (I) =CDM(I)+FGS(I)*CDMX(I)
TSURF(I)=TSURF(I)+FGS(I)*TSURX(I)
QSENS(I)=QSENS(I)+FGS(I)*QSENSX(I)
QEVAP(I)=QEVAP(I)+FGS(I)*QEVAPX(I)
QLWAVG(I)=QLWAVG(I)+FGS(I)*QLWX(I)
FSGS(I) =FSGS(I)+FGS(I)*(QSWX(I)-QTRANS(I))
FSGG(I) =FSGG(I)+FGS(I)*QTRANS(I)
FLGS(I) =FLGS(I)+FGS(I)*(QLWIN(I)-QLWX(I))
HFSS(I) =HFSS(I)+FGS(I)*QSENSX(I)
HEVS(I) =HEVS(I)+FGS(I)*QEVAPX(I)
HTCS(I) =HTCS(I)+FGS(I)*(-GZROGS(I)+
1 QTRANS(I))
HTC(I,1)=HTC(I,1)+FGS(I)*(GZROGS(I)-QTRANS(I)-
1 G12GS(I))
HTC(I,2)=HTC(I,2)+FGS(I)*(G12GS(I)-G23GS(I))
HTC(I,3)=HTC(I,3)+FGS(I)*G23GS(I)
ENDIF
275 CONTINUE
ENDIF
C
C * CALCULATIONS FOR CANOPY OVER BARE GROUND.
C
IF(NLANDC.GT.0) THEN
call vsexp(ZOM(il1),ZOMLNC(il1),il2-il1+1)
call vsexp(ZOH(il1),ZOELNC(il1),il2-il1+1)
DO 300 I=IL1,IL2
IF(FC(I).GT.0.) THEN
c ZOM(I)=EXP(ZOMLNC(I))
c ZOH(I)=EXP(ZOELNC(I))
IF(IZREF.EQ.1) THEN
ZRSLDM(I)=ZREFM(I)
ZRSLDH(I)=ZREFH(I)
ZRSLFM(I)=ZREFM(I)-ZOM(I)-DISP(I)
ZRSLFH(I)=ZREFH(I)-ZOM(I)-DISP(I)
ZDSLM(I)=ZDIAGM(I)-ZOM(I)-DISP(I)
ZDSLH(I)=ZDIAGH(I)-ZOM(I)-DISP(I)
ELSE
ZRSLDM(I)=ZREFM(I)+ZOM(I)
ZRSLDH(I)=ZREFH(I)+ZOM(I)
ZRSLFM(I)=ZREFM(I)-DISP(I)
ZRSLFH(I)=ZREFH(I)-DISP(I)
ZDSLM(I)=ZDIAGM(I)-DISP(I)
ZDSLH(I)=ZDIAGH(I)-DISP(I)
ENDIF
ZOSCLM(I)=ZOM(I)/ZRSLDM(I)
ZOSCLH(I)=ZOH(I)/ZRSLDH(I)
TPOTA(I)=TA(I)+ZRSLFM(I)*G/SPHAIR
TVIRTA(I)=TPOTA(I)*(1.0+0.61*QA(I))
VAC(I)=VA(I)*(LOG(10.0*ZOM(I)-DISP(I))-ZOMLNC(I))/
1 (LOG(ZRSLDM(I)-DISP(I))-ZOMLNC(I))
CRIB(I)=-G*(ZRSLDM(I)-DISP(I))/(TVIRTA(I)*VA(I)**2)
DRAG(I)=DRAG(I)+FC(I)*(VKC/(LOG(ZRSLDM(I)-DISP(I))-
1 ZOMLNC(I)))**2
ENDIF
300 CONTINUE
C
CALL CWCALC(TCANO,RAICAN,SNOCAN,CHCAP,HMFC,HTCC,
1 FC,CMASSC,ILG,IL1,IL2,JL)
CALL TNPREP(A1,A2,B1,B2,C2,GDENOM,GCOEFF,
1 GCONST,CPHCHG,TSTART,IWATER,
2 TBAR,TCTOP,TCBOT,FC,ZPOND,TBAR1P,ISAND,
3 ILG,IL1,IL2,JL,IG )
ISNOW=0
CALL TSOLVC(ISNOW,FC,
1 QSWX,QSWNC,QSWNG,QLWX,QLWOC,QLWOG,QTRANS,
2 QSENSX,QSENSC,QSENSG,QEVAPX,QEVAPC,QEVAPG,EVAPC,
3 EVAPCG,TCANO,QCANX,TSURX,QSURX,GZEROC,QPHCHC,
4 QFREZC,RAICAN,SNOCAN,CDHX,CDMX,RIB,TAC,CFLUX,
5 FTEMP,FVAP,ILMOX,UEX,HX,
6 QSWINV,QSWINI,QLWIN,TPOTA,QA,VA,VAC,PADRY,RHOAIR,
7 ALVSCN,ALIRCN,ALVSG,ALIRG,TRVSCN,TRIRCN,FSVF,
8 CRIB,CPHCHC,CPHCHG,CEVAP,TADP,TVIRTA,RC,DLEAF,
9 AILCAN,ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM,
A FCOR,GCONST,GCOEFF,TSTART,TRSNOW,FSNOWC,FRAINC,
B CHCAP,CMASSC,IWATER,IEVAP,ITERCT,
C ISLFD,ILW,ILG,IL1,IL2,JL,
D TSTEP,TVIRTC,TVIRTG,EVBETA,XEVAP,EVPWET,Q0SAT,
E RB,RAGINV,RBINV,RBTINV,RBCINV,QAC,TVRTAC,TPOTG,
F RESID,RESIDL,RESIDO,TZEROL,TZEROO,TCANL,TCANP,
G TRTOP,QSTOR,AC,BC,ZOMS,ZOHS,LZZ0,LZZ0T,FM,FH,
H ITER,NITER,KF1,KF2)
CALL TNPOST(TBARC,G12C,G23C,TPONDC,GZEROC,QFREZC,GCONST,
1 GCOEFF,TBAR,TCTOP,TCBOT,HCPC,ZPOND,TSURX,
2 TBASE,TBAR1P,A1,A2,B1,B2,C2,FC,IWATER,
3 DELZW,ILG,IL1,IL2,JL,IG )
C
C * DIAGNOSTICS.
C
IF(ISLFD.EQ.2) THEN
CALL DIASURFZ(SU,SV,ST,SQ,ILG,UWIND,VWIND,TAC,QAC,
1 ZOM,ZOH,ILMOX,ZRSLFM,HX,UEX,FTEMP,FVAP,
2 ZDSLM,ZDSLH,RADJ,FC,IL1,IL2)
ENDIF
C
DO 375 I=IL1,IL2
IF(FC(I).GT.0.) THEN
IF(TAC(I).GE.TFREZ) THEN
CA=17.269
CB=35.86
ELSE
CA=21.874
CB=7.66
ENDIF
WACSAT=0.622*611.0*EXP(CA*(TAC(I)-TFREZ)/
1 (TAC(I)-CB))/PADRY(I)
QACSAT=WACSAT/(1.0+WACSAT)
EVPPOT(I)=EVPPOT(I)+FC(I)*RHOAIR(I)*CFLUX(I)*
1 (QACSAT-QA(I))
ACOND(I)=ACOND(I)+FC(I)*CFLUX(I)
H(I)=H(I)+FC(I)*HX(I)
UE(I)=UE(I)+FC(I)*UEX(I)
ILMO(I)=ILMO(I)+FC(I)*ILMOX(I)
CDH (I) =CDH(I)+FC(I)*CDHX(I)
CDM (I) =CDM(I)+FC(I)*CDMX(I)
TSURF(I)=TSURF(I)+FC(I)*TSURX(I)
QSENS(I)=QSENS(I)+FC(I)*QSENSX(I)
QEVAP(I)=QEVAP(I)+FC(I)*QEVAPX(I)
QLWAVG(I)=QLWAVG(I)+FC(I)*QLWX(I)
FSGV(I) =FSGV(I)+FC(I)*QSWNC(I)
FSGG(I) =FSGG(I)+FC(I)*QSWNG(I)
FLGV(I) =FLGV(I)+FC(I)*(QLWIN(I)+QLWOG(I)-2.0*
1 QLWOC(I))*(1.0-FSVF(I))
FLGG(I) =FLGG(I)+FC(I)*(FSVF(I)*QLWIN(I)+
1 (1.0-FSVF(I))*QLWOC(I)-QLWOG(I))
HFSC(I) =HFSC(I)+FC(I)*QSENSC(I)
HFSG(I) =HFSG(I)+FC(I)*QSENSG(I)
HEVC(I) =HEVC(I)+FC(I)*QEVAPC(I)
HEVG(I) =HEVG(I)+FC(I)*QEVAPG(I)
HMFC(I) =HMFC(I)+FC(I)*QPHCHC(I)
HTC(I,1)=HTC(I,1)+FC(I)*(-G12C(I))
HTC(I,2)=HTC(I,2)+FC(I)*(G12C(I)-G23C(I))
HTC(I,3)=HTC(I,3)+FC(I)*G23C(I)
ENDIF
375 CONTINUE
ENDIF
C
C * CALCULATIONS FOR BARE GROUND.
C
IF(NLANDG.GT.0) THEN
DO 400 I=IL1,IL2
IF(FG(I).GT.0.) THEN
ZOM(I)=EXP(ZOMLNG(I))
ZOH(I)=EXP(ZOELNG(I))
IF(IZREF.EQ.1) THEN
ZRSLDM(I)=ZREFM(I)
ZRSLDH(I)=ZREFH(I)
ZRSLFM(I)=ZREFM(I)-ZOM(I)
ZRSLFH(I)=ZREFH(I)-ZOM(I)
ZDSLM(I)=ZDIAGM(I)-ZOM(I)
ZDSLH(I)=ZDIAGH(I)-ZOM(I)
ELSE
ZRSLDM(I)=ZREFM(I)+ZOM(I)
ZRSLDH(I)=ZREFH(I)+ZOM(I)
ZRSLFM(I)=ZREFM(I)
ZRSLFH(I)=ZREFH(I)
ZDSLM(I)=ZDIAGM(I)
ZDSLH(I)=ZDIAGH(I)
ENDIF
ZOSCLM(I)=ZOM(I)/ZRSLDM(I)
ZOSCLH(I)=ZOH(I)/ZRSLDH(I)
TPOTA(I)=TA(I)+ZRSLFM(I)*G/SPHAIR
TVIRTA(I)=TPOTA(I)*(1.0+0.61*QA(I))
CRIB(I)=-G*ZRSLDM(I)/(TVIRTA(I)*VA(I)**2)
DRAG(I)=DRAG(I)+FG(I)*(VKC/(LOG(ZRSLDM(I))-
1 ZOMLNG(I)))**2
ENDIF
400 CONTINUE
C
CALL TNPREP(A1,A2,B1,B2,C2,GDENOM,GCOEFF,
1 GCONST,CPHCHG,TSTART,IWATER,
2 TBAR,TCTOP,TCBOT,FG,ZPOND,TBAR1P,ISAND,
3 ILG,IL1,IL2,JL,IG )
ISNOW=0
CALL TSOLVE(ISNOW,FG,
1 QSWX,QLWX,QTRANS,QSENSX,QEVAPX,EVAPG,
2 TSURX,QSURX,GZEROG,QFREZG,CDHX,CDMX,RIB,CFLUX,
3 FTEMP,FVAP,ILMOX,UEX,HX,
4 QSWINV,QSWINI,QLWIN,TPOTA,QA,VA,PADRY,RHOAIR,
5 ALVSG,ALIRG,CRIB,CPHCHG,CEVAP,TADP,TVIRTA,
6 ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM,FCOR,
7 GCONST,GCOEFF,TSTART,TRSNOW,
8 IWATER,IEVAP,ITERCT,
9 ISLFD,ILW,ILG,IL1,IL2,JL,
A TSTEP,TVIRTS,EVBETA,Q0SAT,RESID,RESIDL,RESIDO,
B TZEROL,TZEROO,TRTOP,AC,BC,ZOMS,ZOHS,LZZ0,LZZ0T,
C FM,FH,ITER,NITER,KF )
CALL TNPOST(TBARG,G12G,G23G,TPONDG,GZEROG,QFREZG,GCONST,
1 GCOEFF,TBAR,TCTOP,TCBOT,HCPG,ZPOND,TSURX,
2 TBASE,TBAR1P,A1,A2,B1,B2,C2,FG,IWATER,
3 DELZW,ILG,IL1,IL2,JL,IG )
C
C * DIAGNOSTICS.
C
IF(ISLFD.EQ.2) THEN
CALL DIASURFZ(SU,SV,ST,SQ,ILG,UWIND,VWIND,TSURX,QSURX,
1 ZOM,ZOH,ILMOX,ZRSLFM,HX,UEX,FTEMP,FVAP,
2 ZDSLM,ZDSLH,RADJ,FG,IL1,IL2)
ENDIF
C
DO 475 I=IL1,IL2
IF(FG(I).GT.0.) THEN
EVPPOT(I)=EVPPOT(I)+FG(I)*RHOAIR(I)*CFLUX(I)*
1 (QSURX(I)-QA(I))
ACOND(I)=ACOND(I)+FG(I)*CFLUX(I)
H(I)=H(I)+FG(I)*HX(I)
UE(I)=UE(I)+FG(I)*UEX(I)
ILMO(I)=ILMO(I)+FG(I)*ILMOX(I)
CDH (I) =CDH(I)+FG(I)*CDHX(I)
CDM (I) =CDM(I)+FG(I)*CDMX(I)
TSURF(I)=TSURF(I)+FG(I)*TSURX(I)
QSENS(I)=QSENS(I)+FG(I)*QSENSX(I)
QEVAP(I)=QEVAP(I)+FG(I)*QEVAPX(I)
QLWAVG(I)=QLWAVG(I)+FG(I)*QLWX(I)
FSGG(I) =FSGG(I)+FG(I)*QSWX(I)
FLGG(I) =FLGG(I)+FG(I)*(QLWIN(I)-QLWX(I))
HFSG(I) =HFSG(I)+FG(I)*QSENSX(I)
HEVG(I) =HEVG(I)+FG(I)*QEVAPX(I)
HTC(I,1)=HTC(I,1)+FG(I)*(-G12G(I))
HTC(I,2)=HTC(I,2)+FG(I)*(G12G(I)-G23G(I))
HTC(I,3)=HTC(I,3)+FG(I)*G23G(I)
ENDIF
475 CONTINUE
ENDIF
C
C * ADDITIONAL DIAGNOSTIC VARIABLES.
C
DO 500 I=IL1,IL2
GT(I)=(QLWAVG(I)/SBC)**0.25
TFLUX(I)=-QSENS(I)/(RHOAIR(I)*SPHAIR)
EVAP(I)=FCS(I)*(EVAPCS(I)+EVPCSG(I)) + FGS(I)*EVAPGS(I) +
1 FC (I)*(EVAPC (I)+EVAPCG(I)) + FG (I)*EVAPG(I)
EVAP(I)=EVAP(I)*RHOW
QFLUX(I)=-EVAP(I)/RHOAIR(I)
IF(EVPPOT(I).NE.0.0) THEN
EVAPB(I)=EVAP(I)/EVPPOT(I)
ELSE
EVAPB(I)=0.0
ENDIF
IF(CDH(I).GT.0.0) THEN
QG(I)=EVAP(I)/(RHOAIR(I)*CDH(I)*VA(I))+QA(I)
ELSE
QG(I)=0.0
ENDIF
500 CONTINUE
C
RETURN
END