SUBROUTINE APREP(FC,FG,FCS,FGS,AILCAN,AILCNS,FSVF,FSVFS, 1,2
1 FRAINC,FSNOWC,RAICAN,RAICNS,SNOCAN,SNOCNS,DISP,
2 DISPS,ZOMLNC,ZOMLCS,ZOELNC,ZOELCS,ZOMLNG,ZOMLNS,
3 ZOELNG,ZOELNS,CHCAP,CHCAPS,CMASSC,CMASCS,CWCAP,
4 CWCAPS,DLEAF,FROOT,ZPLIMC,ZPLIMG,ZPLMCS,ZPLMGS,
5 HTCC,HTCS,HTC,WTRC,WTRS,WTRG,CMAI,
6 AIL,AILS,FCAN,FCANS,PSIGND,
7 FCANMX,ZOLN,AILMAX,AILMIN,CWGTMX,ZRTMAX,
8 AILDAT,HGTDAT,THLIQ,THICE,TBAR,RCAN,SCAN,
9 TCAN,GROWTH,ZSNOW,TSNOW,FSNOW,RHOSNO,SNO,Z0ORO,
A ZBLEND,TA,RHOAIR,RADJ,ILAND,DLON,DELZW,ZBOTW,
B THPOR,THLMIN,PSISAT,BI,PSIWLT,HCPS,ISAND,
C ILG,IL1,IL2,IC,ICP1,IG,IDAY,IDISP,IZREF,ILAI,IHGT,
D RMAT,H,HS,CWCPAV,GROWA,GROWN,GROWB,
E RRESID,SRESID,FRTOT,jl )
C
C * NOV 2003 - Y.DELAGE. MODIFY SOME DO LOOPS TO SATISFY THE LINUX COMPILER
C * JUL 23/03 - Y.DELAGE. ADD CONTRIBUTION OF SUBGRID SCALE
C * TOPOGRAPHY TO Z0
C * JUL 02/03 - D.VERSEGHY. RATIONALIZE ASSIGNMENT OF RESIDUAL
C * CANOPY MOISTURE TO SOIL LAYERS.
C * DEC 05/02 - Y.DELAGE/D.VERSEGHY. ADD PARTS OF CANOPY AIR MASS TO
C * CANOPY MASS ONLY IF IDISP=0 OR IZREF=2.
C * ALSO, REPLACE LOGARITHMIC AVERAGING OF
C * ROUGHNESS HEIGHTS WITH BLENDING HEIGHT
C * AVERAGING.
C * JUL 31/02 - D.VERSEGHY. MOVE CALCULATION OF PSIGND AND FULL
C * CALCULATION OF FROOT INTO THIS ROUTINE
C * FROM TPREP; REMOVE CALCULATION OF RCMIN.
C * SHORTENED CLASS3 COMMON BLOCK.
C * JUL 23/02 - D.VERSEGHY. MOVE ADDITION OF AIR TO CANOPY MASS
C * INTO THIS ROUTINE; SHORTENED CLASS4
C * COMMON BLOCK.
C * MAR 18/02 - D.VERSEGHY. MOVE CALCULATION OF SOIL PROPERTIES INTO
C * ROUTINE "CLASSB"; ALLOW FOR ASSIGNMENT
C * OF SPECIFIED TIME-VARYING VEGETATION
C * HEIGHT AND LEAF AREA INDEX.
C * SEP 19/00 - D.VERSEGHY. ADD CALCULATION OF VEGETATION-DEPENDENT
C * COEFFICIENTS FOR DETERMINATION OF STOMATAL
C * RESISTANCE.
C * APR 12/00 - D.VERSEGHY. RCMIN NOW VARIES WITH VEGETATION TYPE:
C * PASS IN BACKGROUND ARRAY "RCMINX".
C * DEC 16/99 - A.WU/D.VERSEGHY. ADD CALCULATION OF NEW LEAF DIMENSION
C * PARAMETER FOR REVISED CANOPY TURBULENT
C * TRANSFER FORMULATION.
C * NOV 16/98 - M.LAZARE. "DLON" NOW PASSED IN AND USED DIRECTLY
C * (INSTEAD OF INFERRING FROM "LONSL" AND
C * "ILSL" WHICH USED TO BE PASSED) TO CALCULATE
C * GROWTH INDEX. THIS IS DONE TO MAKE THE PHYSICS
C * PLUG COMPATIBLE FOR USE WITH THE RCM WHICH
C * DOES NOT HAVE EQUALLY-SPACED LONGITUDES.
C * JUN 20/97 - D.VERSEGHY. CLASS - VERSION 2.7.
C * MODIFICATIONS TO ALLOW FOR VARIABLE
C * SOIL PERMEABLE DEPTH.
C * OCT 11/96 - D.VERSEGHY. CLASS - VERSION 2.6.
C * BUG FIX: TO AVOID ROUND-OFF ERRORS,
C * SET CANOPY COVER EQUAL TO 1 IF THE
C * CALCULATED SUM OF FC AND FCS IS
C * VERY CLOSE TO 1.
C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5.
C * COMPLETION OF ENERGY BALANCE
C * DIAGNOSTICS.
C * ALSO CORRECT BUG IN CALCULATION OF
C * DEGLON, AND USE IDISP TO DETERMINE
C * METHOD OF CALCULATING DISP AND DISPS.
C * AUG 30/95 - D.VERSEGHY. CLASS - VERSION 2.4.
C * VARIABLE SURFACE DETENTION CAPACITY
C * IMPLEMENTED.
C * AUG 16/95 - D.VERSEGHY. THREE NEW ARRAYS TO COMPLETE WATER
C * BALANCE DIAGNOSTICS.
C * NOV 22/94 - D.VERSEGHY. CLASS - VERSION 2.3.
C * RATIONALIZE CALCULATION OF RCMIN.
C * NOV 12/94 - D.VERSEGHY. FIX BUGS IN SENESCING LIMB OF CROP
C * GROWTH INDEX AND IN CANOPY MASS
C * CALCULATION.
C * MAY 06/93 - M.LAZARE/D.VERSEGHY. CLASS - VERSION 2.1.
C * USE NEW "CANEXT" CANOPY
C * EXTINCTION ARRAY TO DEFINE
C * SKY-VIEW FACTORS. ALSO, CORRECT
C * MINOR BUG WHERE HAD "IF(IN.LE.9)..."
C * INSTEAD OF "IF(IN.GT.9)...".
C * DEC 12/92 - M.LAZARE. MODIFIED FOR MULTIPLE LATITUDES.
C * OCT 24/92 - D.VERSEGHY/M.LAZARE. REVISED AND VECTORIZED CODE
C * FOR MODEL VERSION GCM7.
C * AUG 12/91 - D.VERSEGHY. CALCULATION OF LAND SURFACE CANOPY
C * PARAMETERS.
C
IMPLICIT NONE
integer jl
INTEGER ILG,IL1,IL2,IC,ICP1,IG,IDAY,IDISP,IZREF,ILAI,IHGT
INTEGER i,j,il,in,nl
REAL PI,day,deglon,growg,fsum,snoi,zsnadd
real zroot,fcoeff,psii,lzblend,lz0oro,lzomx
real thsum
C
C * OUTPUT ARRAYS USED ELSEWHERE IN CLASS.
C
REAL FC (ILG), FG (ILG), FCS (ILG), FGS (ILG),
1 AILCAN(ILG), AILCNS(ILG), FSVF (ILG), FSVFS (ILG),
2 FRAINC(ILG), FSNOWC(ILG), RAICAN(ILG), RAICNS(ILG),
3 SNOCAN(ILG), SNOCNS(ILG), DISP (ILG), DISPS (ILG),
4 ZOMLNC(ILG), ZOMLCS(ILG), ZOELNC(ILG), ZOELCS(ILG),
5 ZOMLNG(ILG), ZOMLNS(ILG), ZOELNG(ILG), ZOELNS(ILG),
6 DLEAF (ILG), CHCAP (ILG), CHCAPS(ILG),
7 CMASSC(ILG), CMASCS(ILG), CWCAP (ILG), CWCAPS(ILG),
8 ZPLIMC(ILG), ZPLIMG(ILG), ZPLMCS(ILG), ZPLMGS(ILG),
9 HTCC (ILG), HTCS (ILG), WTRC (ILG), WTRS (ILG),
A WTRG (ILG), CMAI (ILG)
C
REAL FROOT (ILG,IG), HTC (ILG,IG)
C
C * OUTPUT ARRAYS ONLY USED ELSEWHERE IN CLASSA.
C
REAL AIL (ILG,IC), AILS (ILG,IC),
1 FCAN (ILG,IC), FCANS (ILG,IC), PSIGND(ILG)
C
C * INPUT ARRAYS.
C
REAL FCANMX(ILG,ICP1), ZOLN (ILG,ICP1),
1 AILMAX(ILG,IC), AILMIN(ILG,IC), CWGTMX(ILG,IC),
2 ZRTMAX(ILG,IC), AILDAT(ILG,IC), HGTDAT(ILG,IC),
3 THLIQ (ILG,IG), THICE (ILG,IG), TBAR (ILG,IG)
C
REAL RCAN (ILG), SCAN (ILG), TCAN (ILG),
1 GROWTH(ILG), ZSNOW (ILG), TSNOW (ILG),
2 FSNOW (ILG), RHOSNO(ILG), SNO (ILG),
3 TA (ILG), RHOAIR(ILG), DLON (ILG),
4 ZBLEND(ILG), Z0ORO (ILG)
C
REAL RADJ(ILG)
C
INTEGER ILAND (ILG)
C
C * SOIL PROPERTY ARRAYS.
C
REAL DELZW(ILG,IG), ZBOTW(ILG,IG), THPOR(ILG,IG),
1 THLMIN(ILG,IG), PSISAT(ILG,IG), BI (ILG,IG),
2 PSIWLT(ILG,IG), HCPS (ILG,IG)
C
INTEGER ISAND (ILG,IG)
C
C * WORK ARRAYS NOT USED ELSEWHERE IN CLASSA.
C
REAL RMAT (ILG,IC,IG),H (ILG,IC), HS (ILG,IC),
1 CWCPAV(ILG), GROWA (ILG), GROWN (ILG),
2 GROWB (ILG), RRESID(ILG), SRESID(ILG),
3 FRTOT (ILG)
C
C AUTOMATIC ARRAYS
real THICEI(ilg),thliqi(ilg)
C
#include "class_com.cdk"
PI=3.141592654
C-----------------------------------------------------------------------
IF(IC.NE.4) CALL XIT('APREP',-2)
C
C * INITIALIZE DIAGNOSTIC AND OTHER ARRAYS.
C
DO 100 I=IL1,IL2
HTCC(I) =0.0
HTCS(I) =0.0
HTC(I,1)=0.0
HTC(I,2)=0.0
HTC(I,3)=0.0
WTRC(I) =0.0
WTRS(I) =0.0
WTRG(I) =0.0
FRTOT(I)=0.0
PSIGND(I)=1.0E+5
100 CONTINUE
C
C * DETERMINE GROWTH INDEX FOR CROPS (VEGETATION TYPE 3).
C * MUST USE UN-GATHERED LONGITUDES TO COMPUTE ACTUAL LONGITUDE/
C * LATITUDE VALUES.
C
DAY=FLOAT(IDAY)
DO 120 I=IL1,IL2
IL = ILAND(I)
IN = INT( (RADJ(IL)+PI/2.0)*18.0/PI ) + 1
DEGLON=DLON(IL)
IF(DEGLON.GT.190. .AND. DEGLON.LT.330.) THEN
NL=2
ELSE
NL=1
ENDIF
IF(GROWYR(IN,1,NL).LT.0.1) THEN
GROWA(I)=1.0
ELSE
IF(IN.GT.9) THEN
IF(DAY.GE.GROWYR(IN,2,NL).AND.DAY.LT.GROWYR(IN,3,NL))
1 GROWA(I)=1.0
IF(DAY.GE.GROWYR(IN,4,NL).OR.DAY.LT.GROWYR(IN,1,NL))
1 GROWA(I)=0.0
ELSE
IF(DAY.GE.GROWYR(IN,2,NL).OR.DAY.LT.GROWYR(IN,3,NL))
1 GROWA(I)=1.0
IF(DAY.GE.GROWYR(IN,4,NL).AND.DAY.LT.GROWYR(IN,1,NL))
1 GROWA(I)=0.0
ENDIF
IF(DAY.GE.GROWYR(IN,1,NL).AND.DAY.LT.GROWYR(IN,2,NL))
1 GROWA(I)=(DAY-GROWYR(IN,1,NL))/(GROWYR(IN,2,NL)-
2 GROWYR(IN,1,NL))
IF(DAY.GE.GROWYR(IN,3,NL).AND.DAY.LT.GROWYR(IN,4,NL))
1 GROWA(I)=(GROWYR(IN,4,NL)-DAY)/(GROWYR(IN,4,NL)-
2 GROWYR(IN,3,NL))
ENDIF
120 CONTINUE
C
C * DETERMINE GROWTH INDICES FOR NEEDLELEAF TREES, BROADLEAF
C * TREES AND GRASS (VEGETATION TYPES 1, 2 AND 4); CALCULATE
C * VEGETATION HEIGHT, CORRECTED FOR GROWTH STAGE FOR CROPS
C * AND FOR SNOW COVER FOR CROPS AND GRASS; CALCULATE CURRENT
C * LEAF AREA INDEX FOR FOUR VEGETATION TYPES.
C
DO 150 I=IL1,IL2
GROWN(I)=ABS(GROWTH(I))
GROWG=1.0
IF(GROWTH(I).GT.0.0) THEN
GROWB(I)=MIN(1.0,GROWTH(I)*2.0)
ELSE
GROWB(I)=MAX(0.0,(ABS(GROWTH(I))*2.0-1.0))
ENDIF
C
IF(IHGT.EQ.0) THEN
H(I,1)=10.0*ZOLN(I,1)
H(I,2)=10.0*ZOLN(I,2)
H(I,3)=10.0*ZOLN(I,3)*GROWA(I)
H(I,4)=10.0*ZOLN(I,4)
ELSE
H(I,1)=HGTDAT(I,1)
H(I,2)=HGTDAT(I,2)
H(I,3)=HGTDAT(I,3)
H(I,4)=HGTDAT(I,4)
ENDIF
HS(I,1)=H(I,1)
HS(I,2)=H(I,2)
HS(I,3)=MAX(H(I,3)-ZSNOW(I),1.0E-3)
HS(I,4)=MAX(H(I,4)-ZSNOW(I),1.0E-3)
C
IF(ILAI.EQ.0) THEN
AIL(I,1)=AILMIN(I,1)+GROWN(I)*(AILMAX(I,1)-AILMIN(I,1))
AIL(I,2)=AILMIN(I,2)+GROWB(I)*(AILMAX(I,2)-AILMIN(I,2))
AIL(I,3)=AILMIN(I,3)+GROWA(I)*(AILMAX(I,3)-AILMIN(I,3))
AIL(I,4)=AILMIN(I,4)+GROWG *(AILMAX(I,4)-AILMIN(I,4))
ELSE
AIL(I,1)=AILDAT(I,1)
AIL(I,2)=AILDAT(I,2)
AIL(I,3)=AILDAT(I,3)
AIL(I,4)=AILDAT(I,4)
ENDIF
AILS(I,1)=AIL(I,1)
AILS(I,2)=AIL(I,2)
IF(H(I,3).GT.0.0) THEN
AILS(I,3)=AIL(I,3)*HS(I,3)/H(I,3)
ELSE
AILS(I,3)=0.0
ENDIF
IF(H(I,4).GT.0.0) THEN
AILS(I,4)=AIL(I,4)*HS(I,4)/H(I,4)
ELSE
AILS(I,4)=0.0
ENDIF
150 CONTINUE
C
C * ADJUST FRACTIONAL COVERAGE OF GRID CELL FOR CROPS AND
C * GRASS IF LAI FALLS BELOW 1.0 DUE TO GROWTH STAGE OR
C * SNOW COVER; RESET LAI TO 1.0; CALCULATE RESULTANT
C * GRID CELL COVERAGE BY CANOPY, BARE GROUND, CANOPY OVER
C * SNOW AND SNOW OVER BARE GROUND.
C * ALSO CALCULATE SURFACE DETENTION CAPACITY FOR FOUR
C * GRID CELL SUBAREAS BASED ON VALUES SUPPLIED BY
C * U. OF WATERLOO:
C * IMPERMEABLE SURFACES: 0.001 M.
C * BARE SOIL: 0.002 M.
C * LOW VEGETATION: 0.003 M.
C * FOREST: 0.01 M.
C * FOR NOW, ASSIGN WETLANDS A VALUE OF 0.10 M.
C
DO 175 I=IL1,IL2
FCAN(I,1)=FCANMX(I,1)*(1.0-FSNOW(I))
FCAN(I,2)=FCANMX(I,2)*(1.0-FSNOW(I))
IF(AIL(I,3).LT.1.0) THEN
FCAN(I,3)=FCANMX(I,3)*(1.0-FSNOW(I))*AIL(I,3)
AIL (I,3)=1.0
ELSE
FCAN(I,3)=FCANMX(I,3)*(1.0-FSNOW(I))
ENDIF
IF(AIL(I,4).LT.1.0) THEN
FCAN(I,4)=FCANMX(I,4)*(1.0-FSNOW(I))*AIL(I,4)
AIL (I,4)=1.0
ELSE
FCAN(I,4)=FCANMX(I,4)*(1.0-FSNOW(I))
ENDIF
C
FCANS(I,1)=FCANMX(I,1)*FSNOW(I)
FCANS(I,2)=FCANMX(I,2)*FSNOW(I)
IF(AILS(I,3).LT.1.0) THEN
FCANS(I,3)=FCANMX(I,3)*FSNOW(I)*AILS(I,3)
AILS (I,3)=1.0
ELSE
FCANS(I,3)=FCANMX(I,3)*FSNOW(I)
ENDIF
IF(AILS(I,4).LT.1.0) THEN
FCANS(I,4)=FCANMX(I,4)*FSNOW(I)*AILS(I,4)
AILS (I,4)=1.0
ELSE
FCANS(I,4)=FCANMX(I,4)*FSNOW(I)
ENDIF
do j=1,ic
if(fcan(i,j).lt.1.e-5) fcan(i,j)=0.
if(fcans(i,j).lt.1.e-5) fcans(i,j)=0.
enddo
FC (I)=FCAN(I,1)+FCAN(I,2)+FCAN(I,3)+FCAN(I,4)
FG (I)=1.0-FSNOW(I)-FC(I)
FCS(I)=FCANS(I,1)+FCANS(I,2)+FCANS(I,3)+FCANS(I,4)
FGS(I)=FSNOW(I)-FCS(I)
IF(ABS(1.0-FCS(I)-FC(I)).LT.1.0E-5) THEN
FCS(I)=MIN(FSNOW(I),1.0)
FC(I)=1.0-FCS(I)
FGS(I)=0.0
FG(I)=0.0
ENDIF
FC (I)=MAX(FC (I),0.0)
FG (I)=MAX(FG (I),0.0)
FCS(I)=MAX(FCS(I),0.0)
FGS(I)=MAX(FGS(I),0.0)
FSUM=(FCS(I)+FGS(I)+FC(I)+FG(I))
FC (I)=FC (I)/FSUM
FG (I)=FG (I)/FSUM
FCS(I)=FCS(I)/FSUM
FGS(I)=FGS(I)/FSUM
IF(ABS(1.0-FCS(I)-FGS(I)-FC(I)-FG(I)).GT.1.0E-5)
1 CALL XIT('APREP',-1)
C
IF(ISAND(I,1).EQ.-2) THEN
ZPLIMG(I)=0.10
ZPLMGS(I)=0.10
ZPLIMC(I)=0.10
ZPLMCS(I)=0.10
ELSE
IF(ISAND(I,1).EQ.-4) ZPLIMG(I)=0.0
IF(ISAND(I,1).EQ.-3) ZPLIMG(I)=0.001
IF(ISAND(I,1).GT. 0) ZPLIMG(I)=0.002
IF(FGS(I).GT.0.0) THEN
ZPLMGS(I)=(ZPLIMG(I)*FSNOW(I)*(1.0-FCANMX(I,1)-
1 FCANMX(I,2)-FCANMX(I,3)-FCANMX(I,4))+
2 ZPLIMG(I)*(FSNOW(I)*FCANMX(I,3)-
3 FCANS(I,3))+0.003*(FSNOW(I)*FCANMX(I,4)-
4 FCANS(I,4)))/FGS(I)
ELSE
ZPLMGS(I)=0.0
ENDIF
IF(FC(I).GT.0.0) THEN
ZPLIMC(I)=(0.01*(FCAN(I,1)+FCAN(I,2))+0.003*
1 (FCAN(I,3)+FCAN(I,4)))/FC(I)
ELSE
ZPLIMC(I)=0.0
ENDIF
IF(FCS(I).GT.0.0) THEN
ZPLMCS(I)=(0.01*(FCANS(I,1)+FCANS(I,2))+0.003*
1 (FCANS(I,3)+FCANS(I,4)))/FCS(I)
ELSE
ZPLMCS(I)=0.0
ENDIF
ENDIF
C
175 CONTINUE
C
C * PARTITION INTERCEPTED LIQUID AND FROZEN MOISTURE BETWEEN
C * CANOPY OVERLYING BARE GROUND AND CANOPY OVERLYING SNOW; ADD
C * RESIDUAL TO SOIL MOISTURE OR SNOW (IF PRESENT); CALCULATE
C * RELATIVE FRACTIONS OF LIQUID AND FROZEN INTERCEPTED
C * MOISTURE ON CANOPY.
C
DO 190 I=IL1,IL2
IF(FC(I).GT.0.) THEN
AILCAN(I)=(FCAN(I,1)*AIL(I,1)+FCAN(I,2)*AIL(I,2)+
1 FCAN(I,3)*AIL(I,3)+FCAN(I,4)*AIL(I,4))/FC(I)
ELSE
AILCAN(I)=0.0
ENDIF
IF(FCS(I).GT.0.) THEN
AILCNS(I)=(FCANS(I,1)*AILS(I,1)+FCANS(I,2)*AILS(I,2)+
1 FCANS(I,3)*AILS(I,3)+FCANS(I,4)*AILS(I,4))/
2 FCS(I)
ELSE
AILCNS(I)=0.0
ENDIF
C
CWCAP (I)=0.20*AILCAN(I)
CWCAPS(I)=0.20*AILCNS(I)
RRESID(I)=0.0
SRESID(I)=0.0
IF(RCAN(I).GT.0. .AND. (FC(I)+FCS(I)).LE.1.0E-8) THEN
RRESID(I)=RRESID(I)+RCAN(I)
RCAN(I)=0.0
ENDIF
IF(SCAN(I).GT.0. .AND. (FC(I)+FCS(I)).LE.1.0E-8) THEN
SRESID(I)=SRESID(I)+SCAN(I)
SCAN(I)=0.0
ENDIF
IF(RCAN(I).GT.0. .AND. (FC(I)+FCS(I)).GT.0.) THEN
RCAN(I)=RCAN(I)/(FC(I)+FCS(I))
IF(AILCAN(I).GT.0.0) THEN
RAICAN(I)=RCAN(I)*(FC(I)+FCS(I))/(FC(I)+FCS(I)*
1 AILCNS(I)/AILCAN(I))
ELSE
RAICAN(I)=0.0
ENDIF
IF(AILCNS(I).GT.0.0) THEN
RAICNS(I)=RCAN(I)*(FC(I)+FCS(I))/(FCS(I)+FC(I)*
1 AILCAN(I)/AILCNS(I))
ELSE
RAICNS(I)=0.0
ENDIF
ELSE
RAICAN(I)=0.0
RAICNS(I)=0.0
ENDIF
C
IF(SCAN(I).GT.0. .AND. (FC(I)+FCS(I)).GT.0.) THEN
SCAN(I)=SCAN(I)/(FC(I)+FCS(I))
IF(AILCAN(I).GT.0.0) THEN
SNOCAN(I)=SCAN(I)*(FC(I)+FCS(I))/(FC(I)+FCS(I)*
1 AILCNS(I)/AILCAN(I))
ELSE
SNOCAN(I)=0.0
ENDIF
IF(AILCNS(I).GT.0.0) THEN
SNOCNS(I)=SCAN(I)*(FC(I)+FCS(I))/(FCS(I)+FC(I)*
1 AILCAN(I)/AILCNS(I))
ELSE
SNOCNS(I)=0.0
ENDIF
ELSE
SNOCAN(I)=0.0
SNOCNS(I)=0.0
ENDIF
C
IF((FC(I)+FCS(I)).GT.0.) THEN
CWCPAV(I)=(FC(I)*CWCAP(I)+FCS(I)*CWCAPS(I))/(FC(I)+FCS(I))
ELSE
CWCPAV(I)=0.0
ENDIF
IF(CWCPAV(I).GT.0.0) THEN
FRAINC(I)=RCAN(I)/MAX((RCAN(I)+SCAN(I)),CWCPAV(I))
FSNOWC(I)=SCAN(I)/MAX((RCAN(I)+SCAN(I)),CWCPAV(I))
ELSE
FRAINC(I)=0.0
FSNOWC(I)=0.0
ENDIF
C
IF((RAICAN(I)+SNOCAN(I)).GT.CWCAP(I)) THEN
RRESID(I)=RRESID(I)+FC(I)*(RAICAN(I)-FRAINC(I)*CWCAP(I))
SRESID(I)=SRESID(I)+FC(I)*(SNOCAN(I)-FSNOWC(I)*CWCAP(I))
RAICAN(I)=FRAINC(I)*CWCAP(I)
SNOCAN(I)=FSNOWC(I)*CWCAP(I)
ENDIF
C
IF((RAICNS(I)+SNOCNS(I)).GT.CWCAPS(I)) THEN
RRESID(I)=RRESID(I)+FCS(I)*(RAICNS(I)-FRAINC(I)*CWCAPS(I))
SRESID(I)=SRESID(I)+FCS(I)*(SNOCNS(I)-FSNOWC(I)*CWCAPS(I))
RAICNS(I)=FRAINC(I)*CWCAPS(I)
SNOCNS(I)=FSNOWC(I)*CWCAPS(I)
ENDIF
C
WTRC (I)=WTRC(I)-(RRESID(I)+SRESID(I))/DELT
HTCC (I)=HTCC(I)-TCAN(I)*(SPHW*RRESID(I)+SPHICE*SRESID(I))/
1 DELT
IF(FSNOW(I).GT.0.0) THEN
SNOI=SNO(I)
ZSNADD=SRESID(I)/(RHOSNO(I)*FSNOW(I))
ZSNOW(I)=ZSNOW(I)+ZSNADD
SNO(I)=ZSNOW(I)*FSNOW(I)*RHOSNO(I)
TSNOW(I)=(TCAN(I)*SPHICE*SRESID(I)+TSNOW(I)*HCPICE*
1 SNOI/RHOICE)/(HCPICE*SNO(I)/RHOICE)
HTCS (I)=HTCS(I)+TCAN(I)*SPHICE*SRESID(I)/DELT
WTRS (I)=WTRS(I)+SRESID(I)/DELT
SRESID(I)=0.0
ENDIF
190 continue
C
DO 200 J=1,IG
do i=il1,il2
thliqi(I)=0.
enddo
do i=il1,il2
IF(DELZW(I,J).GT.0.0 .AND. (RRESID(I).GT.0.0
1 .OR. SRESID(I).GT.0.0)) then
THSUM=THLIQ(I,J)+THICE(I,J)*RHOICE/RHOW+
1 (RRESID(I)+SRESID(I))/(RHOW*DELZW(I,J))
IF(THSUM.LE.THPOR(I,J)) THEN
THICEI(I)=THICE(I,J)
THLIQI(I)=THLIQ(I,J)
THICE(I,J)=THICE(I,J)+SRESID(I)/
1 (RHOICE*DELZW(I,J))
THLIQ(I,J)=THLIQ(I,J)+RRESID(I)/
1 (RHOW*DELZW(I,J))
endif
ENDIF
enddo
do i=il1,il2
if(thliqi(I).gt.1.e-5) then
TBAR(I,J)=(TBAR(I,J)*((DELZ(J)-DELZW(I,J))*
1 HCPSND+DELZW(I,J)*(THLIQI(I)*HCPW+THICEI(I)*
2 HCPICE+(1.0-THPOR(I,J))*HCPS(I,J)))+TCAN(I)*
3 (RRESID(I)*HCPW/RHOW+SRESID(I)*HCPICE/RHOICE))
4 /((DELZ(J)-DELZW(I,J))*HCPSND+DELZW(I,J)*
5 (HCPW*THLIQ(I,J)+HCPICE*THICE(I,J)+HCPS(I,J)*
6 (1.0-THPOR(I,J))))
endif
enddo
do i=il1,il2
if(thliqi(I).gt.1.e-5) then
WTRG (I)=WTRG(I)+(RRESID(I)+SRESID(I))/DELT
HTC(I,J)=HTC(I,J)+TCAN(I)*(RRESID(I)*HCPW/RHOW+
1 SRESID(I)*HCPICE/RHOICE)/DELT
RRESID(I)=0.0
SRESID(I)=0.0
c ENDIF
ENDIF
enddo
200 CONTINUE
C
C
C * REMAINING CANOPY PARAMETERS.
C * FIRST, INITIALIZE WORK FIELDS FOR SUBSEQUENT CALCULATIONS FOR
C * BOTH SNOW-FREE AND SNOW-COVERED CASES.
C
DO 250 I=IL1,IL2
DISP (I)=0.
ZOMLNC(I)=0.
ZOELNC(I)=1.
DISPS (I)=0.
ZOMLCS(I)=0.
ZOELCS(I)=1.
ZOMLNG(I)=0.
ZOELNG(I)=0.
ZOMLNS(I)=0.
ZOELNS(I)=0.
CMASSC(I)=0.
CMASCS(I)=0.
250 CONTINUE
C
C * CALCULATION OF ROUGHNESS LENGTHS FOR HEAT AND MOMENTUM AND
C * ZERO-PLANE DISPLACEMENT FOR CANOPY OVERLYING BARE SOIL AND
C * CANOPY OVERLYING SNOW.
C
DO 275 J=1,IC
DO 275 I=IL1,IL2
IF(FC(I).GT.0. .AND. H(I,J).GT.0.) THEN
IF(IDISP.EQ.1) DISP(I)=DISP(I)+FCAN (I,J)*
1 LOG(0.7*H(I,J))
ZOMLNC(I)=ZOMLNC(I)+FCAN (I,J)/
1 ((LOG(ZBLEND(I)/(0.1*H(I,J))))**2)
ZOELNC(I)=ZOELNC(I)*
1 (0.01*H(I,J)*H(I,J)/ZORAT(IC))**FCAN(I,J)
ENDIF
IF(FCS(I).GT.0. .AND. HS(I,J).GT.0.) THEN
IF(IDISP.EQ.1) DISPS(I)=DISPS (I)+FCANS(I,J)*
1 LOG(0.7*HS(I,J))
ZOMLCS(I)=ZOMLCS(I)+FCANS(I,J)/
1 ((LOG(ZBLEND(I)/(0.1*HS(I,J))))**2)
ZOELCS(I)=ZOELCS(I)*
1 (0.01*HS(I,J)*HS(I,J)/ZORAT(IC))**FCANS(I,J)
ENDIF
275 CONTINUE
C
DO 290 I=IL1,IL2
IF(FC(I).GT.0.) THEN
IF(IDISP.EQ.1) DISP(I)=EXP(DISP(I)/FC(I))
ZOMLNC(I)=ZBLEND(I)/EXP(SQRT(1.0/(ZOMLNC(I)/FC(I))))
ZOELNC(I)=ZOELNC(I)**(1.0/FC(I))/ZOMLNC(I)
ZOMLNC(I)=log(ZOMLNC(I))
ZOELNC(I)=log(ZOELNC(I))
ENDIF
IF(FCS(I).GT.0.) THEN
IF(IDISP.EQ.1) DISPS(I)=EXP(DISPS(I)/FCS(I))
ZOMLCS(I)=ZBLEND(I)/EXP(SQRT(1.0/(ZOMLCS(I)/FCS(I))))
ZOELCS(I)=ZOELCS(I)**(1.0/FCS(I))/ZOMLCS(I)
ZOMLCS(I)=log(ZOMLCS(I))
ZOELCS(I)=max(-9.2,log(ZOELCS(I)))
ENDIF
290 CONTINUE
C
C * ADJUST ROUGHNESS LENGTHS OF BARE SOIL AND SNOW-COVERED BARE
C * SOIL FOR URBAN ROUGHNESS IF PRESENT.
C
DO 300 I=IL1,IL2
IF(FG(I).GT.0.) THEN
IF(ISAND(I,1).NE.-4) THEN
ZOMLNG(I)=((FG(I)-FCANMX(I,5)*(1.0-FSNOW(I)))*ZOLNG+
1 FCANMX(I,5)*(1.0-FSNOW(I))*LOG(max(ZOLN(I,5),.0001)))/FG(I)
ELSE
ZOMLNG(I)=ZOLNI
ENDIF
ZOELNG(I)=ZOMLNG(I)-LOG(ZORATG)
ENDIF
IF(FGS(I).GT.0.) THEN
ZOMLNS(I)=((FGS(I)-FCANMX(I,5)*FSNOW(I))*ZOLNS+
1 FCANMX(I,5)*FSNOW(I)*LOG(max(ZOLN(I,5),.0001)))/FGS(I)
ZOELNS(I)=ZOMLNS(I)-LOG(ZORATG)
ENDIF
300 CONTINUE
C
C * INCLUDE CONTRIBUTION FROM OROGRAPHY TO MOMENTUM ROUGNESS LENGTH
C
DO 325 I=IL1,IL2
LZ0ORO=LOG(Z0ORO(I))
ZOMLNC(I)=MAX(ZOMLNC(I),LZ0ORO)
ZOMLCS(I)=MAX(ZOMLCS(I),LZ0ORO)
ZOMLNG(I)=MAX(ZOMLNG(I),LZ0ORO)
ZOMLNS(I)=MAX(ZOMLNS(I),LZ0ORO)
325 CONTINUE
C
C * CALCULATE HEAT CAPACITY FOR CANOPY OVERLYING BARE SOIL AND
C * CANOPY OVERLYING SNOW.
C * ALSO CALCULATE INSTANTANEOUS GRID-CELL AVERAGED CANOPY MASS.
C
DO 350 I=IL1,IL2
IF(FC(I).GT.0.) THEN
CMASSC(I)=(FCAN(I,1)*CWGTMX(I,1)+FCAN (I,2)*CWGTMX(I,2)+
1 FCAN(I,3)*CWGTMX(I,3)*GROWA(I)+
2 FCAN(I,4)*CWGTMX(I,4))/FC (I)
IF(IDISP.EQ.0) THEN
CMASSC(I)=CMASSC(I)+RHOAIR(I)*(SPHAIR/SPHVEG)*0.7*
1 (FCAN(I,1)*H(I,1)+FCAN(I,2)*H(I,2)+
2 FCAN(I,3)*H(I,3)+FCAN(I,4)*H(I,4))/FC(I)
ENDIF
IF(IZREF.EQ.2) THEN
CMASSC(I)=CMASSC(I)+RHOAIR(I)*(SPHAIR/SPHVEG)*0.1*
1 (FCAN(I,1)*H(I,1)+FCAN(I,2)*H(I,2)+
2 FCAN(I,3)*H(I,3)+FCAN(I,4)*H(I,4))/FC(I)
ENDIF
ENDIF
IF(FCS(I).GT.0.) THEN
CMASCS(I)=(FCANS(I,1)*CWGTMX(I,1)+FCANS(I,2)*CWGTMX(I,2)+
1 FCANS(I,3)*CWGTMX(I,3)
2 *HS(I,3)/MAX(H(I,3),1.0E-12)+
3 FCANS(I,4)*CWGTMX(I,4)
4 *HS(I,4)/MAX(H(I,4),1.0E-12))/FCS(I)
IF(IDISP.EQ.0) THEN
CMASCS(I)=CMASCS(I)+RHOAIR(I)*(SPHAIR/SPHVEG)*0.7*
1 (FCANS(I,1)*HS(I,1)+FCANS(I,2)*HS(I,2)+
2 FCANS(I,3)*HS(I,3)+FCANS(I,4)*HS(I,4))/
3 FCS(I)
ENDIF
IF(IZREF.EQ.2) THEN
CMASCS(I)=CMASCS(I)+RHOAIR(I)*(SPHAIR/SPHVEG)*0.1*
1 (FCANS(I,1)*HS(I,1)+FCANS(I,2)*HS(I,2)+
2 FCANS(I,3)*HS(I,3)+FCANS(I,4)*HS(I,4))/
3 FCS(I)
ENDIF
ENDIF
CHCAP (I)=SPHVEG*CMASSC(I)+SPHW*RAICAN(I)+SPHICE*SNOCAN(I)
CHCAPS(I)=SPHVEG*CMASCS(I)+SPHW*RAICNS(I)+SPHICE*SNOCNS(I)
HTCC (I)=HTCC(I)-SPHVEG*CMAI(I)*TCAN(I)/DELT
IF(CMAI(I).LT.1.0E-8 .AND. (CMASSC(I).GT.0.0 .OR.
1 CMASCS(I).GT.0.0)) TCAN(I)=TA(I)
CMAI (I)=FC(I)*CMASSC(I)+FCS(I)*CMASCS(I)
HTCC (I)=HTCC(I)+SPHVEG*CMAI(I)*TCAN(I)/DELT
350 CONTINUE
C
C * CALCULATE VEGETATION ROOTING DEPTH AND FRACTION OF ROOTS
C * IN EACH SOIL LAYER (SAME FOR SNOW/BARE SOIL CASES).
C
DO 400 J=1,IC
DO 400 I=IL1,IL2
ZROOT=ZRTMAX(I,J)
IF(J.EQ.3) ZROOT=ZRTMAX(I,J)*GROWA(I)
ZROOT=MIN(ZROOT,(DELZW(I,1)+DELZW(I,2)+DELZW(I,3)))
IF(ZROOT.LE.ZBOTW(I,1)) THEN
RMAT(I,J,1)=1.0
RMAT(I,J,2)=0.0
RMAT(I,J,3)=0.0
ELSE
FCOEFF=EXP(-3.0*ZROOT)
RMAT(I,J,1)=1.0-(EXP(-3.0*ZBOTW(I,1))-FCOEFF)/(1.0-FCOEFF)
IF(ZROOT.LE.ZBOTW(I,2)) THEN
RMAT(I,J,2)=1.0-RMAT(I,J,1)
RMAT(I,J,3)=0.0
ELSE
RMAT(I,J,3)=(EXP(-3.0*ZBOTW(I,2))-FCOEFF)/(1.0-FCOEFF)
RMAT(I,J,2)=1.0-RMAT(I,J,1)-RMAT(I,J,3)
ENDIF
ENDIF
400 CONTINUE
C
DO 500 J=1,IG
DO 500 I=IL1,IL2
IF((FC(I)+FCS(I)).GT.0.) THEN
FROOT(I,J)=((FCAN(I,1)+FCANS(I,1))*RMAT(I,1,J) +
1 (FCAN(I,2)+FCANS(I,2))*RMAT(I,2,J) +
2 (FCAN(I,3)+FCANS(I,3))*RMAT(I,3,J) +
3 (FCAN(I,4)+FCANS(I,4))*RMAT(I,4,J))/
4 (FC(I)+FCS(I))
ELSE
FROOT(I,J)=0.0
ENDIF
500 CONTINUE
C
C * CALCULATE SKY-VIEW FACTORS FOR BARE GROUND AND SNOW
C * UNDERLYING CANOPY.
C * ALSO CALCULATE LEAF DIMENSION PARAMETER DLEAF.
C
DO 600 I=IL1,IL2
IF(FC(I).GT.0.) THEN
FSVF (I)=(FCAN (I,1)*EXP(CANEXT(1)*AIL (I,1)) +
1 FCAN (I,2)*EXP(CANEXT(2)*AIL (I,2)) +
2 FCAN (I,3)*EXP(CANEXT(3)*AIL (I,3)) +
3 FCAN (I,4)*EXP(CANEXT(4)*AIL (I,4)))/FC (I)
ELSE
FSVF (I)=0.
ENDIF
IF(FCS(I).GT.0.) THEN
FSVFS(I)=(FCANS(I,1)*EXP(CANEXT(1)*AILS(I,1)) +
1 FCANS(I,2)*EXP(CANEXT(2)*AILS(I,2)) +
2 FCANS(I,3)*EXP(CANEXT(3)*AILS(I,3)) +
3 FCANS(I,4)*EXP(CANEXT(4)*AILS(I,4)))/FCS(I)
ELSE
FSVFS(I)=0.
ENDIF
IF((FC(I)+FCS(I)).GT.0.) THEN
DLEAF(I)=((FCAN(I,1)+FCANS(I,1))*XLEAF(1) +
1 (FCAN(I,2)+FCANS(I,2))*XLEAF(2) +
2 (FCAN(I,3)+FCANS(I,3))*XLEAF(3) +
3 (FCAN(I,4)+FCANS(I,4))*XLEAF(4))/
4 (FC(I)+FCS(I))
ELSE
DLEAF(I)=0.0
ENDIF
600 CONTINUE
C
C * CALCULATE BULK SOIL MOISTURE SUCTION FOR STOMATAL RESISTANCE.
C * CALCULATE FRACTIONAL TRANSPIRATION EXTRACTED FROM SOIL LAYERS.
C
DO 650 J=1,IG
DO 650 I=IL1,IL2
IF(FCS(I).GT.0.0 .OR. FC(I).GT.0.0) THEN
IF(THLIQ(I,J).GT.(THLMIN(I,J)+0.01) .AND.
1 FROOT(I,J).GT.0.) THEN
PSII=PSISAT(I,J)*(THLIQ(I,J)/THPOR(I,J))**(-BI(I,J))
PSII=MIN(PSII,PSIWLT(I,J))
PSIGND(I)=MIN(PSIGND(I),PSII)
FROOT(I,J)=FROOT(I,J)*(PSIWLT(I,J)-PSII)/
1 (PSIWLT(I,J)-PSISAT(I,J))
FRTOT(I)=FRTOT(I)+FROOT(I,J)
ELSE
FROOT(I,J)=0.0
ENDIF
ENDIF
650 CONTINUE
C
DO 700 J=1,IG
DO 700 I=IL1,IL2
IF(FRTOT(I).GT.0.) THEN
FROOT(I,J)=FROOT(I,J)/FRTOT(I)
ENDIF
700 CONTINUE
C
RETURN
END