SUBROUTINE GRINFL(IVEG,THLIQ,THICE,TBARW,BASFLW,RUNOFF, 4,5
1 QFG,WLOST,FI,EVAP,R,TR,TPOND,ZPOND,DT,
2 ZMAT,WMOVE,TMOVE,THLIQX,THICEX,TBARWX,
3 DELZX,ZBOTX,FDT,TFDT,PSIF,THLINF,GRKINF,
4 THLMAX,THTEST,ZRMDR,FDUMMY,TDUMMY,THLDUM,
5 THIDUM,TDUMW,TRMDR,ZF,FMAX,TUSED,RDUMMY,
6 ZERO,WEXCES,FDTBND,WADD,TADD,WADJ,TIMPND,
7 DZF,DTFLOW,THLNLZ,THLQLZ,DZDISP,WDISP,WABS,
8 THPOR,THLRET,THLMIN,BI,PSISAT,GRKSAT,GRKTLD,
9 THLRAT,DELZW,ZBOTW,XDRAIN,ISAND,IGRN,
A IGRD,IFILL,IZERO,LZF,NINF,IFIND,ITER,
B NEND,ISIMP,IG,IGP1,IGP2,ILG,IL1,IL2,JL )
C
C * AUG 19/04 - Y.DELAGE. REGROUP COMMON BLOCKS
C * MAKE DECLARATIONS EXPLICIT
C * JUL 26/02 - D.VERSEGHY. SHORTENED CLASS4 COMMON BLOCK.
C * DEC 12/01 - D.VERSEGHY. PASS NEW VARIABLE IN FOR CALCULATION
C * OF BASEFLOW.
C * JUN 20/97 - D.VERSEGHY. CLASS - VERSION 2.7.
C * MODIFICATIONS TO ALLOW FOR VARIABLE
C * SOIL PERMEABLE DEPTH.
C * APR 17/96 - D.VERSEGHY. CLASS - VERSION 2.5.
C * BUG FIX: INITIALIZE FDT AND TFDT
C * TO ZERO.
C * AUG 18/95 - D.VERSEGHY. CLASS - VERSION 2.4.
C * REVISIONS TO ALLOW FOR INHOMOGENEITY
C * BETWEEN SOIL LAYERS.
C * APR 24/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. UPDATE SOIL LAYER TEMPERATURES AND
C * LIQUID MOISTURE CONTENTS FOR
C * INFILTRATING CONDITIONS (I.E.
C * PONDED WATER OR RAINFALL OCCURRING
C * WITHIN CURRENT TIMESTEP).
C
IMPLICIT NONE
INTEGER IVEG,IG,IGP1,IGP2,ILG,IL1,IL2,JL,I,J
REAL THLPOT,THLTLD,PSIINF,GRK,PSI
C * INPUT/OUTPUT FIELDS.
C
REAL THLIQ (ILG,IG), THICE (ILG,IG), TBARW (ILG,IG)
C
REAL BASFLW(ILG), RUNOFF(ILG), QFG (ILG),
1 WLOST (ILG)
C
C * INPUT FIELDS.
C
REAL FI (ILG), EVAP (ILG), R (ILG), TR (ILG),
1 TPOND (ILG), ZPOND (ILG), DT (ILG)
C
C * WORK FIELDS (FOR ALL CALLED ROUTINES AS WELL).
C
REAL ZMAT (ILG,IGP2,IGP1)
C
REAL WMOVE (ILG,IGP2), TMOVE (ILG,IGP2)
C
REAL THLIQX(ILG,IGP1), THICEX(ILG,IGP1), TBARWX(ILG,IGP1),
1 DELZX (ILG,IGP1), ZBOTX (ILG,IGP1), FDT (ILG,IGP1),
2 TFDT (ILG,IGP1), PSIF (ILG,IGP1), THLINF(ILG,IGP1),
3 GRKINF(ILG,IGP1), THLMAX(ILG,IG), THTEST(ILG,IG),
4 ZRMDR (ILG,IGP1), FDUMMY(ILG,IGP1), TDUMMY(ILG,IGP1),
5 THLDUM(ILG,IG), THIDUM(ILG,IG), TDUMW (ILG,IG)
C
REAL TRMDR (ILG), ZF (ILG), FMAX (ILG), TUSED (ILG),
1 RDUMMY(ILG), ZERO (ILG), WEXCES(ILG), FDTBND(ILG),
2 WADD (ILG), TADD (ILG), WADJ (ILG), TIMPND(ILG),
3 DZF (ILG), DTFLOW(ILG), THLNLZ(ILG), THLQLZ(ILG),
4 DZDISP(ILG), WDISP (ILG), WABS (ILG)
C
C * SOIL INFORMATION ARRAYS.
C
REAL THPOR (ILG,IG), THLRET(ILG,IG), THLMIN(ILG,IG),
1 BI (ILG,IG), PSISAT(ILG,IG), GRKSAT(ILG,IG),
3 GRKTLD(ILG,IG), THLRAT(ILG,IG), DELZW (ILG,IG),
4 ZBOTW (ILG,IG), XDRAIN(ILG)
C
C * VARIOUS INTEGER ARRAYS.
C
INTEGER ISAND (ILG,IG), IGRN (ILG), IGRD (ILG),
1 IFILL (ILG), IZERO (ILG), LZF (ILG),
2 NINF (ILG), IFIND (ILG), ITER (ILG),
3 NEND (ILG), ISIMP (ILG)
C
#include "class_com.cdk"
C-----------------------------------------------------------------------
C * DETERMINE POINTS WHICH SATISFY CONDITIONS FOR THESE CALCULATIONS
C * AND STORE THEM AS HAVING NON-ZERO VALUES FOR WORK ARRAY "IGRN".
C
DO 50 I=IL1,IL2
IF(FI(I).GT.0. .AND.
1 ISAND(I,1).GT.-4 .AND. DT(I).GT.0. .AND.
2 (R(I).GT.0. .OR. ZPOND(I).GT.0.)) THEN
IGRN(I)=1
IFILL(I)=0
RDUMMY(I)=0.
ELSE
IGRN(I)=0
IFILL(I)=0
ENDIF
50 CONTINUE
C
C * INITIALIZATION; DETERMINATION OF SOIL HYDRAULIC CONDUCTIVITIES
C * AND SOIL MOISTURE SUCTION ACROSS WETTING FRONT.
C
DO 100 J=1,IG
DO 100 I=IL1,IL2
IF(IGRN(I).GT.0) THEN
THLPOT=THPOR(I,J)-THICE(I,J)*RHOICE/RHOW
THLTLD=THLRAT(I,J)*THPOR(I,J)
THLIQX(I,J)=THLIQ(I,J)
THICEX(I,J)=THICE(I,J)
TBARWX(I,J)=TBARW(I,J)
DELZX(I,J)=DELZW(I,J)
ZBOTX(I,J)=ZBOTW(I,J)
FDT (I,J)=0.0
TFDT(I,J)=0.0
IF(THLIQ(I,J).GT.MIN(THLTLD,THLPOT)) THEN
THLINF(I,J)=MAX(THLIQ(I,J),THLMIN(I,J))
GRKINF(I,J)=MIN(GRKSAT(I,J)*(THLINF(I,J)/THPOR(I,J))
1 **(2.*BI(I,J)+3.), GRKSAT(I,J))
ELSE
IF(THICE(I,J).GT.0.) THEN
THLINF(I,J)=MIN(THLTLD,MAX(THLPOT,THLMIN(I,J)))
GRKINF(I,J)=MIN(GRKSAT(I,J)*(THLINF(I,J)/
1 THPOR(I,J))**(2.*BI(I,J)+3.), GRKTLD(I,J))
ELSE
THLINF(I,J)=THLTLD
GRKINF(I,J)=GRKTLD(I,J)
ENDIF
ENDIF
ENDIF
100 CONTINUE
C
DO 150 I=IL1,IL2
IF(IGRN(I).GT.0) THEN
THLIQX(I,IG+1)=THLIQX(I,IG)
THICEX(I,IG+1)=THICEX(I,IG)
TBARWX(I,IG+1)=TBARWX(I,IG)
IF(XDRAIN(I).GT.0.0) THEN
DELZX(I,IG+1)=999994.9
ELSE
DELZX(I,IG+1)=0.0
ENDIF
ZBOTX (I,IG+1)=999999.
FDT (I,IG+1)=0.0
TFDT (I,IG+1)=0.0
THLINF(I,IG+1)=THLINF(I,IG)
GRKINF(I,IG+1)=GRKINF(I,IG)*XDRAIN(I)
ENDIF
150 CONTINUE
C
DO 200 J=1,IG
DO 200 I=IL1,IL2
IF(IGRN(I).GT.0) THEN
IF(THPOR(I,J).GT.0.) THEN
PSIINF=MAX(PSISAT(I,J)*(THLINF(I,J)/THPOR(I,J))**
1 (-BI(I,J)),PSISAT(I,J))
GRK=MIN(GRKSAT(I,J)*(THLIQ(I,J)/THPOR(I,J))**
1 (2.*BI(I,J)+3.),GRKSAT(I,J))
PSI=MAX(PSISAT(I,J)*(THLIQ(I,J)/THPOR(I,J))**
1 (-BI(I,J)),PSISAT(I,J))
ELSE
PSIINF=PSISAT(I,J)
GRK=GRKSAT(I,J)
PSI=PSISAT(I,J)
ENDIF
IF(THLINF(I,J).GT.THLIQ(I,J)) THEN
PSIF(I,J)=MAX(BI(I,J)*(GRKINF(I,J)*PSIINF-GRK*PSI)/
1 (GRKSAT(I,J)*(BI(I,J)+3.)), 0.0)
ELSE
PSIF(I,J)=0.0
ENDIF
ENDIF
200 CONTINUE
C
DO 250 I=IL1,IL2
IF(IGRN(I).GT.0) THEN
PSIF(I,IG+1)=PSIF(I,IG)
TRMDR(I)=DELT
ELSE
TRMDR(I)=0.
ENDIF
250 CONTINUE
C
DO 300 J=1,IGP2
DO 300 I=IL1,IL2
IF(IGRN(I).GT.0) THEN
WMOVE(I,J)=0.0
TMOVE(I,J)=0.0
ENDIF
300 CONTINUE
C
C * DETERMINE STARTING POSITION OF WETTING FRONT; INITIALIZATION
C * FOR SATURATED INFILTRATION.
C * (FOR FOLLOWING LOOPS VECTORIZATION AND OPTIMIZATION ARE ENHANCED
C * BY UNROLLING THE INNER-MOST LOOP. THIS EXPLICITLY ASSUMES THAT
C * IG=3 AND THE ROUTINE IS ABORTED IF SUCH IS NOT THE CASE.)
C
IF(IG.NE.3) CALL XIT('GRINFL',-1)
DO 400 I=IL1,IL2
IF(IGRN(I).GT.0) THEN
IF(THLIQ(I,1).GE.THLINF(I,1)-1.e-6 .AND.
1 THLIQ(I,2).GE.THLINF(I,2)-1.e-6 .AND.
2 THLIQ(I,3).GE.THLINF(I,3)-1.e-6) THEN
ZF(I)=ZBOTW(I,3)
LZF(I)=4
NINF(I)=5
WMOVE(I,2)=THLIQ(I,1)*DELZW(I,1)
TMOVE(I,2)=TBARW(I,1)
WMOVE(I,3)=THLIQ(I,2)*DELZW(I,2)
TMOVE(I,3)=TBARW(I,2)
WMOVE(I,4)=THLIQ(I,3)*DELZW(I,3)
TMOVE(I,4)=TBARW(I,3)
TMOVE(I,NINF(I))=TBARWX(I,LZF(I))
FMAX(I)=MIN(GRKINF(I,1),GRKINF(I,2),GRKINF(I,3))
ELSE IF(THLIQ(I,1).GE.THLINF(I,1)-1.e-6 .AND.
1 THLIQ(I,2).GE.THLINF(I,2)-1.e-6) THEN
ZF(I)=ZBOTW(I,2)
LZF(I)=3
NINF(I)=4
WMOVE(I,2)=THLIQ(I,1)*DELZW(I,1)
TMOVE(I,2)=TBARW(I,1)
WMOVE(I,3)=THLIQ(I,2)*DELZW(I,2)
TMOVE(I,3)=TBARW(I,2)
TMOVE(I,NINF(I))=TBARWX(I,LZF(I))
FMAX(I)=MIN(GRKINF(I,1),GRKINF(I,2))
ELSE IF(THLIQ(I,1).GE.THLINF(I,1)-1.e-6) THEN
ZF(I)=ZBOTW(I,1)
LZF(I)=2
NINF(I)=3
WMOVE(I,2)=THLIQ(I,1)*DELZW(I,1)
TMOVE(I,2)=TBARW(I,1)
TMOVE(I,NINF(I))=TBARWX(I,LZF(I))
FMAX(I)=GRKINF(I,1)
ELSE IF(ZPOND(I).GT.0. .OR. GRKINF(I,1).LE.0.) THEN
ZF(I)=0.0
LZF(I)=1
NINF(I)=2
TMOVE(I,NINF(I))=TBARWX(I,LZF(I))
FMAX(I)=999999.
ELSE
IFILL(I)=1
ENDIF
ENDIF
400 CONTINUE
C
C * IF SATURATED INFILTRATION CONDITIONS ARE NOT PRESENT AT ONCE
C * (IFILL=1), CALL "WFILL" TO DO PROCESSING FOR PERIOD OF
C * UNSATURATED INFILTRATION.
C
CALL WFILL(WMOVE,TMOVE,LZF,NINF,ZF,TRMDR,R,TR,
1 PSIF,GRKINF,THLINF,THLIQX,TBARWX,
2 DELZX,ZBOTX,DZF,TIMPND,WADJ,WADD,
3 IFILL,IFIND,IG,IGP1,IGP2,ILG,IL1,IL2,JL )
C
DO 500 I=IL1,IL2
IF(IFILL(I).GT.0) THEN
FMAX(I)=999999.
ENDIF
500 CONTINUE
C
DO 600 J=1,IGP1
DO 600 I=IL1,IL2
IF(IFILL(I).GT.0 .AND. LZF(I).GT.1 .AND. J.LT.LZF(I)) THEN
FMAX(I)=MIN(GRKINF(I,J),FMAX(I))
ENDIF
600 CONTINUE
C
C * CALL "WFLOW" TO DO PROCESSING FOR PERIOD OF SATURATED
C * INFILTRATION.
C
CALL WFLOW(WMOVE,TMOVE,LZF,NINF,TRMDR,TPOND,ZPOND,
1 R,TR,EVAP,PSIF,GRKINF,THLINF,THLIQX,TBARWX,
2 DELZX,ZBOTX,FMAX,ZF,DZF,DTFLOW,THLNLZ,
3 THLQLZ,DZDISP,WDISP,WABS,ITER,NEND,ISIMP,
4 IGRN,IG,IGP1,IGP2,ILG,IL1,IL2,JL )
C
C * RECALCULATE TEMPERATURES AND LIQUID MOISTURE CONTENTS OF
C * SOIL LAYERS FOLLOWING INFILTRATION.
C
CALL WEND(THLIQX,THICEX,TBARWX,BASFLW,RUNOFF,FI,
1 WMOVE,TMOVE,LZF,NINF,TRMDR,THLINF,DELZX,
2 ZMAT,ZRMDR,FDTBND,WADD,TADD,FDT,TFDT,
3 THLMAX,THTEST,THLDUM,THIDUM,TDUMW,
4 TUSED,RDUMMY,ZERO,WEXCES,XDRAIN,
5 THPOR,THLRET,THLMIN,BI,PSISAT,GRKSAT,
6 DELZW,ISAND,IGRN,IGRD,IZERO,
7 IVEG,IG,IGP1,IGP2,ILG,IL1,IL2,JL )
C
DO 800 J=1,IG
DO 800 I=IL1,IL2
IF(IGRN(I).GT.0) THEN
THLIQ(I,J)=THLIQX(I,J)
THICE(I,J)=THICEX(I,J)
TBARW(I,J)=TBARWX(I,J)
ENDIF
800 CONTINUE
C
C * IF TIME REMAINS IN THE CURRENT MODEL STEP AFTER INFILTRATION
C * HAS CEASED (TRMDR>0), CALL "GRDRAN" TO CALCULATE WATER FLOWS
C * BETWEEN LAYERS FOR THE REMAINDER OF THE TIME STEP.
C
CALL GRDRAN(IVEG,THLIQ,THICE,TBARW,FDUMMY,TDUMMY,
1 BASFLW,RUNOFF,QFG,WLOST,FI,EVAP,ZERO,ZERO,
2 TRMDR,WEXCES,THLMAX,THTEST,THPOR,THLRET,THLMIN,
3 BI,PSISAT,GRKSAT,DELZW,XDRAIN,ISAND,IZERO,
4 IGRD,IG,IGP1,IGP2,ILG,IL1,IL2,JL )
C
RETURN
END