SUBROUTINE CHKWAT(ISFC,PCPR,EVAP,RUNOFF,WLOST,RAICAN,SNOCAN, 4,7
1 RAICNI,SNOCNI,ZPOND,ZPONDI,THLIQ,THICE,
2 THLIQI,THICEI,ZSNOW,RHOSNO,XSNOW,SNOWI,
3 FCS,FGS,FI,BAL,THPOR,THLMIN,DELZW,
4 ISAND,IG,ILG,IL1,IL2,JL )
C
C * AUG 19/04 - Y.DELAGE REGROUP COMMON BLOCKS
C MAKE EXPLICIT DECLARATIONS
C CORRECT A BUG AND FORCE BALANCE
C * JUN 25/02 - D.VERSEGHY. RENAME VARIABLES FOR CLARITY; UPDATES
C * CAUSED BY CONVERSION OF PONDING DEPTH
C * TO A PROGNOSTIC VARIABLE; SHORTENED
C * CLASS4 COMMON BLOCK.
C * MAY 23/02 - D.VERSEGHY. MOVE CALCULATION OF "XSNOW" INTO
C * THIS ROUTINE.
C * JUN 20/97 - D.VERSEGHY. CLASS - VERSION 2.7.
C * MODIFICATIONS TO ALLOW FOR VARIABLE
C * SOIL PERMEABLE DEPTH.
C * AUG 24/95 - D.VERSEGHY. CLASS - VERSION 2.4.
C * RATIONALIZE USE OF WLOST.
C * ALSO INTRODUCE NEW VALUE OF ACCLMT
C * CORRESPONDING TO 3 MM/YR AS USED
C * BY THE PILPS COMMUNITY.
C * AUG 18/95 - D.VERSEGHY. REVISIONS TO ALLOW FOR INHOMOGENEITY
C * BETWEEN SOIL LAYERS.
C * JAN 31/94 - D.VERSEGHY. LOCAL VERSION FOR CLIMATE RESEARCH
C * NETWORK: CHECK RAICAN AND SNOCAN
C * AGAINST -ACCLMT INSTEAD OF AGAINST 0.
C * AUG 16/93 - D.VERSEGHY. CLASS - VERSION 2.2.
C * RETURN WATER BALANCE CHECK TO ROUTINE
C * USE (COMMENTED OUT IN PREVIOUS VERSION)
C * AND RENAME SUBROUTINE FROM "CHKVAL"
C * TO "CHKWAT".
C * MAY 15/92 - M.LAZARE. CLASS - VERSION 2.1.
C * MOISTURE BALANCE CHECKS EXTRACTED FROM
C * "CLASSW" AND VECTORIZED.
C * APR 11/89 - D.VERSEGHY. THE FOLLOWING MOISTURE BALANCE CHECKS
C * ARE CARRIED OUT: INTERCEPTED MOISTURE
C * STORES AND LOCAL RUNOFF MUST BE .GE.0;
C * LIQUID SOIL LAYER MOISTURE STORES MUST
C * BE LESS THAN THE PORE VOLUME AND GREATER
C * THAN THE LIMITING VALUE "THLMIN"; FROZEN
C * SOIL LAYER MOISTURE STORES MUST BE LESS
C * THAN THE MAXIMUM AVAILABLE VOLUME (THE
C * PORE VOLUME - THLMIN) AND GE.0; AND THE
C * MOISTURE BALANCE OF THE TOTAL CANOPY/
C * SNOW/SOIL COLUMN MUST BE WITHIN A
C * SPECIFIED TOLERANCE. THE TOLERANCE
C * LEVEL ADOPTED IS DESIGNATED BY "ACCLMT".
C
C IMPLICIT NONE
INTEGER ISFC,IG,ILG,IL1,IL2,JL,I,KPTBAD,IPTBAD,JPTBAD,
1 IPTBDI,JPTBDI,KPTBDI,LPTBDI,IPTBDJ,JPTBDJ,KPTBDJ,LPTBDJ
REAL ACCLMT
C * INPUT FIELDS.
REAL PCPR (ILG), EVAP (ILG), RUNOFF(ILG), WLOST (ILG),
1 RAICAN(ILG), SNOCAN(ILG), RAICNI(ILG), SNOCNI(ILG),
2 ZPOND (ILG), ZPONDI(ILG), ZSNOW (ILG), RHOSNO(ILG),
3 XSNOW (ILG), SNOWI (ILG), FCS (ILG), FGS (ILG),
4 FI (ILG)
C
REAL THLIQ (ILG,IG), THICE (ILG,IG),
1 THLIQI(ILG,IG), THICEI(ILG,IG)
C
C * WORK ARRAYS.
C
REAL BAL (ILG)
C
C * SOIL INFORMATION ARRAYS.
C
REAL THPOR (ILG,IG), THLMIN(ILG,IG), DELZW (ILG,IG)
C
INTEGER ISAND (ILG,IG)
C
LOGICAL DIAGN
C
#include "class_com.cdk"
C
c ACCLMT=3.0*DELT/3.1536E7
data diagn / .false. /
ACCLMT=2.0E-2
C-----------------------------------------------------------------------
IF(ISFC.EQ.1 .OR. ISFC.EQ.3) THEN
IPTBAD=0
JPTBAD=0
ENDIF
KPTBAD=0
DO 100 I=IL1,IL2
IF(FI(I).GT.0. .AND. ISAND(I,1).GT.-4) THEN
IF(ISFC.EQ.1 .OR. ISFC.EQ.3) THEN
IF(RAICAN(I).LT.(-1.0*ACCLMT)) IPTBAD=I
IF(SNOCAN(I).LT.(-1.0*ACCLMT)) JPTBAD=I
ENDIF
IF(RUNOFF(I).LT.0.0) KPTBAD=I
ENDIF
100 CONTINUE
C
IF(ISFC.EQ.1 .OR. ISFC.EQ.3) THEN
IF(IPTBAD.NE.0) THEN
WRITE(6,6100) IPTBAD,JL,ISFC,RAICAN(IPTBAD)
6100 FORMAT('0AT (I,JL)=(',I3,',',I3,'), ISFC=',I2,' RAICAN = ',
1 E13.5)
CALL XIT('CHKWAT',-1)
ENDIF
IF(JPTBAD.NE.0) THEN
WRITE(6,6150) JPTBAD,JL,ISFC,SNOCAN(JPTBAD)
6150 FORMAT('0AT (I,JL)=(',I3,',',I3,'), ISFC=',I2,' SNOCAN = ',
1 E13.5)
CALL XIT('CHKWAT',-2)
ENDIF
ENDIF
IF(KPTBAD.NE.0) THEN
WRITE(6,6200) KPTBAD,JL,ISFC,RUNOFF(KPTBAD)
6200 FORMAT('0AT (I,JL)=(',I3,',',I3,'), ISFC=',I2,' RUNOFF = ',
1 E13.5)
CALL XIT('CHKWAT',-3)
ENDIF
C
IPTBDI=0
JPTBDI=0
KPTBDI=0
LPTBDI=0
DO 150 J=1,IG
DO 150 I=IL1,IL2
IF(FI(I).GT.0. .AND. ISAND(I,1).GT.-4) THEN
IF((THLIQ(I,J)-THPOR(I,J)).GT.ACCLMT) THEN
IPTBDI=I
IPTBDJ=J
ENDIF
IF(THLIQ(I,J).LT.(THLMIN(I,J)-ACCLMT) .AND.
1 ISAND(I,J).NE.-3) THEN
JPTBDI=I
JPTBDJ=J
ENDIF
IF((THICE(I,J)*RHOICE/RHOW-THPOR(I,J)+THLMIN(I,J))
1 .GT.ACCLMT.AND.ISAND(I,J).NE.-3) THEN
KPTBDI=I
KPTBDJ=J
ENDIF
IF(THICE(I,J).LT.-1.*ACCLMT) THEN
LPTBDI=I
LPTBDJ=J
ENDIF
ENDIF
150 CONTINUE
C
IF(IPTBDI.NE.0) THEN
WRITE(6,6250) IPTBDI,JL,ISFC,THLIQ(IPTBDI,IPTBDJ),
1 THPOR(IPTBDI,IPTBDJ),IPTBDJ
6250 FORMAT('0AT (I,JL)=(',I3,',',I3,'), ISFC=',I2,' THLIQ = ',
1 E13.5,' THPOR = ',E13.5,' FOR J=',I2)
CALL XIT('CHKWAT',-4)
ENDIF
IF(JPTBDI.NE.0) THEN
WRITE(6,6300) JPTBDI,JL,ISFC,THLIQ(JPTBDI,JPTBDJ),JPTBDJ
6300 FORMAT('0AT (I,JL)=(',I3,',',I3,'), ISFC=',I2,' THLIQ = ',
1 E13.5,' FOR J=',I2)
CALL XIT('CHKWAT',-5)
ENDIF
IF(KPTBDI.NE.0) THEN
WRITE(6,6350) KPTBDI,JL,ISFC,THICE(KPTBDI,KPTBDJ),
1 THPOR(KPTBDI,KPTBDJ),KPTBDJ
6350 FORMAT('0AT (I,JL)=(',I3,',',I3,'), ISFC=',I2,' THICE = ',
1 E13.5,' THPOR = ',E13.5,' FOR J=',I2)
CALL XIT('CHKWAT',-6)
ENDIF
IF(LPTBDI.NE.0) THEN
WRITE(6,6400) LPTBDI,JL,ISFC,THICE(LPTBDI,LPTBDJ),LPTBDJ
6400 FORMAT('0AT (I,JL)=(',I3,',',I3,'), ISFC=',I2,' THICE = ',
1 E13.5,' FOR J=',I2)
CALL XIT('CHKWAT',-7)
ENDIF
C
IPTBAD=0
IF(ISFC.EQ.1 .OR. ISFC.EQ.3) THEN
CANFAC=1.0
ELSE
CANFAC=0.0
ENDIF
DO 275 I=IL1,IL2
IF(FI(I).GT.0. .AND. ZSNOW(I).GT.0.) XSNOW(I)=1.0
IF(FI(I).GT.0. .AND. ISAND(I,1).GT.-4) THEN
IF(ISFC.EQ.1 .OR. ISFC.EQ.2) THEN
SNOFAC=1.0/(FCS(I)+FGS(I))
ELSE
SNOFAC=0.0
ENDIF
BAL(I)=PCPR(I)*DELT-
1 EVAP(I)*RHOW*DELT-RUNOFF(I)*RHOW+WLOST(I)-
2 CANFAC*(RAICAN(I)-RAICNI(I)+SNOCAN(I)-
3 SNOCNI(I))-(ZPOND(I)-ZPONDI(I))*RHOW-
4 (THLIQ(I,1)-THLIQI(I,1))*RHOW*DELZW(I,1)-
5 (THLIQ(I,2)-THLIQI(I,2))*RHOW*DELZW(I,2)-
6 (THLIQ(I,3)-THLIQI(I,3))*RHOW*DELZW(I,3)-
7 (THICE(I,1)-THICEI(I,1))*RHOICE*DELZW(I,1)-
8 (THICE(I,2)-THICEI(I,2))*RHOICE*DELZW(I,2)-
9 (THICE(I,3)-THICEI(I,3))*RHOICE*DELZW(I,3)
A -ZSNOW(I)*RHOSNO(I)+SNOFAC*SNOWI(I)
IF(ABS(BAL(I)).GT.ACCLMT.AND.DIAGN) THEN
IPTBAD=I
SNOFACB=SNOFAC
thliq1b=THLIQ(I,1)
zpondb=ZPOND(I)
ENDIF
IF(BAL(I).GT.0.) THEN
zpond(i)=ZPOND(I)+BAL(I)/RHOW
ELSE
THLIQ(I,1)=MAX(THLIQ(I,1)+BAL(I)/(RHOW*DELZW(I,1)),
1 THLMIN(I,1))
ENDIF
ENDIF
275 CONTINUE
IF(IPTBAD.NE.0) THEN
WRITE(6,6450) IPTBAD,JL,ISFC,BAL(IPTBAD)
WRITE(6,6460) PCPR(IPTBAD)*DELT,EVAP(IPTBAD)*RHOW*DELT,
1 RUNOFF(IPTBAD)*RHOW,WLOST(IPTBAD),
2 RAICNI(IPTBAD)-RAICAN(IPTBAD),SNOCNI(IPTBAD)-
3 SNOCAN(IPTBAD),(ZPOND(IPTBAD)-ZPONDI(IPTBAD))*RHOW
WRITE(6,6460)
1 (THLIQ1B -THLIQI(IPTBAD,1))*RHOW*DELZW(IPTBAD,1),
2 (THLIQ(IPTBAD,2)-THLIQI(IPTBAD,2))*RHOW*DELZW(IPTBAD,2),
3 (THLIQ(IPTBAD,3)-THLIQI(IPTBAD,3))*RHOW*DELZW(IPTBAD,3),
4 (THICE(IPTBAD,1)-THICEI(IPTBAD,1))*RHOICE*DELZW(IPTBAD,1),
5 (THICE(IPTBAD,2)-THICEI(IPTBAD,2))*RHOICE*DELZW(IPTBAD,2),
6 (THICE(IPTBAD,3)-THICEI(IPTBAD,3))*RHOICE*DELZW(IPTBAD,3)
WRITE(6,6460) ZSNOW(IPTBAD)*RHOSNO(IPTBAD),
1 SNOFACB*SNOWI(IPTBAD)
WRITE(6,6470) FCS(IPTBAD),FGS(IPTBAD)
6450 FORMAT('0AT (I,JL)=(',I3,',',I3,'), ISFC=',I2,' BAL = ',
1 E13.5)
6460 FORMAT(2X,7F15.8)
6470 FORMAT(2X,4E20.6)
WRITE(6,6460) THLIQ1B,THLIQ(IPTBAD,2),THLIQ(IPTBAD,3),
1 THLIQI(IPTBAD,1),THLIQI(IPTBAD,2),THLIQI(IPTBAD,3)
WRITE(6,6460) THICE(IPTBAD,1),THICE(IPTBAD,2),THICE(IPTBAD,3),
1 THICEI(IPTBAD,1),THICEI(IPTBAD,2),THICEI(IPTBAD,3)
WRITE(6,6460) DELZW(IPTBAD,1),DELZW(IPTBAD,2),DELZW(IPTBAD,3),
1 RAICNI(IPTBAD),RAICAN(IPTBAD),ZPONDB,
2 ZPONDI(IPTBAD)
c CALL XIT('CHKWAT',-8)
ENDIF
RETURN
END