SUBROUTINE TSOLVE(ISNOW,FI, 2,7
1 QSWNET,QLWOUT,QTRANS,QSENS,QEVAP,EVAP,
2 TZERO,QZERO,GZERO,QMELT,CDH,CDM,RIB,CFLUX,
3 FTEMP,FVAP,ILMO,UE,H,
4 QSWINV,QSWINI,QLWIN,TPOTA,QA,VA,PADRY,RHOAIR,
5 ALVISG,ALNIRG,CRIB,CPHCH,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,DCFLXM,CFLUXM,
B JEVAP,W0,TRTOP,A,B,ZOMS,ZOHS,LZZ0,LZZ0T,
C FM,FH,ITER,NITER,KF)
C
C * AUG 19/04 - Y.DELAGE. REGROUP COMMON BLOCKS
C * MAKE DECLARATIONS EXPLICIT
C * NOV 12/02 - Y.DELAGE. REPLACE SECANT METHOD BY NEWTON-RAPHSON SCHEME.
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.
C * JUL 26/02 - D.VERSEGHY. SHORTENED CLASS4 COMMON BLOCK.
C * MAR 28/02 - D.VERSEGHY. STREAMLINED SUBROUTINE CALL.
C * BYPASS EVAPORATION EFFICIENCY PARAMETER
C * IN CASES OF CONDENSATION.
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 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 * "CFLUX" NOW WORK FIELD INSTEAD OF "CLIMIT".
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 LOOP 200.
C * JUL 29/93 - D.VERSEGHY. CLASS - VERSION 2.2.
C * REMOVE RE-DEFINITION OF QMELT NEAR END
C * (SINCE DONE ELSEWHERE ALREADY) AND
C * REDEFINE QSWNET FOR DIAGNOSTIC PURPOSES
C * TO INCLUDE TRANSMISSION THROUGH
C * SNOWPACK.
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. CODE FOR MODEL VERSION GCM7U -
C * CLASS VERSION 2.0 (WITH CANOPY).
C * APR 11/89 - D.VERSEGHY. ITERATIVE SURFACE TEMPERATURE
C * CALCULATIONS FOR SNOW/SOIL.
C
IMPLICIT NONE
INTEGER ISLFD,ILW,ILG,IL1,IL2,JL,I,ISNOW,NIT,NUMIT,IBAD,ITERMX
REAL QSWNV,QSWNI,DCFLUX,DRDT0,TZEROT,WZERO,BOWEN,QEVAPT
C
C * OUTPUT ARRAYS.
C
REAL QSWNET(ILG), QLWOUT(ILG), QTRANS(ILG), QSENS (ILG),
1 QEVAP (ILG), EVAP (ILG), TZERO (ILG), QZERO (ILG),
2 GZERO (ILG), QMELT (ILG), CDH (ILG), CDM (ILG),
3 RIB (ILG), CFLUX (ILG), FTEMP (ILG), FVAP (ILG),
4 ILMO (ILG), 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), PADRY (ILG),
2 RHOAIR(ILG), ALVISG(ILG), ALNIRG(ILG), CRIB (ILG),
3 CPHCH (ILG), CEVAP (ILG), TADP (ILG), TVIRTA(ILG),
4 ZOSCLH(ILG), ZOSCLM(ILG), ZRSLFH(ILG), ZRSLFM(ILG),
5 ZOH (ILG), ZOM (ILG), GCONST(ILG), GCOEFF(ILG),
6 TSTART(ILG), TRSNOW(ILG), FCOR (ILG)
C
INTEGER IWATER(ILG), IEVAP (ILG)
INTEGER ITERCT(ILG,6,50)
C
C * INTERNAL WORK ARRAYS.
C
REAL TSTEP (ILG), TVIRTS(ILG), EVBETA(ILG), Q0SAT (ILG),
1 RESID (ILG), DCFLXM(ILG), CFLUXM(ILG), W0 (ILG),
2 TRTOP (ILG), A (ILG), B (ILG),
3 ZOMS (ILG), ZOHS (ILG), LZZ0 (ILG), LZZ0T (ILG),
4 FM (ILG), FH (ILG)
C
INTEGER ITER (ILG), NITER (ILG), KF (ILG),
1 JEVAP (ILG)
C
logical prnt
#include "class_com.cdk"
C-----------------------------------------------------------------------
data prnt /.false./
c data prnt /.true./
if(prnt) then
print*,'QSWINV',QSWINV
print*,'QSWINI',QSWINI
print*,'QLWIN',QLWIN
print*,'TPOTA',TPOTA
print*,'QA',QA
print*,'VA',VA
print*,'PADRY',PADRY
print*,'RHOAIR',RHOAIR
print*,'CPHCH',CPHCH
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*,'TSTART',TSTART
print*,'TRSNOW',TRSNOW
print*,'ISLFD,ILW,ILG,IL1,IL2,JL',ISLFD,ILW,ILG,IL1,IL2,JL
endif
C * INITIALIZATION AND PRE-ITERATION SEQUENCE.
C
ITERMX = 5
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
QSWNV=QSWINV(I)*(1.0-ALVISG(I))
QSWNI=QSWINI(I)*(1.0-ALNIRG(I))
QSWNET(I)=QSWNV+QSWNI
QTRANS(I)=QSWNET(I)*TRTOP(I)
QSWNET(I)=QSWNET(I)-QTRANS(I)
QMELT(I)=0.0
TZERO(I)=TSTART(I)
TSTEP(I)=5.0
C
RESID(I)=999999.
DCFLXM(I)=0.
ITER(I)=1
NITER(I)=1
IF(ISNOW.EQ.1) THEN
KF(I)=3
ELSE
KF(I)=6
ENDIF
ENDIF
50 CONTINUE
C
C * ITERATION SECTION.
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
NIT=0
DO 150 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
CFLUXM(I)=CFLUX(I)
IF(TZERO(I).GE.TFREZ) THEN
A(I)=17.269
B(I)=35.86
ELSE
A(I)=21.874
B(I)=7.66
ENDIF
W0(I)=0.622*611.0*EXP(A(I)*(TZERO(I)-TFREZ)/
1 (TZERO(I)-B(I)))/PADRY(I)
Q0SAT(I)=W0(I)/(1.0+W0(I))
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
TVIRTS(I)=TZERO(I)*(1.0+0.61*QZERO(I))
NIT=NIT+1
ENDIF
150 CONTINUE
C
IF(NIT.GT.0) THEN
C
C * CALCULATE SURFACE DRAG COEFFICIENTS (STABILITY-DEPENDENT) AND
C * OTHER RELATED QUANTITIES.
C
IF(ISLFD.LT.2) THEN
CALL DRCOEF (CDM,CDH,RIB,CFLUX,QZERO,QA,ZOSCLM,ZOSCLH,
1 CRIB,TVIRTS,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 TZERO,QZERO,H,ZOM,ZOH,
3 LZZ0,LZZ0T,FM,FH,ILG,ITER,JL )
ENDIF
C
C * REMAINING CALCULATIONS.
C
DO 175 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I)
QSENS(I)=RHOAIR(I)*SPHAIR*CFLUX(I)*(TZERO(I)-TPOTA(I))
EVAP(I)=RHOAIR(I)*CFLUX(I)*(QZERO(I)-QA(I))
QEVAP(I)=CPHCH(I)*EVAP(I)
IF(ILW.EQ.2) THEN
QLWOUT(I)=0.0
ELSE
QLWOUT(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I)
ENDIF
RESID(I)=QSWNET(I)+QLWIN(I)-QLWOUT(I)-QSENS(I)-QEVAP(I)-
1 GZERO(I)
IF(ABS(RESID(I)).LT.1.0) ITER(I)=0
IF(FI(I).GT.0. .AND. NITER(I).EQ.ITERMX) ITER(I)=-1
ENDIF
C
175 CONTINUE
DO 185 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
IF(NITER(I).GT.1) THEN
DCFLUX=(CFLUX(I)-CFLUXM(I))/
1 SIGN(MAX(.001,ABS(TSTEP(I))),TSTEP(I))
IF(ABS(TVIRTA(I)-TVIRTS(I)).LT.0.4)
1 DCFLUX=MAX(DCFLUX,0.8*DCFLXM(I))
DCFLXM(I)=DCFLUX
ELSE
DCFLUX=0.
ENDIF
DRDT0= -4*SBC*TZERO(I)**3*(2-ILW)
1 -RHOAIR(I)*SPHAIR*(CFLUX(I)+MAX(0.,TZERO(I)-TPOTA(I))
1 *DCFLUX) -GCOEFF(I)
2 +CPHCH(I)*RHOAIR(I)*(CFLUX(I)*W0(I)*A(I)
3 *EVBETA(I)*(B(I)-TFREZ)/((TZERO(I)-B(I))*(1+W0(I)))**2
4 -(QZERO(I)-QA(I))*DCFLUX)
TSTEP(I)=-RESID(I)/DRDT0
TSTEP(I)=max(-10.,min(5.,TSTEP(I)))
TZERO(I)=TZERO(I)+TSTEP(I)
NITER(I)=NITER(I)+1
NUMIT=NUMIT+1
ENDIF
185 CONTINUE
ENDIF
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
JEVAP(I)=0
NUMIT=0
IF(FI(I).GT.0. .AND.ITER(I).EQ.-1) THEN
TZEROT=TVIRTA(I)/(1.0+0.61*QZERO(I))
IF(TZEROT.LT.TZERO(I)+5..AND.ABS(RESID(I)).GT.25.) 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)
IF(ILW.EQ.2) THEN
QLWOUT(I)=0.0
ELSE
QLWOUT(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I)
ENDIF
RESID(I)=QSWNET(I)+QLWIN(I)-QLWOUT(I)-GZERO(I)
QEVAPT=CPHCH(I)*(QZERO(I)-QA(I))
BOWEN=SPHAIR*(TZERO(I)-TPOTA(I))/
1 SIGN(MAX(ABS(QEVAPT),1.E-6),QEVAPT)
QEVAP(I)=RESID(I)/SIGN(MAX(ABS(1+BOWEN),0.1),1+BOWEN)
QSENS(I)=RESID(I)-QEVAP(I)
RESID(I)=0.
EVAP(I)=QEVAP(I)/CPHCH(I)
TVIRTS(I)=TZERO(I)*(1.0+0.61*QZERO(I))
JEVAP(I)=1
NUMIT=NUMIT+1
ENDIF
ENDIF
195 CONTINUE
C
IF(NUMIT.GT.0) THEN
IF(ISLFD.LT.2) THEN
CALL DRCOEF (CDM,CDH,RIB,CFLUX,QZERO,QA,ZOSCLM,ZOSCLH,
1 CRIB,TVIRTS,TVIRTA,VA,ZOMS,ZOHS,FI,JEVAP,
2 ILG,IL1,IL2)
ELSE
CALL FLXSURFZ(CDM,CDH,CFLUX,RIB,FTEMP,FVAP,ILMO,
1 UE,FCOR,TPOTA,QA,ZRSLFM,ZRSLFH,VA,
2 TZERO,QZERO,H,ZOM,ZOH,
3 LZZ0,LZZ0T,FM,FH,ILG,JEVAP,JL )
ENDIF
ENDIF
C
C do I=IL1,IL2
C if(jevap(i).eq.1) print196,'TSOLVE: RESID>25',
C 1 I,JL,VA(I),QEVAP(I),QSENS(I)
C ENDDO
C 196 FORMAT(A18,2I5,3F10.2)
IBAD=0
DO 200 I=IL1,IL2
IF(FI(I).GT.0. .AND. (TZERO(I).LT.173.16 .OR.
1 TZERO(I).GT.373.16)) THEN
IBAD=I
ENDIF
200 CONTINUE
C
C
IF(IBAD.NE.0) THEN
WRITE(6,6275) IBAD,JL,TZERO(IBAD),NITER(IBAD),ISNOW
6275 FORMAT('0BAD ITERATION TEMPERATURE',3X,2I3,F16.2,2I4)
WRITE(6,6280) QSWNET(IBAD),QLWIN(IBAD),QSENS(IBAD),
1 QEVAP(IBAD),GZERO(IBAD),CFLUX(IBAD),RIB(IBAD)
6280 FORMAT(2X,7F12.4)
CALL XIT('TSOLVE',-1)
ENDIF
C
C * POST-ITERATION CLEAN-UP.
C
NIT=0
DO 300 I=IL1,IL2
IF(((IWATER(I).EQ.1 .AND. TZERO(I).LT.TFREZ) .OR.
1 (IWATER(I).EQ.2 .AND. TZERO(I).GT.TFREZ)) .AND.
2 FI(I).GT.0.) THEN
TZERO(I)=TFREZ
WZERO=0.622*611.0/PADRY(I)
QZERO(I)=WZERO/(1.0+WZERO)
EVBETA(I)=1.0
TVIRTS(I)=TZERO(I)*(1.0+0.61*QZERO(I))
ITER(I)=1
NIT=NIT+1
ELSE
ITER(I)=0
ENDIF
300 CONTINUE
C
IF(NIT.GT.0) THEN
C
C * CALCULATE SURFACE DRAG COEFFICIENTS (STABILITY-DEPENDENT) AND
C * OTHER RELATED QUANTITIES.
C
IF(ISLFD.LT.2) THEN
CALL DRCOEF (CDM,CDH,RIB,CFLUX,QZERO,QA,ZOSCLM,ZOSCLH,
1 CRIB,TVIRTS,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 TZERO,QZERO,H,ZOM,ZOH,
3 LZZ0,LZZ0T,FM,FH,ILG,ITER,JL )
ENDIF
ENDIF
C
C * REMAINING CALCULATIONS.
C
DO 350 I=IL1,IL2
IF(FI(I).GT.0. .AND. ITER(I).EQ.1) THEN
GZERO(I)=GCOEFF(I)*TZERO(I)+GCONST(I)
QSENS(I)=RHOAIR(I)*SPHAIR*CFLUX(I)*(TZERO(I)-TPOTA(I))
EVAP(I)=RHOAIR(I)*CFLUX(I)*(QZERO(I)-QA(I))
IF(EVAP(I).LT.0. .AND. TZERO(I).GE.TADP(I)) EVAP(I)=0.0
QEVAP(I)=CPHCH(I)*EVAP(I)
IF(ILW.EQ.2) THEN
QLWOUT(I)=0.0
ELSE
QLWOUT(I)=SBC*TZERO(I)*TZERO(I)*TZERO(I)*TZERO(I)
ENDIF
QMELT(I)=QSWNET(I)+QLWIN(I)-QLWOUT(I)-QSENS(I)-QEVAP(I)-
1 GZERO(I)
RESID(I)=0.0
ENDIF
C
IF(FI(I).GT.0.) THEN
GZERO(I)=GZERO(I)+RESID(I)*0.5
QSENS(I)=QSENS(I)+RESID(I)*0.5
QSWNET(I)=QSWNET(I)+QTRANS(I)
EVAP(I)=EVAP(I)/RHOW
ITERCT(I,KF(I),NITER(I))=ITERCT(I,KF(I),NITER(I))+1
ENDIF
350 CONTINUE
C
RETURN
END