SUBROUTINE SNOALBW(ALBSNO,RHOSNO,ZSNOW,HCPSNO,TSNOW, 2
     1                   FI,S,RMELT,RHOMAX,ISAND,
     2                   ILG,IG,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     * OCT 20/00 - R.BROWN/D.VERSEGHY. MODIFIED SNOW DENSITY
C     *                                 CALCULATIONS, ACCOUNTING
C     *                                 FOR SETTLING IN WARM AND
C     *                                 COLD SNOW.
C     * JUN 05/97 - D.VERSEGHY. CLASS - VERSION 2.7.
C     *                         SPECIFY LOCATION OF ICE SHEETS
C     *                         BY SOIL TEXTURE ARRAY RATHER
C     *                         THAN BY SOIL COLOUR INDEX.
C     * JAN 02/96 - D.VERSEGHY. CLASS - VERSION 2.5.
C     *                         COMPLETION OF ENERGY BALANCE
C     *                         DIAGNOSTICS.
C     * MAR 13/92 - M.LAZARE.   CLASS - VERSION 2.1.
C     *                         CODE FOR MODEL VERSION GCM7 -
C     *                         DIVIDE PREVIOUS SUBROUTINE 
C     *                         "SNOALB" INTO "SNOALBA" AND
C     *                         "SNOALBW" AND VECTORIZE.
C     * AUG 12/91 - D.VERSEGHY. CODE FOR MODEL VERSION GCM7U -
C     *                         CLASS VERSION 2.0 (WITH CANOPY).
C     * APR 11/89 - D.VERSEGHY. CALCULATE DECREASE IN SNOW ALBEDO
C     *                         AND INCREASE IN DENSITY DUE TO
C     *                         AGING. (ASSIGN DIFFERENT LOWER
C     *                         SNOW ALBEDO LIMITS FOR DRY AND
C     *                         MELTING SNOW.)
C                                                                                 
      IMPLICIT NONE
      INTEGER ILG,IG,IL1,IL2,JL,IPTBAD,I
      REAL TIMFAC,RHOOLD
C
C     * OUTPUT ARRAYS.                                                            
C                                                                                 
      REAL ALBSNO(ILG),   RHOSNO(ILG),   ZSNOW (ILG),   HCPSNO(ILG)
C                                                                                 
C     * INPUT ARRAYS.                                                             
C                                                                                 
      REAL TSNOW (ILG),   FI    (ILG),   S     (ILG),   RMELT (ILG)              
C 
      INTEGER             ISAND (ILG,IG)
C                                                                                 
C     * WORK ARRAY.                                                             
C                                                                                 
      REAL RHOMAX(ILG)
C                                                                
#include "class_com.cdk"
C----------------------------------------------------------------------               
      IPTBAD=0                                                                    
      DO 100 I=IL1,IL2  
       IF(FI(I).GT.0.)                                           THEN
          IF(ZSNOW(I).GT.0. .AND. ISAND(I,1).NE.-4 .AND.
     1             S(I).LT.1.4E-6)            THEN
              IF(ALBSNO(I).GT.0.501.AND.(RMELT(I).GT.0.0 .OR.
     1                TSNOW(I).GE.TFREZ)) THEN
                  TIMFAC=EXP(LOG((ALBSNO(I)-0.50)/0.34)-                    
     1                       2.778E-6*DELT)                                      
                  ALBSNO(I)=0.34*TIMFAC+0.50                                 
              ELSE IF(ALBSNO(I).GT.0.701 .AND. RMELT(I).LE.0.0) THEN
                  TIMFAC=EXP(LOG((ALBSNO(I)-0.70)/0.14)-                    
     1                       2.778E-6*DELT)                                      
                  ALBSNO(I)=0.14*TIMFAC+0.70                                 
              ENDIF                                                           
          ENDIF
C                                                       
          IF(ZSNOW(I).GT.0.001)                THEN
              IF(TSNOW(I).LT.TFREZ)                      THEN
                  RHOMAX(I)=450.0-(204.7/ZSNOW(I))*
     1                (1.0-EXP(-ZSNOW(I)/0.673))
              ELSE
                  RHOMAX(I)=700.0-(204.7/ZSNOW(I))*
     1                (1.0-EXP(-ZSNOW(I)/0.673))
              ENDIF
          ENDIF
C
          IF(ZSNOW(I).GT.0. .AND.(RHOSNO(I)+0.1).LT.RHOMAX(I))    THEN 
              RHOOLD=RHOSNO(I)                                                       
              TIMFAC=EXP(LOG((RHOMAX(I)-RHOSNO(I))/200.0)-
     1            2.778E-6*DELT)                
              RHOSNO(I)=RHOMAX(I)-200.0*TIMFAC  
              ZSNOW(I)=ZSNOW(I)*RHOOLD/RHOSNO(I) 
              HCPSNO(I)=HCPICE*RHOSNO(I)/RHOICE
          ENDIF
          IF((ALBSNO(I).LT.0.41 .OR. ALBSNO(I).GT.1.0) .AND. 
     1       ZSNOW (I).GT.0.)               IPTBAD=I
        ENDIF
  100 CONTINUE                                                                    
C
      IF(IPTBAD.NE.0) THEN                                                        
         WRITE(6,6100) IPTBAD,JL,ALBSNO(IPTBAD)
 6100    FORMAT('0AT (I,J)= (',I3,',',I3,'), ALBSNO = ',F10.5)            
c        CALL XIT('SNOALBW',-1)                                                               
      ENDIF                                                                       
C                                                                                 
      RETURN                                                                      
      END