SUBROUTINE TSOLVC(ISNOW,FI, 2,6
1 QSWNET,QSWNC,QSWNG,QLWOUT,QLWOC,QLWOG,QTRANS,
2 QSENS,QSENSC,QSENSG,QEVAP,QEVAPC,QEVAPG,EVAPC,
3 EVAPG,TCAN,QCAN,TZERO,QZERO,GZERO,QMELTC,
4 QMELTG,RAICAN,SNOCAN,CDH,CDM,RIB,TAC,CFLUX,
5 FTEMP,FVAP,ILMO,UE,H,
6 QSWINV,QSWINI,QLWIN,TPOTA,QA,VA,VAC,PADRY,RHOAIR,
7 ALVISC,ALNIRC,ALVISG,ALNIRG,TRVISC,TRNIRC,FSVF,
8 CRIB,CPHCHC,CPHCHG,CEVAP,TADP,TVIRTA,RC,DLEAF,
9 AILCAN,ZOSCLH,ZOSCLM,ZRSLFH,ZRSLFM,ZOH,ZOM,
A FCOR,GCONST,GCOEFF,TGND,TRSNOW,FSNOWC,FRAINC,
B CHCAP,CMASS,IWATER,IEVAP,ITERCT,
C ISLFD,ILW,ILG,IL1,IL2,JL,
D TSTEP,TVIRTC,TVIRTG,EVBETA,XEVAP,EVPWET,Q0SAT,
E RB,RAGINV,RBINV,XEVAPM,RBCINV,QAC,TVRTAC,TPOTG,
F RESID,IEVAPC,DCFLXM,WC,DRAGIN,CFLUXM,TCANO,
G TRTOP,QSTOR,A,B,ZOMS,ZOHS,LZZ0,LZZ0T,FM,FH,
H ITER,NITER,KF1,KF2 )
C
C * AUG 19/04 - Y.DELAGE. REGROUP COMMON BLOCKS
C * MAKE DECLARATIONS EXPLICIT
C * AUG 05/03 - Y.DELAGE. USE THE CANOPY AIR RESISTANCE TO CALCULATE A
C * ROUGHNESS LENGTH FOR TEMPERATURE AND HUMIDITY.
C * REPLACE SECANT METHOD BY NEWTON-RAPHSON SCHEME
C * FOR BOTH ITERATION LOOPS.
C * LIMIT NUMBER OF ITERATIONS (ITERMX) TO 5 AND
C * APPLY CORRECTIONS IF RESIDUE REMAINS.
C * NOV 07/02 - Y.DELAGE/D.VERSEGHY. NEW CALL TO FLXSURFZ; VIRTUAL
C * AND POTENTIAL TEMPERATURE CORRECTIONS.
C * NOV 01/02 - P.BARTLETT. MODIFICATIONS TO CALCULATIONS OF QAC
C * AND RB.
C * JUL 26/02 - D.VERSEGHY. SHORTENED CLASS4 COMMON BLOCK.
C * MAR 28/02 - D.VERSEGHY. STREAMLINED SUBROUTINE CALL.
C * MAR 10/02 - M.LAZARE. VECTORIZE LOOP 650 BY SPLITTING INTO TWO.
C * JAN 18/02 - P.BARTLETT/D.VERSEGHY. NEW "BETA" FORMULATION FOR
C * BARE SOIL EVAPORATION BASED ON LEE AND
C * PIELKE.
C * APR 11/01 - M.LAZARE. SHORTENED "CLASS2" COMMON BLOCK.
C * OCT 06/00 - D.VERSEGHY. CONDITIONAL "IF" IN ITERATION SEQUENCE
C * TO AVOID DIVIDE BY ZERO.
C * DEC 16/99 - A.WU/D.VERSEGHY. REVISED CANOPY TURBULENT FLUX
C * FORMULATION: ADD PARAMETRIZATION
C * OF CANOPY AIR TEMPERATURE.
C * DEC 07/99 - A.WU/D.VERSEGHY. NEW SOIL EVAPORATION FORMULATION.
C * JUL 24/97 - D.VERSEGHY. CLASS - VERSION 2.7.
C * REPLACE BISECTION METHOD IN SURFACE
C * TEMPERATURE ITERATION SCHEME WITH
C * SECANT METHOD FOR FIRST TEN ITERATIONS.
C * PASS QZERO,QA,ZOMS,ZOHS TO REVISED
C * DRCOEF (ZOMS AND ZOHS ALSO NEW WORK ARRAYS
C * PASSED TO THIS ROUTINE).
C * JUN 20/97 - D.VERSEGHY. PASS IN NEW "CLASS4" COMMON BLOCK.
C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5.
C * COMPLETION OF ENERGY BALANCE
C * DIAGNOSTICS. ALSO, PASS SWITCH "ILW"
C * THROUGH SUBROUTINE CALL, SPECIFYING
C * WHETHER QLWIN REPRESENTS INCOMING
C * (ILW=1) OR NET (ILW=2) LONGWAVE
C * RADIATION ABOVE THE GROUND.
C * NOV 30/94 - M.LAZARE. CLASS - VERSION 2.3.
C * NEW DRAG COEFFICIENT AND RELATED FIELDS,
C * NOW DETERMINED IN ROUTINE "DRCOEF".
C * OCT 04/94 - D.VERSEGHY. CHANGE "CALL ABORT" TO "CALL XIT" TO
C * ENABLE RUNNING ON PCS.
C * JAN 24/94 - M.LAZARE. UNFORMATTED I/O COMMENTED OUT IN LOOPS
C * 200 AND 600.
C * JUL 29/93 - D.VERSEGHY. CLASS - VERSION 2.2.
C * ADD TRANSMISSION THROUGH SNOWPACK TO
C * "QSWNET" FOR DIAGNOSTIC PURPOSES.
C * OCT 15/92 - D.VERSEGHY/M.LAZARE. CLASS - VERSION 2.1.
C * REVISED AND VECTORIZED CODE
C * FOR MODEL VERSION GCM7.
C * AUG 12/91 - D.VERSEGHY. ITERATIVE TEMPERATURE CALCULATIONS
C * FOR VEGETATION CANOPY AND UNDERLYING
C * SURFACE.
C
IMPLICIT NONE
C * OUTPUT ARRAYS.
C
REAL QSWNET(ILG), QSWNC (ILG), QSWNG (ILG), QLWOUT(ILG),
1 QLWOC (ILG), QLWOG (ILG), QTRANS(ILG), QSENS (ILG),
2 QSENSC(ILG), QSENSG(ILG), QEVAP (ILG), QEVAPC(ILG),
3 QEVAPG(ILG), EVAPC (ILG), EVAPG (ILG), TCAN (ILG),
4 QCAN (ILG), TZERO (ILG), QZERO (ILG), GZERO (ILG),
5 QMELTC(ILG), QMELTG(ILG), RAICAN(ILG), SNOCAN(ILG),
6 CDH (ILG), CDM (ILG), RIB (ILG), TAC (ILG),
7 CFLUX (ILG), FTEMP (ILG), FVAP (ILG), ILMO (ILG),
8 UE (ILG), H (ILG)
C
C * INPUT ARRAYS.
C
REAL FI (ILG), QSWINV(ILG), QSWINI(ILG), QLWIN (ILG),
1 TPOTA (ILG), QA (ILG), VA (ILG), VAC (ILG),
2 PADRY (ILG), RHOAIR(ILG), ALVISC(ILG), ALNIRC(ILG),
3 ALVISG(ILG), ALNIRG(ILG), TRVISC(ILG), TRNIRC(ILG),
4 FSVF (ILG), CRIB (ILG), CPHCHC(ILG), CPHCHG(ILG),
5 CEVAP (ILG), TADP (ILG), TVIRTA(ILG), RC (ILG),
6 DLEAF (ILG), AILCAN(ILG), ZOSCLH(ILG), ZOSCLM(ILG),
7 ZRSLFH(ILG), ZRSLFM(ILG), ZOH (ILG), ZOM (ILG),
8 FCOR (ILG), GCONST(ILG), GCOEFF(ILG), TGND (ILG),
9 TRSNOW(ILG), FSNOWC(ILG), FRAINC(ILG),
A CHCAP (ILG), CMASS (ILG)
C
INTEGER IWATER(ILG), IEVAP (ILG),
1 ITERCT(ILG,6,50)
C
C * INTERNAL WORK ARRAYS.
C
REAL TSTEP (ILG), TVIRTC(ILG), TVIRTG(ILG),
1 EVBETA(ILG), XEVAP (ILG), EVPWET(ILG), Q0SAT (ILG),
2 RB (ILG), RAGINV(ILG), RBINV (ILG), XEVAPM(ILG),
3 RBCINV(ILG), QAC (ILG), TVRTAC(ILG), TPOTG (ILG),
4 RESID (ILG), IEVAPC(ILG), DCFLXM(ILG),
5 WC (ILG), DRAGIN(ILG), CFLUXM(ILG), TCANO (ILG),
6 TRTOP (ILG), QSTOR (ILG), A (ILG), B (ILG),
7 ZOMS (ILG), ZOHS (ILG), LZZ0 (ILG), LZZ0T (ILG),
8 FM (ILG), FH (ILG)
C
INTEGER ITER (ILG), NITER (ILG),
1 KF1 (ILG), KF2 (ILG)
C
REAL YEVAP,DXEVAP,qswnvg,qswnig,qswnvc,qswnic,ca,cb,wzero,dq0dt,
1 drdt0,tzerot,qevapt,bowen,wcan,dcflux,tcant,qevapct,hfrez,
2 hconv,rconv,hmelt,hcool,sconv,hwarm,TBETA,rat
INTEGER I,IL1,IL2,ILG,ITERMX,isnow,islfd,ilw,jl,numit,ibad,nit
logical prnt
#include "class_com.cdk"
C
DATA ITERMX /5/
DATA TBETA /2.5/
c data prnt /.true./
data prnt /.false./
if(prnt) then
print*,'fi',fi
print*,'TPOTA',TPOTA
print*,'QSWINV',QSWINV
print*,'QSWINI',QSWINI
print*,'QLWIN',QLWIN
print*,'QA',QA
print*,'VA',VA
print*,'PADRY',PADRY
print*,'RHOAIR',RHOAIR
print*,'CPHCHC',CPHCHC
print*,'CEVAP',CEVAP
print*,'TADP',TADP
print*,'TVIRTA',TVIRTA
print*,'ZRSLFH',ZRSLFH
print*,'ZRSLFM',ZRSLFM
print*,'ZOH',ZOH
print*,'ZOM',ZOM
print*,'FCOR',FCOR
print*,'GCONST',GCONST
print*,'GCOEFF',GCOEFF
print*,'TGND',TGND
print*,'TRSNOW',TRSNOW
print*,'ISLFD,ILW,ILG,IL1,IL2,JL',ISLFD,ILW,ILG,IL1,IL2,JL
endif
C-----------------------------------------------------------------------
C * INITIALIZATION AND PRE-ITERATION SEQUENCE.
C
DO 50 I=IL1,IL2
ITER(I)=2
IF(FI(I).GT.0.) THEN
IF(ISNOW.EQ.0) THEN
TRTOP(I)=0.
ELSE
TRTOP(I)=TRSNOW(I)
ENDIF
QSWNVG=QSWINV(I)*TRVISC(I)*(1.0-ALVISG(I))
QSWNIG=QSWINI(I)*TRNIRC(I)*(1.0-ALNIRG(I))
QSWNVC=QSWINV(I)*(1.0-ALVISC(I))-QSWNVG
QSWNIC=QSWINI(I)*(1.0-ALNIRC(I))-QSWNIG
QSWNG(I)=QSWNVG+QSWNIG
QSWNC(I)=QSWNVC+QSWNIC
QTRANS(I)=QSWNG(I)*TRTOP(I)
QSWNG(I)=QSWNG(I)-QTRANS(I)
QMELTC(I)=0.0
QMELTG(I)=0.0
C
IF(ABS(TCAN(I)).LT.1.0E-8) TCAN(I)=TPOTA(I)
TCANO(I)=TCAN(I)
TAC(I)=(1.0-FSVF(I))*TCAN(I)+FSVF(I)*TPOTA(I)
QAC(I)=QA(I)
QCAN(I)=QA(I)
TVRTAC(I)=TAC(I)*(1.0+0.61*QAC(I))
TVIRTC(I)=TVRTAC(I)
TZERO(I)=TGND(I)
TSTEP(I)=5.0
C
RBINV(I)=(TBETA/307.0)*SQRT(VAC(I)/DLEAF(I))
1 *2.0*MAX(1.0,AILCAN(I))
QLWOC(I)=SBC*TCAN(I)*TCAN(I)*TCAN(I)*TCAN(I)
IF(TAC(I).GE.TFREZ) THEN
CA=17.269
CB=35.86
ELSE
CA=21.874
CB=7.66
ENDIF
RESID(I)=999999.
ITER(I)=1
NITER(I)=1
IF(ISNOW.EQ.1) THEN
KF1(I)=1
KF2(I)=2
ELSE
KF1(I)=4
KF2(I)=5
ENDIF
ENDIF
50 CONTINUE
C
C * ITERATION FOR SURFACE TEMPERATURE OF GROUND UNDER CANOPY.
C * LOOP IS REPEATED UNTIL SOLUTIONS HAVE BEEN FOUND FOR ALL POINTS
C * ON THE CURRENT LATITUDE CIRCLE(S).
C
100 CONTINUE
C
NUMIT=0
DO 150 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
IF(TZERO(I).GE.TFREZ) THEN
A(I)=17.269
B(I)=35.86
ELSE
A(I)=21.874
B(I)=7.66
ENDIF
WZERO=0.622*611.0*EXP(A(I)*(TZERO(I)-TFREZ)/
1 (TZERO(I)-B(I)))/PADRY(I)
Q0SAT(I)=WZERO/(1.0+WZERO)
IF(IWATER(I).GT.0 .OR. ISNOW.EQ.1 .OR. QA(I).GT.Q0SAT(I))
1 THEN
EVBETA(I)=1.0
QZERO(I)=Q0SAT(I)
ELSEIF(IEVAP(I).GT.0.) THEN
EVBETA(I)=CEVAP(I)
QZERO(I)=EVBETA(I)*Q0SAT(I)+(1.0-EVBETA(I))*QA(I)
IF(QZERO(I).LT.QA(I)) THEN
EVBETA(I)=0.0
QZERO(I)=QA(I)
ENDIF
ELSE
EVBETA(I)=0.0
QZERO(I)=QA(I)
ENDIF
DQ0DT=-WZERO*A(I)*(B(I)-TFREZ)/((TZERO(I)-B(I))*
1 (1+WZERO))**2*EVBETA(I)
QLWOG(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I)
GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I)
C
TPOTG(I)=TZERO(I)-8.0*ZOM(I)*G/SPHAIR
TVIRTG(I)=TPOTG(I)*(1.0+0.61*QZERO(I))
IF(TVIRTG(I).GT.TVRTAC(I)+1.) THEN
RAGINV(I)=1.9E-3*(TVIRTG(I)-TVRTAC(I))**0.333333
DRAGIN(I)=0.333*1.9E-3*(TVIRTG(I)-TVIRTC(I))**(-.667)
ELSEIF(TVIRTG(I).GT.TVIRTC(I)) THEN
RAGINV(I)=1.9E-3*(TVIRTG(I)-TVIRTC(I))
DRAGIN(I)=1.9E-3
ELSE
RAGINV(I)=0.0
DRAGIN(I)=0.0
ENDIF
QSENSG(I)=RHOAIR(I)*SPHAIR*(TPOTG(I)-TAC(I))*RAGINV(I)
EVAPG (I)=RHOAIR(I)*(QZERO(I)-QA(I))*RAGINV(I)
QEVAPG(I)=CPHCHG(I)*EVAPG(I)
C
IF(ILW.EQ.2) THEN
RESID(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 (QLWOC(I)-QLWOG(I))-QSENSG(I)-QEVAPG(I)-GZERO(I)
ELSE
RESID(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 QLWOC(I)-QLWOG(I)-QSENSG(I)-QEVAPG(I)-GZERO(I)
ENDIF
IF(ABS(RESID(I)).LT.1.0) ITER(I)=0
DRDT0=-4*SBC*TZERO(I)**3*(1.0-FSVF(I)*(ILW-1))
1 -GCOEFF(I)-RHOAIR(I)*SPHAIR*
2 (RAGINV(I)+(TPOTG(I)-TAC(I))*DRAGIN(I))-
3 CPHCHG(I)*RHOAIR(I)*(DQ0DT*RAGINV(I)
4 +(QZERO(I)-QA(I))*DRAGIN(I))
TSTEP(I)=-RESID(I)/DRDT0
ENDIF
C
IF(FI(I).GT.0. .AND. NITER(I).EQ.ITERMX) ITER(I)=-1
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
TZERO(I)=TZERO(I)+TSTEP(I)
NITER(I)=NITER(I)+1
NUMIT=NUMIT+1
ENDIF
150 CONTINUE
C
IF(NUMIT.GT.0) GO TO 100
C
C * IF CONVERGENCE HAS NOT BEEN REACHED, CALCULATE TEMPERATURE AND
C * FLUXES ASSUMING NEUTRAL STABILITY AND USING BOWEN RATIO APPROACH
C
DO 195 I=IL1,IL2
IF(ITER(I).EQ.-1) THEN
TZEROT=TVIRTC(I)/(1.0+0.61*QZERO(I))
IF(TZEROT.LT.TZERO(I)+5..AND.ABS(RESID(I)).GT.15.) THEN
TZERO(I)=TZEROT
IF(TZERO(I).GE.TFREZ) THEN
A(I)=17.269
B(I)=35.86
ELSE
A(I)=21.874
B(I)=7.66
ENDIF
WZERO=0.622*611.0*EXP(A(I)*(TZERO(I)-TFREZ)/
1 (TZERO(I)-B(I)))/PADRY(I)
Q0SAT(I)=WZERO/(1.0+WZERO)
QZERO(I)=EVBETA(I)*Q0SAT(I)+(1-EVBETA(I))*QA(I)
GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I)
QLWOG(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I)
IF(ILW.EQ.2) THEN
RESID(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 (QLWOC(I)-QLWOG(I))-GZERO(I)
ELSE
RESID(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 QLWOC(I)-QLWOG(I)-GZERO(I)
ENDIF
QEVAPT=CPHCHG(I)*(QZERO(I)-QAC(I))
BOWEN=SPHAIR*(TZERO(I)-TAC(I))/
1 SIGN(MAX(ABS(QEVAPT),1.E-6),QEVAPT)
QEVAPG(I)=RESID(I)/SIGN(MAX(ABS(1+BOWEN),0.1),1+BOWEN)
QSENSG(I)=RESID(I)-QEVAPG(I)
RESID(I)=0.
EVAPG(I)=QEVAPG(I)/CPHCHG(I)
ENDIF
ENDIF
195 CONTINUE
IBAD=0
C
DO 200 I=IL1,IL2
c IF(FI(I).GT.0. .AND. ITER(I).EQ.-1) THEN
c WRITE(6,6250) I,JL,NITER(I),RESID(I),TZERO(I),RIB(I)
c6250 FORMAT('0SUBCAN ITERATION LIMIT',3X,3I3,3(F8.2,E12.4))
c ENDIF
IF(FI(I).GT.0.) THEN
IF(TZERO(I).LT.173.16 .OR.TZERO(I).GT.373.16) IBAD=I
ENDIF
200 CONTINUE
C
IF(IBAD.NE.0) THEN
WRITE(6,6370) IBAD,JL,TZERO(IBAD),NITER(IBAD),ISNOW
6370 FORMAT('0BAD GROUND ITERATION TEMPERATURE',3X,2I3,F16.2,2I4)
WRITE(6,6380) QSWNG(IBAD),FSVF(IBAD),QLWIN(IBAD),QLWOC(IBAD),
1 QLWOG(IBAD),QSENSG(IBAD),QEVAPG(IBAD),GZERO(IBAD)
WRITE(6,6380) TCAN(IBAD)
CALL XIT('TSOLVC',-1)
ENDIF
C
C * POST-ITERATION CLEAN-UP.
C
DO 250 I=IL1,IL2
IF(FI(I).GT.0.) THEN
QSENSG(I)=QSENSG(I)+RESID(I)*0.5
GZERO(I)=GZERO(I)+RESID(I)*0.5
IF((IWATER(I).EQ.1 .AND. TZERO(I).LT.TFREZ) .OR.
1 (IWATER(I).EQ.2 .AND. TZERO(I).GT.TFREZ)) THEN
TZERO(I)=TFREZ
WZERO=0.622*611.0/PADRY(I)
QZERO(I)=WZERO/(1.0+WZERO)
EVBETA(I)=1.0
QLWOG(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I)
GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I)
C
TPOTG(I)=TZERO(I)-8.0*ZOM(I)*G/SPHAIR
TVIRTG(I)=TPOTG(I)*(1.0+0.61*QZERO(I))
IF(TVIRTG(I).GT.TVRTAC(I)) THEN
RAGINV(I)=1.9E-3*(TVIRTG(I)-TVRTAC(I))**0.333333
QSENSG(I)=RHOAIR(I)*SPHAIR*(TPOTG(I)-TAC(I))*
1 RAGINV(I)
EVAPG (I)=RHOAIR(I)*(QZERO(I)-QA(I))*RAGINV(I)
IF(EVAPG(I).LT.0. .AND. TZERO(I).GE.TADP(I))
1 EVAPG(I)=0.
ELSE
RAGINV(I)=0.0
QSENSG(I)=0.0
EVAPG (I)=0.0
ENDIF
QEVAPG(I)=CPHCHG(I)*EVAPG(I)
C
IF(ILW.EQ.2) THEN
QMELTG(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 (QLWOC(I)-QLWOG(I))-QSENSG(I)-QEVAPG(I)-GZERO(I)
ELSE
QMELTG(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 QLWOC(I)-QLWOG(I)-QSENSG(I)-QEVAPG(I)-GZERO(I)
ENDIF
RESID(I)=0.0
ENDIF
ENDIF
250 CONTINUE
C
C * GROUND ITERATION COUNT, AND PRE-ITERATION SEQUENCE FOR
C * VEGETATION CANOPY.
C
DO 300 I=IL1,IL2
IF(FI(I).GT.0.) THEN
ITERCT(I,KF2(I),NITER(I))=ITERCT(I,KF2(I),NITER(I))+1
ITER(I)=1
NITER(I)=1
RAT=EXP(VKC**2*VA(I)/(RBINV(I)*LOG(ZOSCLM(I))))
ZOSCLH(I)=MAX(ZOSCLH(I)*RAT,1.E-6)
ZOH(I)=MAX(ZOH(I)*RAT,1.E-4)
TSTEP(I)=5.0
RESID(I)=999999.
CFLUXM(I)=0.
DCFLXM(I)=0.
ENDIF
300 CONTINUE
C
C * ITERATION FOR CANOPY TEMPERATURE.
C * LOOP IS REPEATED UNTIL SOLUTIONS HAVE BEEN FOUND FOR ALL POINTS
C * ON THE CURRENT LATITUDE CIRCLE(S).
C
400 CONTINUE
C
NUMIT=0
NIT=0
DO 450 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I))
NIT=NIT+1
ENDIF
450 CONTINUE
C
IF(NIT.GT.0) THEN
C
C * CALCULATE SURFACE DRAG COEFFICIENTS (STABILITY-DEPENDENT)
C * AND OTHER RELATED QUANTITIES BETWEEN CANOPY AIR SPACE AND
C * ATMOSPHERE.
C
IF(ISLFD.LT.2) THEN
CALL DRCOEF(CDM,CDH,RIB,CFLUX,QA,QA,ZOSCLM,ZOSCLH,
1 CRIB,TVIRTC,TVIRTA,VA,ZOMS,ZOHS,FI,ITER,
2 ILG,IL1,IL2)
ELSE
CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO,
1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA,
2 TCAN,QCAN,H,ZOM,ZOH,
3 LZZ0,LZZ0T,FM,FH,ILG,ITER,JL )
ENDIF
C
C * CALCULATE CANOPY AIR TEMPERATURE AND SPECIFIC HUMIDITY OF
C * CANOPY AIR (FIRST WITHOUT RC TO CHECK FOR CONDENSATION;
C * IF NO CONDENSATION EXISTS, RECALCULATE).
C
DO 500 I=IL1,IL2
IF (FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
RB(I)=1./CFLUX(I)
IF(QA(I).GT.QCAN(I)) THEN
XEVAP(I)=1.0/RB(I)
ELSE
IF(FSNOWC(I).GT.0.0) THEN
XEVAP(I)=(FRAINC(I)+FSNOWC(I))/RB(I)
ELSE
XEVAP(I)=FRAINC(I)/RB(I)+(1.0-FRAINC(I))/
1 (RB(I)+RC(I))
ENDIF
ENDIF
TAC(I)=TCAN(I)
IF(TCAN(I).GE.TFREZ) THEN
A(I)=17.269
B(I)=35.86
ELSE
A(I)=21.874
B(I)=7.66
ENDIF
WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/
1 (TCAN(I)-B(I)))/PADRY(I)
WC(I)=WCAN
QCAN(I)=WCAN/(1.0+WCAN)
QCAN(I)=RB(I)*XEVAP(I)*QCAN(I)+(1-RB(I)*XEVAP(I))*QA(I)
TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I))
ENDIF
500 CONTINUE
C
C * CALCULATE THE TERMS IN THE ENERGY BALANCE AND SOLVE.
C
DO 550 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
QLWOC(I)=SBC*TCAN(I)*TCAN(I)*TCAN(I)*TCAN(I)
QSENSC(I)=RHOAIR(I)*SPHAIR*CFLUX(I)*(TCAN(I)-TPOTA(I))
IF(FRAINC(I).GT.0. .OR. FSNOWC(I).GT.0. .OR.
1 RC(I).LE.5000. .OR. QA(I).GT.QCAN(I)) THEN
EVAPC(I)=RHOAIR(I)*CFLUX(I)*(QCAN(I)-QA(I))
IEVAPC(I)=1
ELSE
EVAPC(I)=0.
IEVAPC(I)=0
ENDIF
EVPWET(I)=(CLHVAP*RAICAN(I)+(CLHVAP+CLHMLT)*SNOCAN(I))/
1 DELT
IF((FRAINC(I)+FSNOWC(I)).GT.0.50 .AND.
1 EVAPC(I).GT.EVPWET(I)) THEN
EVAPC(I)=EVPWET(I)
IEVAPC(I)=0
ENDIF
QEVAPC(I)=CPHCHC(I)*EVAPC(I)
QSTOR (I)=CHCAP(I)*(TCAN(I)-TCANO(I))/DELT
IF(ILW.EQ.2) THEN
RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-QLWOC(I))*
1 (1.0-FSVF(I))-QSENSC(I)-QEVAPC(I)-
2 QSTOR(I)-QMELTC(I)
ELSE
RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-2.0*QLWOC(I))*
1 (1.0-FSVF(I))-QSENSC(I)-QEVAPC(I)-
2 QSTOR(I)-QMELTC(I)
ENDIF
IF(ABS(RESID(I)).LT.1.0) ITER(I)=0
IF(FI(I).GT.0. .AND. NITER(I).EQ.ITERMX) ITER(I)=-1
ENDIF
550 CONTINUE
C
C * CALCULATE TEMPERATURE STEP FOR NEXT ITERATION.
C
DO 575 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
DCFLUX=(CFLUX(I)-CFLUXM(I))/
1 SIGN(MAX(.001,ABS(TSTEP(I))),TSTEP(I))
IF(ABS(TVIRTA(I)-TVIRTC(I)).LT.0.4)
1 DCFLUX=MAX(DCFLUX,0.8*DCFLXM(I))
IF(NITER(I).GT.1) THEN
DXEVAP=(XEVAP(I)-XEVAPM(I))/
1 SIGN(MAX(.001,ABS(TSTEP(I))),TSTEP(I))
ELSE
DXEVAP=0.
ENDIF
XEVAPM(I)=XEVAP(I)
CFLUXM(I)=CFLUX(I)
DCFLXM(I)=DCFLUX
DRDT0=-4*SBC*TCAN(I)*TCAN(I)*TCAN(I)*(1.0-FSVF(I))*(3-ILW)
1 -RHOAIR(I)*SPHAIR*(CFLUX(I)+MAX(0.,TCAN(I)-TPOTA(I))*DCFLUX)
2 +IEVAPC(I)*CPHCHC(I)*RHOAIR(I)*(XEVAP(I)*WC(I)*A(I)
3 *(B(I)-TFREZ)/((TCAN(I)-B(I))*(1+WC(I)))**2
4 -(QCAN(I)-QA(I))*DXEVAP)-CHCAP(I)/DELT
TSTEP(I)=-RESID(I)/DRDT0
TSTEP(I)=max(-10.,min(5.,TSTEP(I)))
TCAN(I)=TCAN(I)+TSTEP(I)
IF(ABS(TCAN(I)-TFREZ).LT.1.0E-3) TCAN(I)=TFREZ
NITER(I)=NITER(I)+1
NUMIT=NUMIT+1
ENDIF
575 CONTINUE
ENDIF
C
IF(NUMIT.GT.0) GO TO 400
C
C * IF CONVERGENCE HAS NOT BEEN REACHED, CALCULATE TEMPERATURE AND
C * FLUXES ASSUMING NEUTRAL STABILITY AND USING BOWEN RATIO APPROACH
C
DO 585 I=IL1,IL2
IEVAPC(I)=0
NUMIT=0
IF(ITER(I).EQ.-1) THEN
TCANT=TVIRTA(I)/(1.0+0.61*QCAN(I))
IF(TCANT.LT.TCAN(I)+5..AND.ABS(RESID(I)).GT.25.) THEN
TCAN(I)=TCANT
IF(TCAN(I).GE.TFREZ) THEN
A(I)=17.269
B(I)=35.86
ELSE
A(I)=21.874
B(I)=7.66
ENDIF
WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/
1 (TCAN(I)-B(I)))/PADRY(I)
QCAN(I)=WCAN/(1.0+WCAN)
IF(FSNOWC(I).GT.0.0) THEN
YEVAP=FRAINC(I)+FSNOWC(I)
ELSE
YEVAP=FRAINC(I)+(1.0-FRAINC(I))*10./(10.+RC(I))
ENDIF
QCAN(I)=YEVAP*QCAN(I)+(1-YEVAP)*QA(I)
c QEVAPCT=CPHCHC(I)*(QCAN(I)-QA(I))
c BOWEN=SPHAIR*(TCAN(I)-TPOTA(I))/
c 1 SIGN(MAX(ABS(QEVAPCT),1.E-6),QEVAPCT)
QSTOR(I)=CHCAP(I)*(TCAN(I)-TCANO(I))/DELT
QLWOC(I)=SBC*TCAN(I)*TCAN(I)*TCAN(I)*TCAN(I)
IF(ILW.EQ.2) THEN
RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-QLWOC(I))*
1 (1.0-FSVF(I))+QSENSG(I)-QSTOR(I)
ELSE
RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-2.0*QLWOC(I))*
1 (1.0-FSVF(I))+QSENSG(I)-QSTOR(I)
ENDIF
c QEVAPC(I)=RESID(I)/SIGN(MAX(ABS(1+BOWEN),0.1),1+BOWEN)
IF(RESID(I).GT.0.) THEN
QEVAPC(I)=RESID(I)
ELSE
QEVAPC(I)=RESID(I)*0.5
ENDIF
QSENSC(I)=RESID(I)-QEVAPC(I)
RESID(I)=0.
EVAPC(I)=QEVAPC(I)/CPHCHC(I)
TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I))
NUMIT=NUMIT+1
IEVAPC(I)=1
ENDIF
ENDIF
585 CONTINUE
c
IF(NUMIT.GT.0) THEN
IF(ISLFD.LT.2) THEN
CALL DRCOEF(CDM,CDH,RIB,CFLUX,QA,QA,ZOSCLM,ZOSCLH,
1 CRIB,TVIRTC,TVIRTA,VA,ZOMS,ZOHS,FI,IEVAPC,
2 ILG,IL1,IL2)
ELSE
CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO,
1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA,
2 TCAN,QCAN,H,ZOM,ZOH,
3 LZZ0,LZZ0T,FM,FH,ILG,IEVAPC,JL )
ENDIF
ENDIF
c
IBAD=0
C
DO 600 I=IL1,IL2
C IF(FI(I).GT.0. .AND. ITER(I).EQ.-1) THEN
C WRITE(6,6350) I,JL,NITER(I),RESID(I),TCAN(I),RIB(I)
C6350 FORMAT('0CANOPY ITERATION LIMIT',3X,3I3,3(F8.2,E12.4))
C ENDIF
IF(FI(I).GT.0. .AND. (TCAN(I).LT.173.16 .OR.
1 TCAN(I).GT.373.16)) THEN
IBAD=I
ENDIF
600 CONTINUE
C
IF(IBAD.NE.0) THEN
WRITE(6,6375) IBAD,JL,TCAN(IBAD),NITER(IBAD),ISNOW
6375 FORMAT('0BAD CANOPY ITERATION TEMPERATURE',3X,2I3,F16.2,2I4)
WRITE(6,6380) QSWNC(IBAD),QLWIN(IBAD),QLWOG(IBAD),
1 QLWOC(IBAD),QSENSG(IBAD),QSENSC(IBAD),
2 QEVAPC(IBAD),QSTOR(IBAD),QMELTC(IBAD)
WRITE(6,6380) TAC(IBAD),TPOTA(IBAD),TZERO(IBAD)
6380 FORMAT(2X,9F10.2)
CALL XIT('TSOLVC',-2)
ENDIF
C
C * POST-ITERATION CLEAN-UP.
C
NIT=0
DO 650 I=IL1,IL2
IF(FI(I).GT.0.) THEN
IF(RAICAN(I).GT.0. .AND. TCAN(I).LT.TFREZ) THEN
QSTOR(I)=-CHCAP(I)*TCANO(I)/DELT
HFREZ=CHCAP(I)*(TFREZ-TCAN(I))
HCONV=RAICAN(I)*CLHMLT
ITER(I)=1
NIT=NIT+1
IF(HFREZ.LT.HCONV) THEN
RCONV=HFREZ/CLHMLT
SNOCAN(I)=SNOCAN(I)+RCONV
RAICAN(I)=RAICAN(I)-RCONV
TCAN (I)=TFREZ
QMELTC(I)=-CLHMLT*RCONV/DELT
CHCAP(I)=SPHVEG*CMASS(I)+SPHICE*SNOCAN(I)+
1 SPHW*RAICAN(I)
QSTOR(I)=QSTOR(I)+CHCAP(I)*TCAN(I)/DELT
WCAN=0.622*611.0/PADRY(I)
QCAN(I)=WCAN/(1.0+WCAN)
TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I))
ELSE
HCOOL=HFREZ-HCONV
SNOCAN(I)=SNOCAN(I)+RAICAN(I)
TCAN (I)=-HCOOL/(SPHVEG*CMASS(I)+SPHICE*
1 SNOCAN(I))+TFREZ
QMELTC(I)=-CLHMLT*RAICAN(I)/DELT
RAICAN(I)=0.0
CHCAP(I)=SPHVEG*CMASS(I)+SPHICE*SNOCAN(I)
QSTOR(I)=QSTOR(I)+CHCAP(I)*TCAN(I)/DELT
A(I)=21.874
B(I)=7.66
WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/
1 (TCAN(I)-B(I)))/PADRY(I)
QCAN(I)=WCAN/(1.0+WCAN)
TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I))
ENDIF
ELSE
ITER(I)=0
ENDIF
ENDIF
650 CONTINUE
C
DO 675 I=IL1,IL2
IF(FI(I).GT.0.) THEN
IF(SNOCAN(I).GT.0. .AND. TCAN(I).GT.TFREZ) THEN
QSTOR(I)=-CHCAP(I)*TCANO(I)/DELT
HMELT=CHCAP(I)*(TCAN(I)-TFREZ)
HCONV=SNOCAN(I)*CLHMLT
ITER(I)=1
NIT=NIT+1
IF(HMELT.LT.HCONV) THEN
SCONV=HMELT/CLHMLT
SNOCAN(I)=SNOCAN(I)-SCONV
RAICAN(I)=RAICAN(I)+SCONV
TCAN (I)=TFREZ
QMELTC(I)=CLHMLT*SCONV/DELT
CHCAP(I)=SPHVEG*CMASS(I)+SPHW*RAICAN(I)+
1 SPHICE*SNOCAN(I)
QSTOR(I)=QSTOR(I)+CHCAP(I)*TCAN(I)/DELT
WCAN=0.622*611.0/PADRY(I)
QCAN(I)=WCAN/(1.0+WCAN)
TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I))
ELSE
HWARM=HMELT-HCONV
RAICAN(I)=RAICAN(I)+SNOCAN(I)
TCAN (I)=HWARM/(SPHVEG*CMASS(I)+SPHW*
1 RAICAN(I))+TFREZ
QMELTC(I)=CLHMLT*SNOCAN(I)/DELT
SNOCAN(I)=0.0
CHCAP(I)=SPHVEG*CMASS(I)+SPHW*RAICAN(I)
QSTOR(I)=QSTOR(I)+CHCAP(I)*TCAN(I)/DELT
A(I)=17.269
B(I)=35.86
WCAN=0.622*611.0*EXP(A(I)*(TCAN(I)-TFREZ)/
1 (TCAN(I)-B(I)))/PADRY(I)
QCAN(I)=WCAN/(1.0+WCAN)
TVIRTC(I)=TCAN(I)*(1.0+0.61*QCAN(I))
ENDIF
ENDIF
ENDIF
675 CONTINUE
C
C * REMAINING CALCULATIONS.
C
DO 700 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
QLWOC(I)=SBC*TCAN(I)*TCAN(I)*TCAN(I)*TCAN(I)
QSENSC(I)=RHOAIR(I)*SPHAIR*CFLUX(I)*(TCAN(I)-TPOTA(I))
IF(QA(I).GT.QCAN(I)) THEN
XEVAP(I)=1.0/RB(I)
ELSE
IF(FSNOWC(I).GT.0.0) THEN
XEVAP(I)=(FRAINC(I)+FSNOWC(I))/RB(I)
ELSE
XEVAP(I)=FRAINC(I)/RB(I)+(1.0-FRAINC(I))/
1 (RB(I)+RC(I))
ENDIF
ENDIF
C
IF(FRAINC(I).GT.0. .OR. FSNOWC(I).GT.0. .OR.
1 RC(I).LE.5000. .OR. QA(I).GT.QCAN(I)) THEN
EVAPC(I)=RHOAIR(I)*XEVAP(I)*(QCAN(I)-QA(I))
ELSE
EVAPC(I)=0.0
ENDIF
IF(EVAPC(I).LT.0. .AND. TCAN(I).GE.TADP(I)) EVAPC(I)=0.0
EVPWET(I)=(CLHVAP*RAICAN(I)+(CLHVAP+CLHMLT)*SNOCAN(I))/
1 DELT
IF((FRAINC(I)+FSNOWC(I)).GT.0.50 .AND.
1 EVAPC(I).GT.EVPWET(I)) EVAPC(I)=EVPWET(I)
QEVAPC(I)=CPHCHC(I)*EVAPC(I)
IF(ILW.EQ.2) THEN
RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-QLWOC(I))*
1 (1.0-FSVF(I))-QSENSC(I)-QEVAPC(I)-
2 QSTOR(I)-QMELTC(I)
ELSE
RESID(I)=QSWNC(I)+(QLWIN(I)+QLWOG(I)-2.0*QLWOC(I))*
1 (1.0-FSVF(I))-QSENSC(I)-QEVAPC(I)-
2 QSTOR(I)-QMELTC(I)
ENDIF
ENDIF
C
IF(FI(I).GT.0.) THEN
QSENSC(I)=QSENSC(I)+RESID(I)
IF(TAC(I).GE.TFREZ) THEN
CA=17.269
CB=35.86
ELSE
CA=21.874
CB=7.66
ENDIF
IF(EVAPG(I).LT.0. .AND. TZERO(I).GE.TADP(I)) EVAPG(I)=0.
QEVAPG(I)=CPHCHG(I)*EVAPG(I)
IF(ABS(TZERO(I)-TFREZ).LT.1.0E-8) THEN
IF(ILW.EQ.2) THEN
QMELTG(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 (QLWOC(I)-QLWOG(I))-QSENSG(I)-QEVAPG(I)-
2 GZERO(I)
QLWOUT(I)=0.0
ELSE
QMELTG(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 QLWOC(I)-QLWOG(I)-QSENSG(I)-QEVAPG(I)-GZERO(I)
QLWOUT(I)=FSVF(I)*QLWOG(I)+(1.0-FSVF(I))*QLWOC(I)
ENDIF
ELSE
IF(ILW.EQ.2) THEN
GZERO(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 (QLWOC(I)-QLWOG(I))-QSENSG(I)-QEVAPG(I)
QLWOUT(I)=0.0
ELSE
GZERO(I)=QSWNG(I)+FSVF(I)*QLWIN(I)+(1.0-FSVF(I))*
1 QLWOC(I)-QLWOG(I)-QSENSG(I)-QEVAPG(I)
QLWOUT(I)=FSVF(I)*QLWOG(I)+(1.0-FSVF(I))*QLWOC(I)
ENDIF
ENDIF
QSWNET(I)=QSWNG(I)+QSWNC(I)+QTRANS(I)
QSENS(I)=QSENSC(I)+QSENSG(I)
QEVAP(I)=QEVAPC(I)+QEVAPG(I)
EVAPC(I)=EVAPC(I)/RHOW
EVAPG(I)=EVAPG(I)/RHOW
ITERCT(I,KF1(I),NITER(I))=ITERCT(I,KF1(I),NITER(I))+1
ENDIF
700 CONTINUE
C
RETURN
END