SUBROUTINE TPREP(THLIQC, THLIQG, THICEC, THICEG, TBARC, TBARG, 1
1 TBARCS, TBARGS, HCPC, HCPG, TCTOP, TCBOT,
2 HCPSNO, TCSNOW, TSNOCS, TSNOGS, TCANO, TCANS,
3 CEVAP, IEVAP, TBAR1P, HCP1P, WTABLE, FTEMP,
4 EVAPC, EVAPCG, EVAPG, EVAPCS, EVPCSG, EVAPGS,
5 GSNOWC, GSNOWG, GZEROC, GZEROG, QMELTC, QMELTG,
6 ST, SU, SV, SQ, CDH, CDM,
7 TSURF, QSENS, QEVAP, QLWAVG, ILMO, H,
8 FSGV, FSGS, FSGG, FLGV, FLGS, FLGG,
9 HFSC, HFSS, HFSG, HEVC, HEVS, HEVG,
A HMFC, EVPPOT, ACOND, DRAG, UE, FVAP,
B THLIQ, THICE, TBAR, ZPOND, TPOND,
C THPOR, THLMIN, THLRET, THFC, HCPS, TCS,
D TA, RHOSNO, TSNOW, ZSNOW, TCAN,
E FC, FCS, DELZW, ZBOTW, GZROCS, GZROGS,
F ISAND, ILG, IL1, IL2, JL, IG,
G FVEG, TCSAT )
C
C * AUG 19/04 - Y.DELAGE. REGROUP COMMON BLOCKS
C * MAKE DECLARATIONS EXPLICIT
C * JUL 30/02 - D.VERSEGHY. MOVE CALCULATION OF VEGETATION
C * STOMATAL RESISTANCE INTO APREP
C * AND CANALB; SHORTENED CLASS3
C * COMMON BLOCK.
C * JUN 17/02 - D.VERSEGHY. NEW THERMAL ARRAYS FOR SURFACE
C * TEMPERATURE ITERATION, WITH PONDED
C * WATER ROLLED INTO SOIL UPPER LAYER;
C * SHORTENED CLASS4 COMMON BLOCK.
C * MAR 20/02 - D.VERSEGHY. MOVE CALCULATION OF BACKGROUND SOIL
C * PROPERTIES INTO "CLASSB"; UPDATES
C * TO MAKE ZPOND A PROGNOSTIC VARIABLE.
C * FEB 27/02 - D.VERSEGHY. RECALCULATE WILTING POINT BASED ON
C * FIELD CAPACITY.
C * JAN 18/02 - D.VERSEGHY. INTRODUCTION OF CALCULATION OF FIELD
C * CAPACITY AND NEW BARE SOIL EVAPORATION
C * PARAMETERS.
C * APR 11/01 - M.LAZARE. SHORTENED "CLASS2" COMMON BLOCK.
C * NOV 01/00 - A.WU/D.VERSEGHY. EXTEND MINERAL SOIL CALCULATION
C * OF SOIL EVAPORATION "BETA" TO
C * ORGANIC SOILS.
C * SEP 19/00 - A.WU/D.VERSEGHY. CHANGE CALCULATION OF THERMAL
C * CONDUCTIVITY FOR ORGANIC SOILS,
C * USING METHOD OF FAROUKI (1981).
C * ALSO, CALCULATE STOMATAL RESISTANCE
C * USING VEGETATION-VARYING
C * COEFFICIENTS FOR ENVIRONMENTAL
C * VARIABLES.
C * FEB 14/00 - D.VERSEGHY. INSERT CALCULATION OF WATER TABLE DEPTH
C * FOR ORGANIC SOILS.
C * DEC 07/99 - A.WU/D.VERSEGHY. INCORPORATE CALCULATION OF "BETA"
C * PARAMETER FOR NEW SOIL EVAPORATION
C * FORMULATION.
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 24/97 - D.VERSEGHY. CLASS - VERSION 2.6.
C * SET RC AND RCS TO ZERO FOR GRID CELLS
C * WITH NO VEGETATION.
C * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5.
C * COMPLETION OF ENERGY BALANCE
C * DIAGNOSTICS.
C * AUG 30/95 - D.VERSEGHY. CLASS - VERSION 2.4.
C * REMOVE SUBTRACTION OF RESIDUAL SOIL
C * MOISTURE CONTENT IN CALCULATIONS OF
C * "PSIZRO" AND "PSII".
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 THREE NEW DIAGNOSTIC FIELDS.
C * NOV 12/94 - D.VERSEGHY. SET INITIAL TEMPERATURE OF EMERGING
C * CANOPY TO TA INSTEAD OF TO ZERO.
C * JAN 31/94 - D.VERSEGHY. CLASS - VERSION 2.2.
C * INTRODUCE LIMITING VALUES INTO
C * CALCULATION OF "PSIZRO" TO AVOID
C * OVERFLOWS.
C * JUL 27/93 - D.VERSEGHY/M.LAZARE. INITIALIZE NEW DIAGNOSTIC
C * FIELDS FSGV,FSGG,FLGV,FLGG,
C * HFSC,HFSG,HMFC.
C * MAY 06/93 - D.VERSEGHY/M.LAZARE. CLASS - VERSION 2.1.
C * MODIFICATIONS TO CANOPY
C * RESISTANCE TO ADD "RCS"
C * FIELD FOR SNOW-COVERED
C * CANOPY.
C * JUL 04/92 - D.VERSEGHY/M.LAZARE. 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 ENERGY BUDGET
C * CALCULATIONS.
C
IMPLICIT NONE
INTEGER ILG, IL1, IL2, JL, IG,I,J
REAL THSNOW,SATRAT,THLSAT,THISAT,P1,P2,P3,TCSOIL
C
C * OUTPUT ARRAYS.
C
REAL TBARC (ILG,IG),TBARG (ILG,IG),TBARCS(ILG,IG),TBARGS(ILG,IG),
1 THLIQC(ILG,IG),THLIQG(ILG,IG),THICEC(ILG,IG),THICEG(ILG,IG),
2 HCPC (ILG,IG),HCPG (ILG,IG),TCTOP (ILG,IG),TCBOT (ILG,IG)
C
REAL HCPSNO(ILG), TCSNOW(ILG), TSNOGS(ILG), TSNOCS(ILG),
1 TCANO (ILG), TCANS (ILG), CEVAP (ILG),
2 TBAR1P(ILG), HCP1P (ILG), WTABLE(ILG)
C
INTEGER IEVAP (ILG)
C
C * OUTPUT ARRAYS WHICH ARE INTERNAL WORK ARRAYS FOR CLASST
C * AND ARE INITIALIZED TO ZERO HERE.
C
REAL EVAPC (ILG), EVAPCG(ILG), EVAPG (ILG), EVAPCS(ILG),
1 EVPCSG(ILG), EVAPGS(ILG), GSNOWC(ILG), GSNOWG(ILG),
2 GZEROC(ILG), GZEROG(ILG), QMELTC(ILG), QMELTG(ILG),
3 GZROCS(ILG), GZROGS(ILG)
C
C * DIAGNOSTIC ARRAYS.
C
REAL ST (ILG), SU (ILG), SV (ILG), SQ (ILG),
1 CDH (ILG), CDM (ILG), TSURF (ILG), FTEMP (ILG),
2 QSENS (ILG), QEVAP (ILG), QLWAVG(ILG), FVAP (ILG),
3 FSGV (ILG), FSGS (ILG), FSGG (ILG), FLGV (ILG),
4 FLGS (ILG), FLGG (ILG), HFSC (ILG), HFSS (ILG),
5 HFSG (ILG), HEVC (ILG), HEVS (ILG), HEVG (ILG),
6 HMFC (ILG), EVPPOT(ILG), ACOND (ILG), DRAG (ILG),
7 ILMO (ILG), H (ILG), UE (ILG)
C
C * INPUT ARRAYS.
C
REAL THLIQ (ILG,IG),THICE (ILG,IG),TBAR (ILG,IG),
1 ZPOND (ILG), TPOND (ILG)
C
REAL TA (ILG), RHOSNO(ILG), TSNOW (ILG), ZSNOW (ILG),
1 TCAN (ILG), FC (ILG), FCS (ILG)
C
C * SOIL PROPERTY ARRAYS.
C
REAL THPOR(ILG,IG), THLMIN(ILG,IG),THLRET(ILG,IG),
1 THFC (ILG,IG),HCPS (ILG,IG),TCS (ILG,IG)
REAL DELZW(ILG,IG), ZBOTW(ILG,IG)
C
INTEGER ISAND (ILG,IG)
C
C * INTERNAL WORK FIELDS FOR THIS ROUTINE.
C
REAL FVEG (ILG), TCSAT (ILG)
C
#include "class_com.cdk"
C----------------------------------------------------------------------
C * INITIALIZE 2-D ARRAYS.
C
DO 50 J=1,IG
DO 50 I=IL1,IL2
THLIQG(I,J)=THLIQ(I,J)
THICEG(I,J)=THICE(I,J)
THLIQC(I,J)=THLIQ(I,J)
THICEC(I,J)=THICE(I,J)
TBARCS(I,J)=0.0
TBARGS(I,J)=0.0
TBARC (I,J)=0.0
TBARG (I,J)=0.0
50 CONTINUE
C
C * INITIALIZE 1-D INTERNAL WORK FIELDS FOR LATER USE.
C
DO 100 I=IL1,IL2
FVEG (I)=FC(I)+FCS(I)
IF(TCAN(I).GT.5.0) THEN
TCANS (I)=TCAN(I)
TCANO (I)=TCAN(I)
ELSE
TCANS (I)=TA(I)
TCANO (I)=TA(I)
ENDIF
EVAPC (I)=0.
EVAPCG(I)=0.
EVAPG (I)=0.
EVAPCS(I)=0.
EVPCSG(I)=0.
EVAPGS(I)=0.
GSNOWC(I)=0.
GSNOWG(I)=0.
GZEROC(I)=0.
GZEROG(I)=0.
GZROCS(I)=0.
GZROGS(I)=0.
QMELTC(I)=0.
QMELTG(I)=0.
ST (I)=0.
SU (I)=0.
SV (I)=0.
SQ (I)=0.
CDH (I)=0.
FTEMP (I)=0.
FVAP (I)=0.
CDM (I)=0.
TSURF (I)=0.
QSENS (I)=0.
QEVAP (I)=0.
QLWAVG(I)=0.
FSGV (I)=0.
FSGS (I)=0.
FSGG (I)=0.
FLGV (I)=0.
FLGS (I)=0.
FLGG (I)=0.
HFSC (I)=0.
HFSS (I)=0.
HFSG (I)=0.
HEVC (I)=0.
HEVS (I)=0.
HEVG (I)=0.
HMFC (I)=0.
EVPPOT(I)=0.
ACOND (I)=0.
DRAG (I)=0.
ILMO (I)=0.
UE (I)=0.
H (I)=0.
WTABLE(I)=9999.
100 CONTINUE
C
C * SURFACE EVAPORATION EFFICIENCY FOR BARE SOIL ENERGY BALANCE
C * CALCULATIONS.
C
DO 200 I=IL1,IL2
IF(THLIQG(I,1).LE.(THLMIN(I,1)+0.001)) THEN
IEVAP(I)=0
CEVAP(I)=0.0
ELSEIF(THLIQG(I,1).GE.THFC(I,1)) THEN
IEVAP(I)=1
CEVAP(I)=1.0
ELSE
IEVAP(I)=1
CEVAP(I)=0.25*(1.0-COS(3.14159*THLIQG(I,1)/THFC(I,1)))**2
ENDIF
200 CONTINUE
C
C * VOLUMETRIC HEAT CAPACITIES OF SOIL LAYERS AND DEPTH OF
C * WATER TABLE IN ORGANIC SOILS.
C
DO 300 J=1,IG
DO 300 I=IL1,IL2
IF(ISAND(I,1).GT.-4) THEN
HCPC(I,J)=0.
HCPG(I,J)=0.
IF(FVEG(I).LT.1.) THEN
HCPG(I,J)=HCPW*THLIQG(I,J)+HCPICE*THICEG(I,J)+
1 HCPS(I,J)*(1.0-THPOR(I,J))
ENDIF
IF(FVEG(I).GT.0.) THEN
HCPC(I,J)=HCPW*THLIQC(I,J)+HCPICE*THICEC(I,J)+
1 HCPS(I,J)*(1.0-THPOR(I,J))
ENDIF
ELSE
HCPC(I,J)=HCPICE
HCPG(I,J)=HCPICE
ENDIF
300 CONTINUE
C
C * THERMAL PROPERTIES OF SNOW.
C
DO 400 I=IL1,IL2
IF(ZSNOW(I).GT.0.) THEN
THSNOW=RHOSNO(I)/RHOICE
HCPSNO(I)=HCPICE*THSNOW
TCSNOW(I)=2.576E-6*RHOSNO(I)*RHOSNO(I)+0.074
IF(FVEG(I).LT.1.) THEN
TSNOGS(I)=TSNOW(I)
ELSE
TSNOGS(I)=0.0
ENDIF
IF(FVEG(I).GT.0.) THEN
TSNOCS(I)=TSNOW(I)
ELSE
TSNOCS(I)=0.0
ENDIF
ELSE
TSNOGS(I)=0.0
TSNOCS(I)=0.0
ENDIF
400 CONTINUE
C
C * THERMAL CONDUCTIVITIES OF SOIL LAYERS.
C
DO 500 J=1,IG
DO 500 I=IL1,IL2
c IF (ISAND(I,1).EQ.-4) THEN
c TCTOP(I,J)=TCGLAC
c TCBOT(I,J)=TCGLAC
c ELSEIF(ISAND(I,J).EQ.-3) THEN
c TCTOP(I,J)=TCSAND
c TCBOT(I,J)=TCSAND
c ELSEIF(ISAND(I,J).EQ.-2) THEN
c IF (WTABLE(I).GT.999. .AND. THLIQG(I,J).GT.
c 1 THLRET(I,J)) THEN
c WTABLE(I)=ZBOTW(I,J)-
c 1 DELZW(I,J)*(THLIQG(I,J)-THLRET(I,J))/
c 2 (THPOR(I,J)-THICEG(I,J)*RHOICE/RHOW-
c 3 THLRET(I,J))
c THTOT=THLRET(I,J)+THICEG(I,J)*RHOICE/RHOW
c SATRAT=MIN((THLRET(I,J)+THICEG(I,J)*RHOICE/RHOW)/
c 1 THPOR(I,J), 1.0)
c RATICE=(THICEG(I,J)*RHOICE/RHOW)/
c 1 (THLRET(I,J)+THICEG(I,J)*RHOICE/RHOW)
c RATLIQ=MIN(1.0-RATICE,1.0)
c RATLIQ=MAX(0.0,RATLIQ)
c TCTHAW=0.55*THTOT*THTOT+0.05
c TCFROZ=0.0603*EXP(3.73*SATRAT)
c TCSOIL=RATLIQ*TCTHAW+RATICE*TCFROZ
c IF(DELZW(I,J).GT.0.0) THEN
c TCTOP(I,J)=TCSOIL
c ELSE
c TCTOP(I,J)=TCSAND
c ENDIF
c IF(DELZW(I,J).LT.DELZ(J)) THEN
c TCBOT(I,J)=TCSAND
c ELSE
c RATICE=(THICEG(I,J)*RHOICE/RHOW)/THPOR(I,J)
c RATLIQ=MIN(1.0-RATICE,1.0)
c RATLIQ=MAX(0.0,RATLIQ)
c TCTHAW=0.55*THPOR(I,J)*THPOR(I,J)+0.05
c TCFROZ=1.80
c TCBOT(I,J)=RATLIQ*TCTHAW+RATICE*TCFROZ
c ENDIF
c IF(J.EQ.1.AND.ZPOND(I).GT.1.0E-3) TCTOP(I,J)=TCW
c ELSE
c THTOT=THLIQG(I,J)+THICEG(I,J)*RHOICE/RHOW
c SATRAT=MIN((THLIQG(I,J)+THICEG(I,J)*RHOICE/RHOW)/
c 1 THPOR(I,J), 1.0)
c RATICE=(THICEG(I,J)*RHOICE/RHOW)/
c 1 (THLIQG(I,J)+THICEG(I,J)*RHOICE/RHOW)
c RATLIQ=MIN(1.0-RATICE,1.0)
c RATLIQ=MAX(0.0,RATLIQ)
c TCTHAW=0.55*THTOT*THTOT+0.05
c TCFROZ=0.0603*EXP(3.73*SATRAT)
c TCSOIL=RATLIQ*TCTHAW+RATICE*TCFROZ
c IF(DELZW(I,J).GT.0.0) THEN
c TCTOP(I,J)=TCSOIL
c ELSE
c TCTOP(I,J)=TCSAND
c ENDIF
c IF(DELZW(I,J).LT.DELZ(J)) THEN
c TCBOT(I,J)=TCSAND
c ELSE
c TCBOT(I,J)=TCSOIL
c ENDIF
c IF(J.EQ.1.AND.ZPOND(I).GT.1.0E-3) TCTOP(I,J)=TCW
c ENDIF
c ELSE
SATRAT=MIN((THLIQG(I,J)+THICEG(I,J)*RHOICE/RHOW)/
1 THPOR(I,J), 1.0)
THLSAT=THPOR(I,J)*THLIQG(I,J)/(THLIQG(I,J)+
1 THICEG(I,J)*RHOICE/RHOW)
THISAT=THPOR(I,J)*THICEG(I,J)*RHOICE/RHOW/
1 (THLIQG(I,J)+THICEG(I,J)*RHOICE/RHOW)
p1=TCW**THLSAT
p2=TCICE**THISAT
p3=TCS(I,J)**(1.0-THPOR(I,J))
TCSAT(I)=p1*p2*p3
c TCSAT(I)=(TCW**THLSAT)*(TCICE**THISAT)*
c 1 (TCS(I,J)**(1.0-THPOR(I,J)))
TCSOIL=(TCSAT(I)-TCDRYS)*SATRAT+TCDRYS
IF(DELZW(I,J).GT.0.0) THEN
TCTOP(I,J)=TCSOIL
ELSE
TCTOP(I,J)=TCSAND
ENDIF
IF(DELZW(I,J).LT.DELZ(J)) THEN
TCBOT(I,J)=TCSAND
ELSE
TCBOT(I,J)=TCSOIL
ENDIF
IF(J.EQ.1.AND.ZPOND(I).GT.1.0E-3) TCTOP(I,J)=TCW
c ENDIF
500 CONTINUE
C
C * ADD PONDED WATER TEMPERATURE TO FIRST SOIL LAYER FOR USE
C * IN GROUND HEAT FLUX CALCULATIONS.
C
DO 600 I=IL1,IL2
HCP1P (I) = 0.
IF(ISAND(I,1).GT.-4 .AND. ZPOND(I).GT.0.
1 .AND. DELZW(I,1).GT.0.) THEN
HCP1P (I)=HCPW*(THLIQ(I,1)+ZPOND(I)/DELZW(I,1)) +
1 HCPICE*THICE(I,1) + HCPS(I,1)*(1.-THPOR(I,1))
c TBAR1P(I)=(TPOND(I)*HCPW*ZPOND(I) +
c 1 TBAR(I,1)*((HCPW*THLIQ(I,1) +
c 2 HCPICE*THICE(I,1) +
c 3 HCPS(I,1)*(1.-THPOR(I,1)))*DELZW(I,1)+
c 4 HCPSND*(DELZ(1)-DELZW(I,1))))/
c 5 (HCP1P(I)*DELZW(I,1)+HCPSND*(DELZ(1)-
c 6 DELZW(I,1)))
ELSE
HCP1P (I)=HCPG(I,1)
c TBAR1P(I)=TBAR(I,1)
ENDIF
600 CONTINUE
do I=IL1,IL2
if(HCP1P (I).gt.1.e-5) then
TBAR1P(I)=(TPOND(I)*HCPW*ZPOND(I) +
1 TBAR(I,1)*((HCPW*THLIQ(I,1) +
2 HCPICE*THICE(I,1) +
3 HCPS(I,1)*(1.-THPOR(I,1)))*DELZW(I,1)+
4 HCPSND*(DELZ(1)-DELZW(I,1))))/
5 (HCP1P(I)*DELZW(I,1)+HCPSND*(DELZ(1)-
6 DELZW(I,1)))
else
TBAR1P(I)=TBAR(I,1)
ENDIF
enddo
C
RETURN
END