      SUBROUTINE VGRFAC5 (ALSWROL,ALLWROL,EVAPF,QG,SNOFAC,RUNOFF,PVEG,
     1                    SVEG,PGND,SOIL,ALSW,ALLW,SAGE,GC,GT,GTA,SNO,
     2                    SIC,WF,WL,PS,QROW,SLP,SNOMASK,ILG,IS,IF,LEV)
C 
C     * APR 27/89 - M.LAZARE. MAJOR MODIFICATIONS TO SIC/SNO ALBEDOES.
C     * JAN 08/88 - M.LAZARE. BASED ON OLD VGRFAC WITH MAJOR REVISIONS. 
C     * OCT 11/84 - R.LAPRISE,T.CARRIERES 
C 
C     * EVALUATE GROUND FACTORS:  EVAPORATION EFFICIENCY, 
C     * SATURATION SPECIFIC HUMIDITY AT GROUND TEMPERATURE, AND 
C     * EFFECTIVE SNOW COVERAGE.
C     * CALCULATE VISIBLE AND NEAR-IR ALBEDOES, INCLUDING FEEDBACK
C     * EFFECTS OF SOIL MOISTURE AND SNOW COVER.
C     * INITIALIZE RUNOFF TO ZERO.
C 
      IMPLICIT REAL (A-H,O-Z),
     +INTEGER (I-N)

      REAL ALSWROL(ILG),ALLWROL(ILG),EVAPF(ILG),QG(ILG),SNOFAC(ILG) 
      REAL RUNOFF(ILG),PVEG(ILG),SVEG(ILG),SOIL(ILG),PGND(ILG)
      REAL GC(ILG),GT(ILG),GTA(ILG),SNO(ILG),SIC(ILG),WF(ILG),WL(ILG) 
      REAL SLP(ILG),SNOMASK(ILG)
      REAL ALSW(ILG),ALLW(ILG),SAGE(ILG),PS(ILG),QROW(ILG,LEV)
C 
      COMMON /PARAM3/CSNO,CPACK,GTFSW,RKHI,SBC,SNOMAX 
      COMMON /PARAM5/ CONI,DENI,SICMIN,DFSIC,CONF 
      COMMON /EPS/ A,B,EPS1,EPS2
C 
C     * ALBEDOES (VISIBLE AND NEAR-IR) OF FRESH SNOW, NON-MELTING SEA-
C     * ICE AND ICE-WATER TRANSITION, RESPECTIVELY. 
C 
      DATA ALBSWN,ALBLWN /0.90,0.70/
      DATA ALBSWI,ALBLWI /0.75,0.55/
      DATA ALBSWO,ALBLWO /0.50,0.30/
C 
C     * IN-LINE FUNCTIONS.
C 
      E(TD,A,B)=EXP(A-B/TD) 
      Q(EEE,P,EPS1,EPS2)=EPS1*EEE/(P-EPS2*EEE)
C-----------------------------------------------------------------------
      DO 500 I=IS,IF
C 
C     * INITIALIZE RUNOFF TO ZERO INITIALLY.
C 
      RUNOFF(I)=0.
C 
C     * SATURATION SPECIFIC HUMIDITY AT GROUND TEMPERATURE AND PRESSURE.
C 
      QG(I)=Q(E(GT(I),A,B), .01*PS(I), EPS1, EPS2)
C 
C     * FRACTIONAL SNOW COVERAGE. 
C     * FUN(SNO) OVER PACK ICE,  GC=1.
C     *       0. OVER OPEN SEA,  GC=0.
C     * FUN(SNO) OVER LAND,      GC=-1. 
C 
      SNOFAC(I)=MIN(1.,SQRT(SNO(I)/SNOMAX)) 
C 
C     * CALCULATE ACTUAL DEPTH OF SNOW. 
C     * FIRST CALCULATE THE EFFECTIVE SNOW DENSITY. 
C     * FORMULA BASED ON ABEL'S: RHO(Z)=RHO(0)*EXP(AZ) INTEGRATED OVER
C     * DEPTH OF SNOW WITH RHO(0)=275. (AVERAGE AGED-DENSITY AT SFC)
C     * AND A=0.54. 
C     * SET DENSITY TO FRESH SNOW VALUE IF NO SNOW, TO AVOID
C     * NUMERICAL PROBLEMS LATER ON.
C 
      IF(SNO(I).GT.SNOMAX) THEN 
         DENS=0.54*SNO(I)/LOG(1.+0.54*SNO(I)/275.) 
      ELSE
         DENS=100.
      ENDIF 
      DSNO=SNO(I)/DENS
C 
C     * GROUND EVAPORATION EFFICIENCY.
C     * =1. OVER OPEN WATER AND PACK ICE, GC=0.,1.
C     * =FUN(WL+WF,SLP,SNOFAC) OVER LAND, GC=-1.
C     * SET TO 1. WHEN AIR MOISTER THEN UNDERLYING GROUND.
C 
      EVAPF(I)=MERGE(MIN(1.,(WL(I)+WF(I))/SLP(I))*(1.-SNOFAC(I))
     1                                      +1.*SNOFAC(I),
     2               1.,
     3               GC(I).EQ.-1.)
      EVAPF(I)=MERGE(1.,  EVAPF(I),  QROW(I,LEV).GT.QG(I))
C 
C **********************************************************************
C     * ACTUAL SURFACE ALBEDOES (VISIBLE AND NEAR-IR), INCLUDING SNOW 
C     * AND SOIL MOISTURE FEEDBACKS.
C     * ORIGINAL INPUT VALUES            OVER OPEN SEA,  GC=0.
C     * FUNC(GTA,SNOFAC,SAGE)            OVER PACK ICE,  GC=1.
C     * FUNC(WL,SOIL,PGND,SNO,PVEG,SAGE) OVER LAND,      GC=-1. 
C **********************************************************************
C 
C     * ALBEDOES OVER SNOW VARY WITH SNOWAGE. 
C 
      ALSNOS=ALBSWN-0.15*SAGE(I)
      ALSNOL=ALBLWN-0.15*SAGE(I)
C 
      IF(GC(I).EQ.1.) THEN
C 
C       * PACK ICE ALBEDOES HAVE VALUES IN EACH SPECTRAL INTERVAL 
C       * WHICH ARE PRIMARILY CONSTANT (ALBSWI,ALBLWI). 
C       * THESE ARE IN EFFECT UNTIL "PUDDLING" OCCURS, WHICH
C       * IS INCLUDED TO REDUCE ALBEDO IN EACH SPECTRAL INTERVAL BY UP
C       * TO 10%, ONLY IF GTA LIES BETWEEN GTFSW AND GTMSI. THE EFFECT
C       * OF SNOW IS THEN SUPERIMPOSED, BASED ON THE ABOVE VALUE, THE 
C       * EFFECTIVE SNOW COVERAGE (SNOFAC) AND THE ABOVE-CALCULATED DEEP
C       * SNOW ALBEDOES.
C 
C       * FIRST-YEAR ICE/LEEDS ARE THEN SUPERIMPOSED. 
C 
        PUDDLE = MAX(0.0,(MIN((GTA(I)-GTFSW)/4.,0.5)))
        ALFA   = MIN((45./SIC(I))**1.25,1.) 
        ALICES = ALBSWI - 0.10*PUDDLE 
        ALICEL = ALBLWI - 0.10*PUDDLE 
        ASNOIS = ALICES*(1.-SNOFAC(I))+ALSNOS*SNOFAC(I) 
        ASNOIL = ALICEL*(1.-SNOFAC(I))+ALSNOL*SNOFAC(I) 
        ALSWROL(I)=ALFA*ALBSWO+(1.-ALFA)*ASNOIS 
        ALLWROL(I)=ALFA*ALBLWO+(1.-ALFA)*ASNOIL 
  
      ELSE IF(GC(I).EQ.-1.) THEN
C 
C       * ALBEDOES OVER LAND VARIES FROM DRY LIMIT (AT WL=0.) TO WET
C       * LIMIT (AT WL=1.) IN A LINEAR FASHION, IN EACH OF THE TWO
C       * SPECTRAL INTERVALS. EACH IS THEN COMBINED WITH THE CANOPY. THE
C       * EFFECT OF SNOW COVERAGE IS THEN SUPERIMPOSED, BASED ON THE
C       * ACTUAL DEPTH OF SNOW (DSNO), THE  SNOW MASKING DEPTH
C       * (SNOMASK), THE ALBEDOES OF SNOW AND THE ABOVE-CALCULATED SNOW-
C       * FREE ALBEDOES.
C 
C       * FIRST RETRIEVE SOIL COLOUR, TEXTURE AND DRAINAGE FROM SOIL
C       * CODE EACH HAVING A RESULTING INTEGER VALUE RANGING FROM 0 TO
C       * 9, REPRESENTING: (DARK TO LIGHT) COLOUR, (FINE TO COARSE) 
C       * TEXTURE, AND (FREE TO POOR) DRAINAGE, RESPECTIVELY. 
C 
        IF(DSNO.LT.SNOMASK(I)) THEN 
          IF(PVEG(I).NE.1.) THEN
            IC     = INT(SOIL(I))/100 
            ICLR   = IC/100 
            ITEX   = (IC-100*ICLR)/10 
            IDRN   = IC - 100*ICLR - 10*ITEX
            SOLOUR = FLOAT(ICLR)/9. 
            ALBSWU = 0.10 + 0.10*SOLOUR + 0.07*(1.0-WL(I))
            ALBLWU = 2.0*ALBSWU 
          ELSE
            ALBSWU = ALSW(I)
            ALBLWU = ALLW(I)
          ENDIF 
C 
C         * EFFECTIVE ALBEDOES OF GROUND COMBINED WITH CANOPY, INCLUDING
C         * SNOW COVERAGE.
C 
          ALSWROL(I)=PGND(I)*ALBSWU + (1.-PGND(I))*ALSW(I)
          ALLWROL(I)=PGND(I)*ALBLWU + (1.-PGND(I))*ALLW(I)
          ALSWROL(I)=ALSWROL(I)+(DSNO/SNOMASK(I))*(ALSNOS-ALSWROL(I)) 
          ALLWROL(I)=ALLWROL(I)+(DSNO/SNOMASK(I))*(ALSNOL-ALLWROL(I)) 
        ELSE
          ALSWROL(I)=ALSNOS 
          ALLWROL(I)=ALSNOL 
        ENDIF 
      ELSE
C 
C       * OVER OPEN WATER, THE ALBEDOES MAINTAIN THEIR ORIGINAL VALUES. 
C 
        ALSWROL(I)=ALSW(I)
        ALLWROL(I)=ALLW(I)
      ENDIF 
C 
  500 CONTINUE
      RETURN
      END 
