SUBROUTINE WPREP(THLQCO, THLQGO, THLQCS, THLQGS, THICCO, THICGO, 1
1 THICCS, THICGS, HCPCO, HCPGO, HCPCS, HCPGS,
2 SPCC, SPCG, SPCCS, SPCGS, TSPCC, TSPCG,
3 TSPCCS, TSPCGS, RPCC, RPCG, RPCCS, RPCGS,
4 TRPCC, TRPCG, TRPCCS, TRPCGS, EVPIC, EVPIG,
5 EVPICS, EVPIGS, ZPONDC, ZPONDG, ZPNDCS, ZPNDGS,
6 XSNOWC, XSNOWG, XSNOCS, XSNOGS, ZSNOWC, ZSNOWG,
7 ZSNOCS, ZSNOGS, ALBSC, ALBSG, ALBSCS, ALBSGS,
8 RHOSC, RHOSG, RHOSCS, RHOSGS, HCPSC, HCPSG,
9 HCPSCS, HCPSGS, RUNFC, RUNFG, RUNFCS, RUNFGS,
A SUBLC, SUBLCS, WLOSTC, WLOSTG, WLSTCS, WLSTGS,
B RAC, RACS, SNC, SNCS, TSNOWC, TSNOWG,
C OVRFLW, SUBFLW, BASFLW,
D PCFC, PCLC, PCPN, PCPG, QFCF, QFCL,
E QFN, QFG, QFC, HMFN, HMFG,
F ROVG, ROFC, ROFN,
G DT, ZERO, IZERO, DELZZ,
G FC, FG, FCS, FGS,
H THLIQC, THLIQG, THICEC, THICEG, HCPC, HCPG,
I FSVF, FSVFS, RAICAN, SNOCAN, RAICNS, SNOCNS,
J EVAPC, EVAPCG, EVAPG, EVAPCS, EVPCSG, EVAPGS,
K RPCP, TRPCP, SPCP, TSPCP, RHOSNI,
L ZPOND, ZSNOW, ALBSNO, RHOSNO,
M THPOR, HCPS, ISAND, DELZW,
N ILG, IL1, IL2, JL, IG,
O NLANDCS,NLANDGS,NLANDC, NLANDG, RADD, SADD )
C
C * AUG 19/04 - Y.DELAGE. REGROUP COMMON BLOCKS
C * MAKE DECLARATIONS EXPLICIT
C * SEP 26/02 - D.VERSEGHY. MODIFICATIONS ASSOCIATED WITH BUGFIX
C * IN SUBCAN.
C * AUG 06/02 - D.VERSEGHY. SHORTENED CLASS3 COMMON BLOCK.
C * JUN 18/02 - D.VERSEGHY. MOVE PARTITIONING OF PRECIPITATION
C * BETWEEN RAINFALL AND SNOWFALL INTO
C * "CLASSI"; TIDY UP SUBROUTINE CALL;
C * CHANGE RHOSNI FROM CONSTANT TO
C * VARIABLE.
C * OCT 04/01 - M.LAZARE. NEW DIAGNOSTIC FIELD "ROVG".
C * NOV 09/00 - D.VERSEGHY. MOVE DIAGNOSTIC CALCULATIONS FROM
C * SUBCAN INTO THIS ROUTINE.
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 * JAN 02/95 - D.VERSEGHY. CLASS - VERSION 2.5.
C * COMPLETION OF ENERGY BALANCE
C * DIAGNOSTICS; INTRODUCE CALCULATION OF
C * OVERLAND FLOW.
C * AUG 24/95 - D.VERSEGHY. CLASS - VERSION 2.4.
C * RATIONALIZE USE OF "WLOST":
C * COMPLETION OF WATER BUDGET DIAGNOSTICS.
C * AUG 18/95 - D.VERSEGHY. 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 * INITIALIZE TWO NEW DIAGNOSTIC FIELDS.
C * AUG 20/93 - D.VERSEGHY. CLASS - VERSION 2.2.
C * REVISED CALCULATION OF CANOPY
C * SUBLIMATION RATE.
C * JUL 30/93 - D.VERSEGHY/M.LAZARE. NEW DIAGNOSTIC FIELDS.
C * APR 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. PREPARATION AND INITIALIZATION FOR
C * LAND SURFACE WATER BUDGET CALCULATIONS.
IMPLICIT NONE
INTEGER I,J,ILG, IL1, IL2, JL, IG,
1 NLANDCS,NLANDGS,NLANDC, NLANDG
C
C * OUTPUT ARRAYS.
C
REAL THLQCO(ILG,IG),THLQGO(ILG,IG),THLQCS(ILG,IG),THLQGS(ILG,IG),
1 THICCO(ILG,IG),THICGO(ILG,IG),THICCS(ILG,IG),THICGS(ILG,IG),
2 HCPCO (ILG,IG),HCPGO (ILG,IG),HCPCS (ILG,IG),HCPGS (ILG,IG),
3 QFC (ILG,IG),HMFG (ILG,IG)
C
REAL SPCC (ILG), SPCG (ILG), SPCCS (ILG), SPCGS (ILG),
1 TSPCC (ILG), TSPCG (ILG), TSPCCS(ILG), TSPCGS(ILG),
2 RPCC (ILG), RPCG (ILG), RPCCS (ILG), RPCGS (ILG),
3 TRPCC (ILG), TRPCG (ILG), TRPCCS(ILG), TRPCGS(ILG),
4 EVPIC (ILG), EVPIG (ILG), EVPICS(ILG), EVPIGS(ILG),
5 ZPONDC(ILG), ZPONDG(ILG), ZPNDCS(ILG), ZPNDGS(ILG),
6 XSNOWC(ILG), XSNOWG(ILG), XSNOCS(ILG), XSNOGS(ILG),
7 ZSNOWC(ILG), ZSNOWG(ILG), ZSNOCS(ILG), ZSNOGS(ILG),
8 ALBSC (ILG), ALBSG (ILG), ALBSCS(ILG), ALBSGS(ILG),
9 RHOSC (ILG), RHOSG (ILG), RHOSCS(ILG), RHOSGS(ILG),
A HCPSC (ILG), HCPSG (ILG), HCPSCS(ILG), HCPSGS(ILG),
B RUNFC (ILG), RUNFG (ILG), RUNFCS(ILG), RUNFGS(ILG)
C
REAL SUBLC (ILG), SUBLCS(ILG), WLOSTC(ILG), WLOSTG(ILG),
1 WLSTCS(ILG), WLSTGS(ILG), RAC (ILG), RACS (ILG),
2 SNC (ILG), SNCS (ILG), TSNOWC(ILG), TSNOWG(ILG),
3 OVRFLW(ILG), SUBFLW(ILG), BASFLW(ILG),
4 PCFC (ILG), PCLC (ILG), PCPN (ILG), PCPG (ILG),
5 QFCF (ILG), QFCL (ILG), QFN (ILG), QFG (ILG),
6 HMFN (ILG), ROVG (ILG), ROFC (ILG), ROFN (ILG),
7 DT (ILG), ZERO (ILG)
C
INTEGER IZERO (ILG)
C
C * INPUT ARRAYS.
C
REAL FC (ILG), FG (ILG), FCS (ILG), FGS (ILG),
1 FSVF (ILG), FSVFS (ILG), RAICAN(ILG), SNOCAN(ILG),
2 RAICNS(ILG), SNOCNS(ILG), EVAPC (ILG), EVAPCG(ILG),
3 EVAPG (ILG), EVAPCS(ILG), EVPCSG(ILG), EVAPGS(ILG),
4 RPCP (ILG), TRPCP (ILG), SPCP (ILG), TSPCP (ILG),
5 RHOSNI(ILG), ZPOND (ILG), ZSNOW (ILG), ALBSNO(ILG),
6 RHOSNO(ILG)
C
REAL THLIQC(ILG,IG),THLIQG(ILG,IG),THICEC(ILG,IG),THICEG(ILG,IG),
1 HCPC (ILG,IG),HCPG (ILG,IG)
C
C * SOIL INFORMATION ARRAYS.
C
REAL THPOR (ILG,IG),HCPS (ILG,IG),DELZZ (ILG,IG),
1 DELZW (ILG,IG)
C
INTEGER ISAND (ILG,IG)
C
C * INTERNAL WORK ARRAYS.
C
REAL RADD (ILG), SADD (ILG)
C
#include "class_com.cdk"
C-----------------------------------------------------------------------
C * INITIALIZE 2-D ARRAYS.
C
DO 50 J=1,IG
DO 50 I=IL1,IL2
THLQCO(I,J)=0.0
THLQGO(I,J)=0.0
THLQCS(I,J)=0.0
THLQGS(I,J)=0.0
THICCO(I,J)=0.0
THICGO(I,J)=0.0
THICCS(I,J)=0.0
THICGS(I,J)=0.0
HCPCO (I,J)=0.0
HCPGO (I,J)=0.0
HCPCS (I,J)=0.0
HCPGS (I,J)=0.0
QFC (I,J)=0.0
HMFG (I,J)=0.0
50 CONTINUE
C
C * INITIALIZE OTHER DIAGNOSTIC AND WORK ARRAYS.
C
DO 100 I=IL1,IL2
EVPICS(I)=EVAPCS(I)+EVPCSG(I)
EVPIGS(I)=EVAPGS(I)
EVPIC (I)=EVAPC (I)+EVAPCG(I)
EVPIG (I)=EVAPG (I)
TSNOWC(I)=0.0
TSNOWG(I)=0.0
WLOSTC(I)=0.0
WLOSTG(I)=0.0
WLSTCS(I)=0.0
WLSTGS(I)=0.0
RAC (I)=RAICAN(I)
RACS (I)=RAICNS(I)
SNC (I)=SNOCAN(I)
SNCS (I)=SNOCNS(I)
PCFC (I)=0.0
PCLC (I)=0.0
PCPN (I)=0.0
PCPG (I)=0.0
QFCF (I)=0.0
QFCL (I)=0.0
QFN (I)=0.0
QFG (I)=0.0
HMFN (I)=0.0
ROVG (I)=0.0
ROFC (I)=0.0
ROFN (I)=0.0
OVRFLW(I)=0.0
SUBFLW(I)=0.0
BASFLW(I)=0.0
ZPONDC(I)=0.0
ZPONDG(I)=0.0
ZPNDCS(I)=0.0
ZPNDGS(I)=0.0
XSNOWC(I)=0.0
XSNOWG(I)=0.0
XSNOCS(I)=0.0
XSNOGS(I)=0.0
ZSNOWC(I)=0.0
ZSNOWG(I)=0.0
ZSNOCS(I)=0.0
ZSNOGS(I)=0.0
ALBSC (I)=0.0
ALBSG (I)=0.0
ALBSCS(I)=0.0
ALBSGS(I)=0.0
RHOSC (I)=0.0
RHOSG (I)=0.0
RHOSCS(I)=0.0
RHOSGS(I)=0.0
HCPSC (I)=0.0
HCPSG (I)=0.0
HCPSCS(I)=0.0
HCPSGS(I)=0.0
RUNFC (I)=0.0
RUNFG (I)=0.0
RUNFCS(I)=0.0
RUNFGS(I)=0.0
DT (I)=DELT
ZERO (I)=0.
IZERO (I)=0
DELZZ (I,1)=DELZ(1)
DELZZ (I,2)=DELZ(2)
C DELZZ (I,2)=DELZW(I,2)
DELZZ (I,3)=DELZW(I,3)
C
C * PRECIPITATION DIAGNOSTICS.
C
IF(RPCP(I).GT.0.) THEN
PCLC(I)=(FCS(I)*(1.0-FSVFS(I))+FC(I)*(1.0-FSVF(I)))*
1 RPCP(I)*RHOW
PCPN(I)=(FCS(I)*FSVFS(I)+FGS(I))*RPCP(I)*RHOW
PCPG(I)=(FC(I)*FSVF(I)+FG(I))*RPCP(I)*RHOW
ENDIF
C
IF(SPCP(I).GT.0.) THEN
PCFC(I)=(FCS(I)*(1.0-FSVFS(I))+FC(I)*(1.0-FSVF(I)))*
1 SPCP(I)*RHOSNI(I)
PCPN(I)=PCPN(I)+(FCS(I)*FSVFS(I)+FGS(I)+
1 FC(I)*FSVF(I)+FG(I))*SPCP(I)*RHOSNI(I)
ENDIF
100 CONTINUE
C
C * RAINFALL/SNOWFALL RATES OVER GRID CELL SUBAREAS. DOWNWARD
C * WATER FLUXES ARE LUMPED TOGETHER WITH PRECIPITATION, AND
C * UPWARD AND DOWNWARD WATER FLUXES CANCEL OUT.
C
C * CALCULATIONS FOR CANOPY OVER SNOW.
C
IF(NLANDCS.GT.0) THEN
C
DO 200 J=1,IG
DO 200 I=IL1,IL2
IF(FCS(I).GT.0.) THEN
THLQCS(I,J)=THLIQC(I,J)
THICCS(I,J)=THICEC(I,J)
HCPCS (I,J)=HCPC (I,J)
ENDIF
200 CONTINUE
C
DO 250 I=IL1,IL2
IF(FCS(I).GT.0.) THEN
IF(SNOCNS(I).GT.0.) THEN
SUBLCS(I)=EVAPCS(I)*(CLHMLT+CLHVAP)*SNOCNS(I)/
1 (CLHVAP*RAICNS(I)+(CLHVAP+CLHMLT)*
2 SNOCNS(I))
EVAPCS(I)=EVAPCS(I)-SUBLCS(I)
ELSE
SUBLCS(I)=0.0
ENDIF
IF(SUBLCS(I).GT.0.0) THEN
QFCF(I)=QFCF(I)+FCS(I)*SUBLCS(I)*RHOW
ELSE
QFCF(I)=QFCF(I)+FCS(I)*(1.0-FSVFS(I))*SUBLCS(I)*
1 RHOW
QFN(I)=QFN(I)+FCS(I)*FSVFS(I)*SUBLCS(I)*RHOW
ENDIF
IF(EVAPCS(I).GT.0.0) THEN
QFCL(I)=QFCL(I)+FCS(I)*EVAPCS(I)*RHOW
ELSE
QFCL(I)=QFCL(I)+FCS(I)*(1.0-FSVFS(I))*EVAPCS(I)*
1 RHOW
QFN(I)=QFN(I)+FCS(I)*FSVFS(I)*EVAPCS(I)*RHOW
ENDIF
C
IF(SPCP(I).GT.0. .OR. SUBLCS(I).LT.0.) THEN
SADD(I)=SPCP(I)-SUBLCS(I)*RHOW/RHOSNI(I)
IF(SADD(I).GT.0.0) THEN
IF(SUBLCS(I).GT.0.) THEN
QFCF(I)=QFCF(I)-FCS(I)*FSVFS(I)*
1 SUBLCS(I)*RHOW
QFN(I)=QFN(I)+FCS(I)*FSVFS(I)*
1 SUBLCS(I)*RHOW
ENDIF
SPCCS (I)=SADD(I)
TSPCCS(I)=TSPCP(I)+TFREZ
SUBLCS(I)=0.0
ELSE
PCPN(I)=PCPN(I)-FCS(I)*FSVFS(I)*SPCP(I)*
1 RHOSNI(I)
PCFC(I)=PCFC(I)+FCS(I)*FSVFS(I)*SPCP(I)*
1 RHOSNI(I)
SUBLCS(I)=-SADD(I)*RHOSNI(I)/RHOW
SPCCS (I)=0.0
TSPCCS(I)=0.0
ENDIF
ELSE
SPCCS(I)=0.0
TSPCCS(I)=0.0
ENDIF
C
IF(RPCP(I).GT.0. .OR. EVAPCS(I).LT.0.) THEN
RADD(I)=RPCP(I)-EVAPCS(I)
if(ABS(RADD(I)) .LT. 1.0E-20) RADD(I) = 0.0
IF(RADD(I).GT.0.) THEN
IF(EVAPCS(I).GT.0.) THEN
QFCL(I)=QFCL(I)-FCS(I)*FSVFS(I)*
1 EVAPCS(I)*RHOW
QFN(I)=QFN(I)+FCS(I)*FSVFS(I)*
1 EVAPCS(I)*RHOW
ENDIF
RPCCS (I)=RADD(I)
TRPCCS(I)=TRPCP(I)+TFREZ
EVAPCS(I)=0.0
ELSE
PCPN(I)=PCPN(I)-FCS(I)*FSVFS(I)*RPCP(I)*RHOW
PCLC(I)=PCLC(I)+FCS(I)*FSVFS(I)*RPCP(I)*RHOW
EVAPCS(I)=-RADD(I)
RPCCS (I)=0.0
TRPCCS(I)=0.0
ENDIF
ELSE
RPCCS(I)=0.0
TRPCCS(I)=0.0
ENDIF
ZPNDCS(I)=ZPOND (I)
ZSNOCS(I)=ZSNOW (I)
ALBSCS(I)=ALBSNO(I)
RHOSCS(I)=RHOSNO(I)
HCPSCS(I)=HCPICE*RHOSNO(I)/RHOICE
QFN (I)=QFN(I)+FCS(I)*EVPCSG(I)*RHOW
ENDIF
250 CONTINUE
ENDIF
C
C * CALCULATIONS FOR SNOW-COVERED GROUND.
C
IF(NLANDGS.GT.0) THEN
C
DO 300 J=1,IG
DO 300 I=IL1,IL2
IF(FGS(I).GT.0.) THEN
THLQGS(I,J)=THLIQG(I,J)
THICGS(I,J)=THICEG(I,J)
HCPGS (I,J)=HCPG (I,J)
ENDIF
300 CONTINUE
C
DO 350 I=IL1,IL2
IF(FGS(I).GT.0.) THEN
QFN(I)=QFN(I)+FGS(I)*EVAPGS(I)*RHOW
IF(SPCP(I).GT.0. .OR. EVAPGS(I).LT.0.) THEN
SADD(I)=SPCP(I)-EVAPGS(I)*RHOW/RHOSNI(I)
IF(SADD(I).GT.0.0) THEN
SPCGS (I)=SADD(I)
TSPCGS(I)=TSPCP(I)
EVAPGS(I)=0.0
ELSE
EVAPGS(I)=-SADD(I)*RHOSNI(I)/RHOW
SPCGS (I)=0.0
TSPCGS(I)=0.0
ENDIF
ELSE
SPCGS (I)=0.0
TSPCGS(I)=0.0
ENDIF
C
IF(RPCP(I).GT.0.) THEN
RADD(I)=RPCP(I)-EVAPGS(I)
if(ABS(RADD(I)) .LT. 1.0E-20) RADD(I) = 0.0
IF(RADD(I).GT.0.) THEN
RPCGS (I)=RADD(I)
TRPCGS(I)=TRPCP(I)
EVAPGS(I)=0.0
ELSE
EVAPGS(I)=-RADD(I)
RPCGS (I)=0.0
TRPCGS(I)=0.0
ENDIF
ELSE
RPCGS (I)=0.0
TRPCGS(I)=0.0
ENDIF
ZPNDGS(I)=ZPOND (I)
ZSNOGS(I)=ZSNOW (I)
ALBSGS(I)=ALBSNO(I)
RHOSGS(I)=RHOSNO(I)
HCPSGS(I)=HCPICE*RHOSNO(I)/RHOICE
ENDIF
350 CONTINUE
ENDIF
C
C * CALCULATIONS FOR CANOPY OVER BARE GROUND.
C
IF(NLANDC.GT.0) THEN
C
DO 400 J=1,IG
DO 400 I=IL1,IL2
IF(FC(I).GT.0.) THEN
THLQCO(I,J)=THLIQC(I,J)
THICCO(I,J)=THICEC(I,J)
HCPCO (I,J)=HCPC (I,J)
ENDIF
400 CONTINUE
C
DO 450 I=IL1,IL2
IF(FC(I).GT.0.) THEN
IF(SNOCAN(I).GT.0.) THEN
SUBLC(I)=EVAPC(I)*(CLHMLT+CLHVAP)*SNOCAN(I)/
1 (CLHVAP*RAICAN(I)+(CLHVAP+CLHMLT)*
2 SNOCAN(I))
EVAPC(I)=EVAPC(I)-SUBLC(I)
ELSE
SUBLC(I)=0.0
ENDIF
IF(SUBLC(I).GT.0.0) THEN
QFCF(I)=QFCF(I)+FC(I)*SUBLC(I)*RHOW
ELSE
QFCF(I)=QFCF(I)+FC(I)*(1.0-FSVF(I))*SUBLC(I)*
1 RHOW
QFN(I)=QFN(I)+FC(I)*FSVF(I)*SUBLC(I)*RHOW
ENDIF
IF(EVAPC(I).GT.0.0) THEN
QFCL(I)=QFCL(I)+FC(I)*EVAPC(I)*RHOW
ELSE
QFCL(I)=QFCL(I)+FC(I)*(1.0-FSVF(I))*EVAPC(I)*
1 RHOW
QFG(I)=QFG(I)+FC(I)*FSVF(I)*EVAPC(I)*RHOW
ENDIF
C
IF(SPCP(I).GT.0. .OR. SUBLC(I).LT.0.) THEN
SADD(I)=SPCP(I)-SUBLC(I)*RHOW/RHOSNI(I)
IF(SADD(I).GT.0.0) THEN
IF(SUBLC(I).GT.0.) THEN
QFCF(I)=QFCF(I)-FC(I)*FSVF(I)*SUBLC(I)*
1 RHOW
QFN(I)=QFN(I)+FC(I)*FSVF(I)*SUBLC(I)*
1 RHOW
ENDIF
SPCC (I)=SADD(I)
TSPCC (I)=TSPCP(I)+TFREZ
SUBLC (I)=0.0
ELSE
PCPN(I)=PCPN(I)-FC(I)*FSVF(I)*SPCP(I)*
1 RHOSNI(I)
PCFC(I)=PCFC(I)+FC(I)*FSVF(I)*SPCP(I)*
1 RHOSNI(I)
SUBLC (I)=-SADD(I)*RHOSNI(I)/RHOW
SPCC (I)=0.0
TSPCC (I)=0.0
ENDIF
ELSE
SPCC (I)=0.0
TSPCC (I)=0.0
ENDIF
C
IF(RPCP(I).GT.0. .OR. EVAPC(I).LT.0.) THEN
RADD(I)=RPCP(I)-EVAPC(I)
if(ABS(RADD(I)) .LT. 1.0E-20) RADD(I) = 0.0
IF(RADD(I).GT.0.) THEN
IF(EVAPC(I).GT.0.) THEN
QFCL(I)=QFCL(I)-FC(I)*FSVF(I)*EVAPC(I)*
1 RHOW
QFG(I)=QFG(I)+FC(I)*FSVF(I)*EVAPC(I)*
1 RHOW
ENDIF
RPCC (I)=RADD(I)
TRPCC (I)=TRPCP(I)+TFREZ
EVAPC (I)=0.0
ELSE
PCPG(I)=PCPG(I)-FC(I)*FSVF(I)*RPCP(I)*RHOW
PCLC(I)=PCLC(I)+FC(I)*FSVF(I)*RPCP(I)*RHOW
EVAPC (I)=-RADD(I)
RPCC (I)=0.0
TRPCC (I)=0.0
ENDIF
ELSE
RPCC (I)=0.0
TRPCC (I)=0.0
ENDIF
ZPONDC(I)=ZPOND (I)
ZSNOWC(I)=0.
RHOSC (I)=0.
HCPSC (I)=0.
QFG (I)=QFG(I)+FC(I)*EVAPCG(I)*RHOW
ENDIF
450 CONTINUE
ENDIF
C
C * CALCULATIONS FOR BARE GROUND.
C
IF(NLANDG.GT.0) THEN
C
DO 500 J=1,IG
DO 500 I=IL1,IL2
IF(FG(I).GT.0.) THEN
THLQGO(I,J)=THLIQG(I,J)
THICGO(I,J)=THICEG(I,J)
HCPGO (I,J)=HCPG (I,J)
ENDIF
500 CONTINUE
C
DO 550 I=IL1,IL2
IF(FG(I).GT.0.) THEN
QFG(I)=QFG(I)+FG(I)*EVAPG(I)*RHOW
IF(SPCP(I).GT.0.) THEN
SADD(I)=SPCP(I)-EVAPG(I)*RHOW/RHOSNI(I)
IF(SADD(I).GT.0.0) THEN
QFN(I)=QFN(I)+FG(I)*EVAPG(I)*RHOW
QFG(I)=QFG(I)-FG(I)*EVAPG(I)*RHOW
SPCG (I)=SADD(I)
TSPCG (I)=TSPCP(I)
EVAPG (I)=0.0
ELSE
PCPN(I)=PCPN(I)-FG(I)*SPCP(I)*RHOSNI(I)
PCPG(I)=PCPG(I)+FG(I)*SPCP(I)*RHOSNI(I)
EVAPG (I)=-SADD(I)*RHOSNI(I)/RHOW
SPCG (I)=0.0
TSPCG (I)=0.0
ENDIF
ELSE
SPCG (I)=0.0
TSPCG (I)=0.0
ENDIF
C
IF(RPCP(I).GT.0. .OR. EVAPG(I).LT.0.) THEN
RADD(I)=RPCP(I)-EVAPG(I)
if(ABS(RADD(I)) .LT. 1.0E-20) RADD(I) = 0.0
IF(RADD(I).GT.0.) THEN
RPCG (I)=RADD(I)
TRPCG (I)=TRPCP(I)
EVAPG (I)=0.0
ELSE
EVAPG (I)=-RADD(I)
RPCG (I)=0.0
TRPCG (I)=0.0
ENDIF
ELSE
RPCG (I)=0.0
TRPCG(I)=0.0
ENDIF
ZPONDG(I)=ZPOND (I)
ZSNOWG(I)=0.
RHOSG (I)=0.
HCPSG (I)=0.
ENDIF
550 CONTINUE
ENDIF
C
RETURN
END