SUBROUTINE CANALB(ALVSCN,ALIRCN,ALVSCS,ALIRCS,TRVSCN,TRIRCN, 1,5
1 TRVSCS,TRIRCS,RC,RCS,
2 ALVSC,ALIRC,RSMIN,QA50,VPDA,VPDB,PSIGA,PSIGB,
3 FC,FCS,FSNOW,FSNOWC,FCAN,FCANS,AIL,AILS,PSIGND,
4 FROOT,FCLOUD,COSZS,QSWINV,VPD,TA,ACVDAT,ACIDAT,
5 ILG,IL1,IL2,JL,IC,ICP1,IG,IALC,
6 CXTEFF,RCACC,RCG,RCV,RCT,GC)
C
C * NOV 2003 - Y.DELAGE. REARRANGE COMPUTATIONS FOR EFFICIENCY ON THE IBM
C * AND TO SATISFY THE LINUX COMPILER
C * JAN 24/02 - P.BARTLETT. TEST VERSION - EFFICIENCY IMPROVEMENTS
C * IN ALBEDO AND TRANSMISSIVITY CALCULATIONS.
C * JUL 30/02 - P.BARTLETT/D.VERSEGHY. NEW STOMATAL RESISTANCE
C * FORMULATION INCORPORATED.
C * MAR 18/02 - D.VERSEGHY. ALLOW FOR ASSIGNMENT OF SPECIFIED TIME-
C * VARYING VALUES OF VEGETATION SNOW-FREE
C * ALBEDO.
C * NOV 29/94 - M.LAZARE. CLASS - VERSION 2.3.
C * CALL ABORT CHANGED TO CALL XIT TO ENABLE
C * RUNNING ON PC'S.
C * MAY 06/93 - D.VERSEGHY. EXTENSIVE MODIFICATIONS TO CANOPY
C * ALBEDO LOOPS.
C * MAR 03/92 - D.VERSEGHY/M.LAZARE. REVISED AND VECTORIZED CODE
C * FOR MODEL VERSION GCM7.
C * AUG 12/91 - D.VERSEGHY. CANOPY ALBEDOS AND TRANSMISSIVITIES.
C
IMPLICIT NONE
INTEGER ILG,IL1,IL2,JL,IC,ICP1,IG,IALC,I,J,jptbad,jptbdi,iptbad
REAL fact,alvsn,alirn,alavg,alclr,altot,alvss
REAL alirs,trclrs,trclrt,trvs,trtot,trir
C
C * OUTPUT ARRAYS.
C
REAL ALVSCN(ILG), ALIRCN(ILG), ALVSCS(ILG), ALIRCS(ILG),
1 TRVSCN(ILG), TRIRCN(ILG), TRVSCS(ILG), TRIRCS(ILG),
2 RC (ILG), RCS (ILG)
C
C * 2-D INPUT ARRAYS.
C
REAL ALVSC (ILG,ICP1), ALIRC (ILG,ICP1),
1 RSMIN (ILG,IC), QA50 (ILG,IC),
2 VPDA (ILG,IC), VPDB (ILG,IC),
3 PSIGA (ILG,IC), PSIGB (ILG,IC),
4 FCAN (ILG,IC), FCANS (ILG,IC),
5 AIL (ILG,IC), AILS (ILG,IC),
6 ACVDAT(ILG,IC), ACIDAT(ILG,IC),
7 FROOT (ILG,IG)
C
C * 1-D INPUT ARRAYS.
C
REAL FC (ILG), FCS (ILG), FSNOW (ILG), FSNOWC(ILG),
1 PSIGND(ILG), FCLOUD(ILG), COSZS (ILG), QSWINV(ILG),
2 VPD (ILG), TA (ILG)
C
C * WORK ARRAYS.
C
REAL CXTEFF(ILG,IC), RCACC (ILG,IC),
1 RCV (ILG,IC), RCG (ILG,IC),
2 RCT (ILG), GC (ILG)
C
c automatic arrays
real fexp(ilg),ALVSCX(ilg),ALIRCX(ilg),secz(ilg)
real rs(ilg),rt(ilg),ds1(ilg),ds2(ilg),ds3(ilg)
real dt1(ilg),dt2(ilg),dt3(ilg),TRCLDS(ILG),TRCLDT(ILG)
c
#include "class_com.cdk"
REAL ALVSWG,ALIRWG,ALVSWS,ALIRWS,ALVSWC,ALIRWC
DATA ALVSWG,ALIRWG,ALVSWS,ALIRWS,ALVSWC
1 / 0.03, 0.23, 0.61, 0.38, 0.17/
C----------------------------------------------------------------------
C
C * INITIALIZE WORK ARRAYS.
C
DO 50 I=IL1,IL2
RCT(I)=0.0
GC(I)=0.0
RC(I)=0.0
50 CONTINUE
DO 60 J=1,IC
DO 60 I=IL1,IL2
CXTEFF(I,J)=0.0
RCACC(I,J)=0.0
RCG(I,J)=0.0
RCV(I,J)=0.0
60 CONTINUE
C
C * ALBEDO CALCULATIONS FOR CANOPY OVER BARE SOIL.
C
C * NEEDLELEAF AND BROADLEAF TREES.
C
do 110 j=1,2
do i=il1,il2
fexp(i)=CANEXT(J)*AIL(I,J)
ALIRWC=ALIRC(I,J)+0.04
IF(IALC.EQ.0) THEN
ALVSCX(I)=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ALVSC(I,J)
ALIRCX(I)=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ALIRC(I,J)
ELSE
ALVSCX(I)=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ACVDAT(I,J)
ALIRCX(I)=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ACIDAT(I,J)
ENDIF
enddo
call vsexp(fexp(il1),fexp(il1),il2-il1+1)
DO 100 I=IL1,IL2
IF(FCAN(I,J).GT.0..AND. COSZS(I).GT.0.) THEN
IF(IALC.EQ.0) THEN
ALVSN=(1.0-fexp(I))*ALVSCX(I)+fexp(I)*ALVSWG
ALIRN=(1.0-fexp(I))*ALIRCX(I)+fexp(I)*ALIRWG
ELSE
ALVSN=(1.0-fexp(i))*ALVSCX(i)+fexp(i)*ACVDAT(I,J)
ALIRN=(1.0-fexp(i))*ALIRCX(i)+fexp(i)*ACIDAT(I,J)
ENDIF
ALVSCN(I)=ALVSCN(I)+FCAN(I,J)*ALVSN
ALIRCN(I)=ALIRCN(I)+FCAN(I,J)*ALIRN
ENDIF
100 CONTINUE
110 continue
C
C * CROPS AND GRASS.
C
DO 125 J=3,IC
do i=il1,il2
fexp(i)=CANEXT(J)*AIL(I,J)
ALAVG=0.5*(ALVSC(I,J)+ALIRC(I,J))
IF(COSZS(I).LE.0.5) THEN
ALCLR=ALAVG/(0.5+COSZS(I))
ELSE
ALCLR=ALAVG*(0.5+1.0/(1.0+2.0*COSZS(I)))
ENDIF
ALTOT=FCLOUD(I)*ALAVG+(1.0-FCLOUD(I))*ALCLR
ALVSN=ALVSC(I,J)
ALIRN=2.0*ALTOT-ALVSN
ALIRWC=ALIRC(I,J)+0.04
IF(IALC.EQ.0) THEN
ALVSCX(I)=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ALVSN
ALIRCX(I)=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ALIRN
ELSE
ALVSCX(I)=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ACVDAT(I,J)
ALIRCX(I)=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ACIDAT(I,J)
ENDIF
enddo
call vsexp(fexp(il1),fexp(il1),il2-il1+1)
C
do 120 i=il1,il2
IF(FCAN(I,J).GT.0. .AND. COSZS(I).GT.0.) THEN
IF(IALC.EQ.0) THEN
ALVSN=(1.0-fexp(I))*ALVSCX(I)+fexp(I)*ALVSWG
ALIRN=(1.0-fexp(I))*ALIRCX(I)+fexp(I)*ALIRWG
ELSE
ALVSN=(1.0-fexp(i))*ALVSCX(i)+fexp(i)*ACVDAT(I,J)
ALIRN=(1.0-fexp(i))*ALIRCX(i)+fexp(i)*ACIDAT(I,J)
END IF
ALVSCN(I)=ALVSCN(I)+FCAN(I,J)*ALVSN
ALIRCN(I)=ALIRCN(I)+FCAN(I,J)*ALIRN
ENDIF
120 CONTINUE
125 CONTINUE
C
C * TOTAL ALBEDOS.
C
IPTBAD=0
DO 190 I=IL1,IL2
IF(FC(I).GT.0. .AND. COSZS(I).GT.0.) THEN
ALVSCN(I)=ALVSCN(I)/FC(I)
ALIRCN(I)=ALIRCN(I)/FC(I)
ENDIF
IF(ALVSCN(I).GT.1. .OR. ALVSCN(I).LT.0.) IPTBAD=I
IF(ALIRCN(I).GT.1. .OR. ALIRCN(I).LT.0.) IPTBAD=I
190 CONTINUE
C
IF(IPTBAD.NE.0) THEN
WRITE(6,6100) IPTBAD,JL,ALVSCN(IPTBAD),ALIRCN(IPTBAD)
6100 FORMAT('0AT (I,J)= (',I3,',',I3,'), ALVSCN,ALIRCN = ',2F10.5)
CALL XIT('CANALB',-1)
ENDIF
C----------------------------------------------------------------------
C * ALBEDO CALCULATIONS FOR CANOPY OVER SNOW.
C
DO 200 J=1,IC
do i=il1,il2
fexp(i)=CANEXT(J)*AILS(I,J)
ALIRWC=ALIRC(I,J)+0.04
IF(IALC.EQ.0) THEN
ALVSCX(I)=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ALVSC(I,J)
ALIRCX(I)=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ALIRC(I,J)
ELSE
ALVSCX(I)=FSNOWC(I)*ALVSWC+(1.0-FSNOWC(I))*ACVDAT(I,J)
ALIRCX(I)=FSNOWC(I)*ALIRWC+(1.0-FSNOWC(I))*ACIDAT(I,J)
ENDIF
enddo
call vsexp(fexp(il1),fexp(il1),il2-il1+1)
DO 180 I=IL1,IL2
IF(FCANS(I,J).GT.0. .AND. COSZS(I).GT.0.) THEN
ALVSS=(1.0-fexp(i))*ALVSCX(I)+fexp(i)*ALVSWS
ALIRS=(1.0-fexp(i))*ALIRCX(I)+fexp(i)*ALIRWS
ALVSCS(I)=ALVSCS(I)+FCANS(I,J)*ALVSS
ALIRCS(I)=ALIRCS(I)+FCANS(I,J)*ALIRS
ENDIF
180 CONTINUE
200 CONTINUE
C
C * TOTAL ALBEDOS.
C
IPTBAD=0
DO 290 I=IL1,IL2
IF(FCS(I).GT.0. .AND. COSZS(I).GT.0.) THEN
ALVSCS(I)=ALVSCS(I)/FCS(I)
ALIRCS(I)=ALIRCS(I)/FCS(I)
ENDIF
IF(ALVSCS(I).GT.1. .OR. ALVSCS(I).LT.0.) IPTBAD=I
IF(ALIRCS(I).GT.1. .OR. ALIRCS(I).LT.0.) IPTBAD=I
290 CONTINUE
C
IF(IPTBAD.NE.0) THEN
WRITE(6,6200) IPTBAD,JL,ALVSCS(IPTBAD),ALIRCS(IPTBAD)
6200 FORMAT('0AT (I,J)= (',I3,',',I3,'), ALVSCS,ALIRCS = ',2F10.5)
CALL XIT('CANALB',-2)
ENDIF
c
C-----------------------------------------------------------------------
C * TRANSMISSIVITY CALCULATIONS FOR CANOPY OVER BARE SOIL.
C
do I=IL1,IL2
secz(i)=1/max(coszs(i),0.1)
enddo
c
do 300 J=1,IC
do I=IL1,IL2
C
C * NEEDLELEAF TREES.
C
if(j.eq.1) then
rs(i)= -0.4*AIL(I,J)*secz(i)
rt(i)= -0.3*AIL(I,J)*secz(i)
ds1(i)= -0.41412*AIL(I,J)
ds2(i)= -0.56569*AIL(I,J)
ds3(i)= -1.54559*AIL(I,J)
dt1(i)= -0.31059*AIL(I,J)
dt2(i)= -0.42427*AIL(I,J)
dt3(i)= -1.15920*AIL(I,J)
C
C * BROADLEAF TREES.
C
else if(j.eq.2) then
rs(i)=min(-0.7*AIL(I,J),-0.4*secz(i))
rt(i)=min(-0.4*AIL(I,J),-0.4*secz(i))
ds1(i)=min(-0.7*AIL(I,J),-0.41412)
ds2(i)=min(-0.7*AIL(I,J),-0.56569)
ds3(i)=min(-0.7*AIL(I,J),-1.54559)
dt1(i)=min(-0.4*AIL(I,J),-0.41412)
dt2(i)=min(-0.4*AIL(I,J),-0.56569)
dt3(i)=min(-0.4*AIL(I,J),-1.54559)
C
C * CROPS AND GRASS.
C
else
rs(i)= -0.5*AIL(I,J)*secz(i)
rt(i)= -0.4*AIL(I,J)*secz(i)
ds1(i)= -0.51765*AIL(I,J)
ds2(i)= -0.70711*AIL(I,J)
ds3(i)= -1.93199*AIL(I,J)
dt1(i)= -0.41412*AIL(I,J)
dt2(i)= -0.56569*AIL(I,J)
dt3(i)= -1.54559*AIL(I,J)
endif
enddo
call vsexp(rs(il1),rs(il1),il2-il1+1)
call vsexp(rt(il1),rt(il1),il2-il1+1)
call vsexp(ds1(il1),ds1(il1),il2-il1+1)
call vsexp(ds2(il1),ds2(il1),il2-il1+1)
call vsexp(ds3(il1),ds3(il1),il2-il1+1)
call vsexp(dt1(il1),dt1(il1),il2-il1+1)
call vsexp(dt2(il1),dt2(il1),il2-il1+1)
call vsexp(dt3(il1),dt3(il1),il2-il1+1)
do I=IL1,IL2
TRCLDS(i)=0.3*ds1(i)+0.5*ds2(i)+0.2*ds3(i)
TRCLDT(i)=0.3*dt1(i)+0.5*dt2(i)+0.2*dt3(i)
enddo
c
do I=IL1,IL2
IF(FCAN(I,J).GT.0. .AND. COSZS(I).GT.0.) THEN
TRVS =FCLOUD(I)*TRCLDS(i)+(1.0-FCLOUD(I))*rs(i)
TRTOT =FCLOUD(I)*TRCLDT(i)+(1.0-FCLOUD(I))*rt(i)
TRIR = 2.*TRTOT-TRVS
TRVSCN(I)=TRVSCN(I)+FCAN(I,J)*TRVS
TRIRCN(I)=TRIRCN(I)+FCAN(I,J)*TRIR
CXTEFF(I,J)=-LOG(TRVS)/max(0.001,AIL(I,J))
ENDIF
enddo
c call vslog(CXTEFF(IL1,J),CXTEFF(IL1,J),IL2-IL1+1)
c do I=IL1,IL2
c IF(FCANS(I,J).GT.0. .AND. COSZS(I).GT.0.
c 1 .AND. AIL(I,J).GT..001) THEN
c CXTEFF(I,J)=-CXTEFF(I,J)/AIL(I,J)
c ENDIF
c enddo
300 continue
C
C * TOTAL TRANSMISSIVITIES.
C
IPTBAD=0
DO 350 I=IL1,IL2
IF(FC(I).GT.0. .AND. COSZS(I).GT.0.) THEN
TRVSCN(I)=TRVSCN(I)/FC(I)
TRIRCN(I)=TRIRCN(I)/FC(I)
TRVSCN(I)=MIN( TRVSCN(I), 0.90*(1.0-ALVSCN(I)) )
TRIRCN(I)=MIN( TRIRCN(I), 0.90*(1.0-ALIRCN(I)) )
ENDIF
IF(TRVSCN(I).GT.1. .OR. TRVSCN(I).LT.0.) IPTBAD=I
IF(TRIRCN(I).GT.1. .OR. TRIRCN(I).LT.0.) IPTBAD=I
350 CONTINUE
C
IF(IPTBAD.NE.0) THEN
WRITE(6,6300) IPTBAD,JL,TRVSCN(IPTBAD),TRIRCN(IPTBAD)
6300 FORMAT('0AT (I,J)= (',I3,',',I3,'), TRVSCN,TRIRCN = ',2F10.5)
CALL XIT('CANALB',-3)
ENDIF
C
C-----------------------------------------------------------------------
C * TRANSMISSIVITY CALCULATIONS FOR CANOPY OVER SNOW.
do 400 J=1,IC
do I=IL1,IL2
C
C * NEEDLELEAF TREES.
C
if(j.eq.1) then
rs(i)= -0.4*AILS(I,J)*secz(i)
rt(i)= -0.3*AILS(I,J)*secz(i)
ds1(i)= -0.41412*AILS(I,J)
ds2(i)= -0.56569*AILS(I,J)
ds3(i)= -1.54559*AILS(I,J)
dt1(i)= -0.31059*AILS(I,J)
dt2(i)= -0.42427*AILS(I,J)
dt3(i)= -1.15920*AILS(I,J)
C
C * BROADLEAF TREES.
C
else if(j.eq.2) then
rs(i)=min(-0.7*AILS(I,J),-0.4*secz(i))
rt(i)=min(-0.4*AILS(I,J),-0.4*secz(i))
ds1(i)=min(-0.7*AILS(I,J),-0.41412)
ds2(i)=min(-0.7*AILS(I,J),-0.56569)
ds3(i)=min(-0.7*AILS(I,J),-1.54559)
dt1(i)=min(-0.4*AILS(I,J),-0.41412)
dt2(i)=min(-0.4*AILS(I,J),-0.56569)
dt3(i)=min(-0.4*AILS(I,J),-1.54559)
C
C * CROPS AND GRASS.
C
else
rs(i)= -0.5*AILS(I,J)*secz(i)
rt(i)= -0.4*AILS(I,J)*secz(i)
ds1(i)= -0.51765*AILS(I,J)
ds2(i)= -0.70711*AILS(I,J)
ds3(i)= -1.93199*AILS(I,J)
dt1(i)= -0.41412*AILS(I,J)
dt2(i)= -0.56569*AILS(I,J)
dt3(i)= -1.54559*AILS(I,J)
endif
enddo
call vsexp(rs(il1),rs(il1),il2-il1+1)
call vsexp(rt(il1),rt(il1),il2-il1+1)
call vsexp(ds1(il1),ds1(il1),il2-il1+1)
call vsexp(ds2(il1),ds2(il1),il2-il1+1)
call vsexp(ds3(il1),ds3(il1),il2-il1+1)
call vsexp(dt1(il1),dt1(il1),il2-il1+1)
call vsexp(dt2(il1),dt2(il1),il2-il1+1)
call vsexp(dt3(il1),dt3(il1),il2-il1+1)
do I=IL1,IL2
TRCLDS(i)=0.3*ds1(i)+0.5*ds2(i)+0.2*ds3(i)
TRCLDT(i)=0.3*dt1(i)+0.5*dt2(i)+0.2*dt3(i)
enddo
c
do I=IL1,IL2
IF(FCANS(I,J).GT.0. .AND. COSZS(I).GT.0.) THEN
TRVS =FCLOUD(I)*TRCLDS(i)+(1.0-FCLOUD(I))*rs(i)
TRTOT =FCLOUD(I)*TRCLDT(i)+(1.0-FCLOUD(I))*rt(i)
TRIR = 2.*TRTOT-TRVS
TRVSCS(I)=TRVSCS(I)+FCANS(I,J)*TRVS
TRIRCS(I)=TRIRCS(I)+FCANS(I,J)*TRIR
ENDIF
enddo
400 continue
C
C * TOTAL TRANSMISSIVITIES AND CONSISTENCY CHECKS.
C
IPTBAD=0
JPTBAD=0
DO 450 I=IL1,IL2
IF(FCS(I).GT.0. .AND. COSZS(I).GT.0.) THEN
TRVSCS(I)=TRVSCS(I)/FCS(I)
TRIRCS(I)=TRIRCS(I)/FCS(I)
TRVSCS(I)=MIN( TRVSCS(I), 0.90*(1.0-ALVSCS(I)) )
TRIRCS(I)=MIN( TRIRCS(I), 0.90*(1.0-ALIRCS(I)) )
ENDIF
IF(TRVSCS(I).GT.1. .OR. TRVSCS(I).LT.0.) IPTBAD=I
IF(TRIRCS(I).GT.1. .OR. TRIRCS(I).LT.0.) IPTBAD=I
IF((1.-ALVSCN(I)-TRVSCN(I)).LT.0.) THEN
JPTBAD=1000+I
JPTBDI=I
ENDIF
IF((1.-ALVSCS(I)-TRVSCS(I)).LT.0.) THEN
JPTBAD=2000+I
JPTBDI=I
ENDIF
IF((1.-ALIRCN(I)-TRIRCN(I)).LT.0.) THEN
JPTBAD=3000+I
JPTBDI=I
ENDIF
IF((1.-ALIRCS(I)-TRIRCS(I)).LT.0.) THEN
JPTBAD=4000+I
JPTBDI=I
ENDIF
450 CONTINUE
C
IF(IPTBAD.NE.0) THEN
WRITE(6,6400) IPTBAD,JL,TRVSCS(IPTBAD),TRIRCS(IPTBAD)
6400 FORMAT('0AT (I,J)= (',I3,',',I3,'), TRVSCS,TRIRCS = ',2F10.5)
CALL XIT('CANALB',-4)
ENDIF
C
IF(JPTBAD.NE.0) THEN
WRITE(6,6500) JPTBDI,JL,JPTBAD
6500 FORMAT('0AT (I,J)= (',I3,',',I3,'), JPTBAD = ',I5)
CALL XIT('CANALB',-5)
ENDIF
C
C * BULK STOMATAL RESISTANCES FOR CANOPY OVERLYING SNOW AND CANOPY
C * OVERLYING BARE SOIL.
C
DO 500 I=IL1,IL2
IF((FCS(I)+FC(I)).GT.0.0) THEN
IF(TA(I).LE.268.15) THEN
RCT(I)=250.
ELSEIF(TA(I).LT.278.15) THEN
RCT(I)=1./(1.-(278.15-TA(I))*.1)
ELSEIF(TA(I).GT.313.15) THEN
IF(TA(I).GE.323.15) THEN
RCT(I)=250.
ELSE
RCT(I)=1./(1.-(TA(I)-313.15)*0.1)
ENDIF
ELSE
RCT(I)=1.
ENDIF
ENDIF
500 CONTINUE
C
DO 550 J=1,IC
DO 550 I=IL1,IL2
IF(FCAN(I,J).GT.0.) THEN
IF(VPD(I).LE.0.) THEN
RCV(I,J)=1.0
ELSE
IF(VPDA(I,J).GT.0.0.AND.VPDB(I,J).EQ.0.0) THEN
RCV(I,J)=1./EXP(-VPDA(I,J)*VPD(I)/10.)
ELSEIF(VPDA(I,J).GT.0.) THEN
RCV(I,J)=MAX(1.,((VPD(I)/10.)**VPDB(I,J))/
1 VPDA(I,J))
ENDIF
ENDIF
IF(PSIGA(I,J).GT.10.)
1 RCG(I,J)=1.+(PSIGND(I)/PSIGA(I,J))**PSIGB(I,J)
IF(QSWINV(I).GT.0..AND.COSZS(I).GT.0.
1 .AND.CXTEFF(I,J).GT.0.0001.AND.RCG(I,J).LT.1.E5) THEN
RCACC(I,J)=MIN(CXTEFF(I,J)*RSMIN(I,J)/MAX(1.E-4,
1 LOG((QSWINV(I)+
1 QA50(I,J)/CXTEFF(I,J))/(QSWINV(I)*EXP(-CXTEFF(I,J)*
2 AIL(I,J))+QA50(I,J)/CXTEFF(I,J))))*RCV(I,J)*RCG(I,J)*
3 RCT(I),5000.)
ELSE
RCACC(I,J)=5000.
ENDIF
RC(I)=RC(I)+FCAN(I,J)*RCACC(I,J)
GC(I)=GC(I)+FCAN(I,J)/MAX(RCACC(I,J),1.E-4)
ENDIF
550 CONTINUE
C
DO 600 I=IL1,IL2
IF((FCS(I)+FC(I)).GT.0.) THEN
IF(MAX(FROOT(I,1),FROOT(I,2),FROOT(I,3))
1 .LT. 1.0E-6) THEN
RCS(I)=1.0E+20
RC(I) =1.0E+20
ELSEIF(QSWINV(I).LT.2.0) THEN
RCS(I)=5000.0
RC(I)=5000.0
ELSEIF(RC(I).GT.0.) THEN
RCS(I)=5000.0
RC(I)= 2./((FCS(I)+FC(I))/RC(I)+
1 GC(I)/(FCS(I)+FC(I)))
ELSE
RCS(I)=5000.0
ENDIF
ELSE
RC(I)=0.0
RCS(I)=0.0
ENDIF
600 CONTINUE
return
end