C     path:      $Source: /storm/rc1/cvsroot/rc/rrtm_lw/src/rtregcldmr.f,v $
C     author:    $Author: jdelamer $
C     revision:  $Revision: 3.2 $
C     created:   $Date: 2002/08/15 18:33:27 $
      SUBROUTINE RTREGCLDMR

C *** This program calculates the upward fluxes, downward fluxes, and
C     heating rates for an arbitrary cloudy atmosphere.  The input
C     to this program is the atmospheric profile, including cloud
C     properties,  and all needed Planck function information.  First  
C     order standard Gaussian quadrature is used for the angle 
C     integration.

C     Clouds are treated with maximum/random overlap scheme.

      PARAMETER (MG=16)
      PARAMETER (MXLAY=203)
      PARAMETER (MXANG = 4)
      PARAMETER (NBANDS = 16)
      PARAMETER (NTBL = 10000,TBLINT = 10000.0)

      IMPLICIT DOUBLE PRECISION (V)                                     

      COMMON /CONSTANTS/ FLUXFAC,HEATFAC
      COMMON /CONSTS/ PI,PLANCK,BOLTZ,CLIGHT,AVOGAD,ALOSMT,GASCON,
     *                RADCN1,RADCN2 
      COMMON /FEATURES/  NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS)
      COMMON /BANDS/     WAVENUM1(NBANDS),WAVENUM2(NBANDS),
     &                   DELWAVE(NBANDS)
      COMMON /CONTROL/   NUMANGS, IOUT, ISTART, IEND
      COMMON /PROFI/   NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY),
     &                   PZ(0:MXLAY),TZ(0:MXLAY)
      COMMON /SURFACE/   TBOUND,IREFLECT,SEMISS(NBANDS)
      COMMON /CLOUDDAT/  NCBANDS,CLDFRAC(MXLAY),TAUCLOUD(MXLAY,NBANDS)
      COMMON /PLNKDAT/   PLANKLAY(MXLAY,NBANDS),
     &                   PLANKLEV(0:MXLAY,NBANDS),PLANKBND(NBANDS)
      COMMON /PLANKG/    FRACS(MXLAY,MG)                                       
      COMMON /TAUGCOM/   TAUG(MXLAY,MG)
      COMMON /OUTPUT/    TOTUFLUX(0:MXLAY), TOTDFLUX(0:MXLAY),
     &                   FNET(0:MXLAY), HTR(0:MXLAY)
      COMMON /RTTBL/     BPADE,
     &                   TAUTBL(0:NTBL),TRANS(0:NTBL),TF(0:NTBL)

      COMMON /CVRRGX/    HVRRGX

      CHARACTER*15       HVRRGX

      DIMENSION ATRANS(MXLAY,MXANG),BBUGAS(MXLAY,MXANG)
      DIMENSION ATOT(MXLAY,MXANG),ODCLD(MXLAY,NBANDS,MXANG)
      DIMENSION UFLUX(0:MXLAY),DFLUX(0:MXLAY),BBUTOT(MXLAY,MXANG)
      DIMENSION DRAD(0:MXLAY-1,MXANG),URAD(0:MXLAY,MXANG)
      DIMENSION SECANG(MXANG),ANGWEIGH(MXANG),RAD(MXANG)
      DIMENSION SECREG(MXANG,MXANG),WTREG(MXANG,MXANG)
      DIMENSION ABSCLD(MXLAY,NBANDS,MXANG)
      DIMENSION IPAT(16,0:2)

C Dimensions for cloud overlap adjustment
      DIMENSION ICLDLYR(MXLAY)
      DIMENSION FACCLD1(MXLAY+1),FACCLD2(MXLAY+1)
      DIMENSION FACCLR1(MXLAY+1),FACCLR2(MXLAY+1),ISTCLD(MXLAY+1)
      DIMENSION FACCMB1(MXLAY+1),FACCMB2(MXLAY+1)
      DIMENSION FACCLD1D(0:MXLAY),FACCLD2D(0:MXLAY),FACCLR1D(0:MXLAY)
      DIMENSION FACCLR2D(0:MXLAY),ISTCLDD(0:MXLAY),FACCMB1D(0:MXLAY)
      DIMENSION FACCMB2D(0:MXLAY)

      DATA IPAT /1,1,1,1,1,1,1,1,1, 1, 1, 1, 1, 1, 1, 1,
     &           1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5,
     &           1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/

C *** When standard first-order Gaussian quadrature is chosen as
C     the method to approximate the integral over angles that yields
C     flux from radiances, then SECREG(I,J) is the secant of the Ith  
C     (out of a total of J angles) and WTREG(I,J) is the corresponding
C     weight.
      DATA SECREG(1,1) / 1.5/
      DATA SECREG(2,2) / 2.81649655/, SECREG(1,2) / 1.18350343/
      DATA SECREG(3,3) / 4.70941630/, SECREG(2,3) / 1.69338507/
      DATA SECREG(1,3) / 1.09719858/
      DATA SECREG(4,4) / 7.15513024/, SECREG(3,4) / 2.40148179/
      DATA SECREG(2,4) / 1.38282560/, SECREG(1,4) / 1.06056257/
      DATA WTREG(1,1) / 0.50000000/
      DATA WTREG(2,2) /0.1819586183/, WTREG(1,2) /0.3180413817/
      DATA WTREG(3,3) /0.0698269799/, WTREG(2,3) /0.2292411064/
      DATA WTREG(1,3) /0.2009319137/
      DATA WTREG(4,4) /0.0311809710/, WTREG(3,4) /0.1298475476/
      DATA WTREG(2,4) /0.2034645680/, WTREG(1,4) /0.1355069134/
      DATA REC_6 /0.166667/

      HVRRGX = '$Revision: 3.2 $'

      RADSUM = 0.
      NUMANG = ABS(NUMANGS)
C *** Load angle data in arrays depending on angular quadrature scheme.
      DO 100 IANG = 1, NUMANG
         SECANG(IANG) = SECREG(IANG,NUMANG)
         ANGWEIGH(IANG) = WTREG(IANG,NUMANG)
 100  CONTINUE
      
      TOTUFLUX(0) = 0.0
      TOTDFLUX(0) = 0.0
      DO 120 IANG = 1, NUMANG
         URAD(0,IANG) = 0.0
         DRAD(0,IANG) = 0.0
 120  CONTINUE
      DO 200 LAY = 1, NLAYERS
         TOTUFLUX(LAY) = 0.0
         TOTDFLUX(LAY) = 0.0
         DO 180 IANG = 1, NUMANG
            URAD(LAY,IANG) = 0.
            DRAD(LAY,IANG) = 0.
            DO 150 IB = 1, NCBANDS
               IF (CLDFRAC(LAY) .GE. 1.E-6) THEN
                  ODCLD(LAY,IB,IANG) = SECANG(IANG) * TAUCLOUD(LAY,IB)
                  TRANSCLD = EXP(-ODCLD(LAY,IB,IANG))
                  ABSCLD(LAY,IB,IANG) = 1. - TRANSCLD
                  ICLDLYR(LAY) = 1
               ELSE
                  ODCLD(LAY,IB,IANG) = 0.0
                  ABSCLD(LAY,IB,IANG) = 0.0
                  ICLDLYR(LAY) = 0
               ENDIF
 150        CONTINUE
 180     CONTINUE
 200  CONTINUE

C *** Maximum/Random cloud overlap parameter

      ISTCLD(1) = 1
      ISTCLDD(NLAYERS) = 1
      DO 220 LEV = 1, NLAYERS

         IF (ICLDLYR(LEV).EQ.1) THEN
C  Maximum/random cloud overlap
            ISTCLD(LEV+1) = 0
            IF (LEV .EQ. NLAYERS) THEN
               FACCLD1(LEV+1) = 0.
               FACCLD2(LEV+1) = 0.
               FACCLR1(LEV+1) = 0.
               FACCLR2(LEV+1) = 0.
               FACCMB1(LEV+1) = 0.
               FACCMB2(LEV+1) = 0.
            ELSEIF (CLDFRAC(LEV+1) .GE. CLDFRAC(LEV)) THEN
               FACCLD1(LEV+1) = 0.
               FACCLD2(LEV+1) = 0.
               IF (ISTCLD(LEV) .EQ. 1) THEN
                  FACCLR1(LEV+1) = 0.
                  FACCLR2(LEV+1) = 0.
                  IF (CLDFRAC(LEV) .LT. 1.) FACCLR2(LEV+1) =
     &                 (CLDFRAC(LEV+1)-CLDFRAC(LEV))/(1.-CLDFRAC(LEV))
                  FACCLR2(LEV) = 0.
                  FACCLD2(LEV) = 0.
               ELSE
                  FMAX = MAX(CLDFRAC(LEV),CLDFRAC(LEV-1))
                  IF (CLDFRAC(LEV+1) .GT. FMAX) THEN
                     FACCLR1(LEV+1) = RAT2
                     FACCLR2(LEV+1) = (CLDFRAC(LEV+1)-FMAX)/(1.-FMAX)
                  ELSEIF (CLDFRAC(LEV+1) .LT. FMAX) THEN
                     FACCLR1(LEV+1) = (CLDFRAC(LEV+1)-CLDFRAC(LEV))/
     &                    (CLDFRAC(LEV-1)-CLDFRAC(LEV))
                     FACCLR2(LEV+1) = 0.
                  ELSE
                     FACCLR1(LEV+1) = RAT2
                     FACCLR2(LEV+1) = 0.
                  ENDIF
               ENDIF
               IF (FACCLR1(LEV+1).GT.0. .OR. FACCLR2(LEV+1).GT.0.) THEN
                  RAT1 = 1.
                  RAT2 = 0.
               ELSE
                  RAT1 = 0.
                  RAT2 = 0.
               ENDIF
            ELSE
               FACCLR1(LEV+1) = 0.
               FACCLR2(LEV+1) = 0.
               IF (ISTCLD(LEV) .EQ. 1) THEN
                  FACCLD1(LEV+1) = 0.
                  FACCLD2(LEV+1) = (CLDFRAC(LEV)-CLDFRAC(LEV+1))/
     &                 CLDFRAC(LEV)

                  FACCLR2(LEV) = 0.
                  FACCLD2(LEV) = 0.
               ELSE
                  FMIN = MIN(CLDFRAC(LEV),CLDFRAC(LEV-1))
                  IF (CLDFRAC(LEV+1) .LE. FMIN) THEN
                     FACCLD1(LEV+1) = RAT1
                     FACCLD2(LEV+1) = (FMIN-CLDFRAC(LEV+1))/FMIN
                  ELSE
                     FACCLD1(LEV+1) = (CLDFRAC(LEV)-CLDFRAC(LEV+1))/
     &                    (CLDFRAC(LEV)-FMIN)
                     FACCLD2(LEV+1) = 0.
                  ENDIF
               ENDIF
               IF (FACCLD1(LEV+1).GT.0. .OR. FACCLD2(LEV+1).GT.0.) THEN
                  RAT1 = 0.
                  RAT2 = 1.
               ELSE
                  RAT1 = 0.
                  RAT2 = 0.
               ENDIF
            ENDIF
            FACCMB1(LEV+1) = FACCLR1(LEV+1) * FACCLD2(LEV) *
     &           CLDFRAC(LEV-1) 
            FACCMB2(LEV+1) = FACCLD1(LEV+1) * FACCLR2(LEV) *
     &           (1. - CLDFRAC(LEV-1)) 
         ELSE
            ISTCLD(LEV+1) = 1
         ENDIF
220   CONTINUE

      DO 320 LEV = NLAYERS, 1, -1
         IF (ICLDLYR(LEV).EQ.1) THEN
            ISTCLDD(LEV-1) = 0
            IF (LEV .EQ. 1) THEN
               FACCLD1D(LEV-1) = 0.
               FACCLD2D(LEV-1) = 0.
               FACCLR1D(LEV-1) = 0.
               FACCLR2D(LEV-1) = 0.
               FACCMB1D(LEV-1) = 0.
               FACCMB2D(LEV-1) = 0.
            ELSEIF (CLDFRAC(LEV-1) .GE. CLDFRAC(LEV)) THEN
               FACCLD1D(LEV-1) = 0.
               FACCLD2D(LEV-1) = 0.
               IF (ISTCLDD(LEV) .EQ. 1) THEN
                  FACCLR1D(LEV-1) = 0.
                  FACCLR2D(LEV-1) = 0.
                  IF (CLDFRAC(LEV) .LT. 1.) FACCLR2D(LEV-1) =
     &                 (CLDFRAC(LEV-1)-CLDFRAC(LEV))/(1.-CLDFRAC(LEV))
                  FACCLR2D(LEV) = 0.
                  FACCLD2D(LEV) = 0.
               ELSE
                  FMAX = MAX(CLDFRAC(LEV),CLDFRAC(LEV+1))
                  IF (CLDFRAC(LEV-1) .GT. FMAX) THEN
                     FACCLR1D(LEV-1) = RAT2
                     FACCLR2D(LEV-1) = (CLDFRAC(LEV-1)-FMAX)/(1.-FMAX)
                  ELSEIF (CLDFRAC(LEV-1) .LT. FMAX) THEN
                     FACCLR1D(LEV-1) = (CLDFRAC(LEV-1)-CLDFRAC(LEV))/
     &                    (CLDFRAC(LEV+1)-CLDFRAC(LEV))
                     FACCLR2D(LEV-1) = 0.
                  ELSE
                     FACCLR1D(LEV-1) = RAT2
                     FACCLR2D(LEV-1) = 0.
                  ENDIF
               ENDIF
               IF (FACCLR1D(LEV-1).GT.0. .OR. FACCLR2D(LEV-1).GT.0.)THEN
                  RAT1 = 1.
                  RAT2 = 0.
               ELSE
                  RAT1 = 0.
                  RAT2 = 0.
               ENDIF
            ELSE
               FACCLR1D(LEV-1) = 0.
               FACCLR2D(LEV-1) = 0.
               IF (ISTCLDD(LEV) .EQ. 1) THEN
                  FACCLD1D(LEV-1) = 0.
                  FACCLD2D(LEV-1) = (CLDFRAC(LEV)-CLDFRAC(LEV-1))/
     &                 CLDFRAC(LEV)
                  FACCLR2D(LEV) = 0.
                  FACCLD2D(LEV) = 0.
               ELSE
                  FMIN = MIN(CLDFRAC(LEV),CLDFRAC(LEV+1))
                  IF (CLDFRAC(LEV-1) .LE. FMIN) THEN
                     FACCLD1D(LEV-1) = RAT1
                     FACCLD2D(LEV-1) = (FMIN-CLDFRAC(LEV-1))/FMIN
                  ELSE
                     FACCLD1D(LEV-1) = (CLDFRAC(LEV)-CLDFRAC(LEV-1))/
     &                    (CLDFRAC(LEV)-FMIN)
                     FACCLD2D(LEV-1) = 0.
                  ENDIF
               ENDIF
               IF (FACCLD1D(LEV-1).GT.0. .OR. FACCLD2D(LEV-1).GT.0.)THEN
                  RAT1 = 0.
                  RAT2 = 1.
               ELSE
                  RAT1 = 0.
                  RAT2 = 0.
               ENDIF
            ENDIF
            FACCMB1D(LEV-1) = FACCLR1D(LEV-1) * FACCLD2D(LEV) *
     &           CLDFRAC(LEV+1) 
            FACCMB2D(LEV-1) = FACCLD1D(LEV-1) * FACCLR2D(LEV) *
     &           (1. - CLDFRAC(LEV+1))
         ELSE
            ISTCLDD(LEV-1) = 1
         ENDIF
320   CONTINUE


C *** Loop over frequency bands.
      DO 6000 IBAND = ISTART, IEND
         IF (NCBANDS .EQ. 1) THEN
            IB = IPAT(IBAND,0)
         ELSEIF (NCBANDS .EQ.  5) THEN
            IB = IPAT(IBAND,1)
         ELSEIF (NCBANDS .EQ. 16) THEN
            IB = IPAT(IBAND,2)
         ENDIF
         IF (IBAND .EQ. 1) THEN
            CALL TAUGB1
         ELSEIF (IBAND .EQ. 2) THEN
            CALL TAUGB2
         ELSEIF (IBAND .EQ. 3) THEN
            CALL TAUGB3
         ELSEIF (IBAND .EQ. 4) THEN
            CALL TAUGB4
         ELSEIF (IBAND .EQ. 5) THEN
            CALL TAUGB5
         ELSEIF (IBAND .EQ. 6) THEN
            CALL TAUGB6
         ELSEIF (IBAND .EQ. 7) THEN
            CALL TAUGB7
         ELSEIF (IBAND .EQ. 8) THEN
            CALL TAUGB8
         ELSEIF (IBAND .EQ. 9) THEN
            CALL TAUGB9
         ELSEIF (IBAND .EQ. 10) THEN
            CALL TAUGB10
         ELSEIF (IBAND .EQ. 11) THEN
            CALL TAUGB11
         ELSEIF (IBAND .EQ. 12) THEN
            CALL TAUGB12
         ELSEIF (IBAND .EQ. 13) THEN
            CALL TAUGB13
         ELSEIF (IBAND .EQ. 14) THEN
            CALL TAUGB14
         ELSEIF (IBAND .EQ. 15) THEN
            CALL TAUGB15
         ELSE
            CALL TAUGB16
         ENDIF

         
C ***    Loop over g-channels.
         IG = 1
 1000    CONTINUE
         
C ***    Loop over each angle for which the radiance is to be computed.
         DO 3000 IANG = 1, NUMANG
C ***       Radiative transfer starts here.
            RADLD = 0.
            CLDRADD = 0.
            CLRRADD = 0.
            OLDCLD = 0.
            OLDCLR = 0.
            RADT = 0.
C ***       Downward radiative transfer.  
            DO 2500 LEV = NLAYERS, 1, -1
               PLFRAC = FRACS(LEV,IG)
               BLAY = PLANKLAY(LEV,IBAND)
               DPLANKUP = PLANKLEV(LEV,IBAND) - BLAY
               DPLANKDN = PLANKLEV(LEV-1,IBAND) - BLAY
               ODEPTH = SECANG(IANG) * TAUG(LEV,IG)
               IF (ODEPTH .LT. 0.0) ODEPTH = 0.0
               IF (ICLDLYR(LEV).EQ.1) THEN
                  ODTOT = ODEPTH + ODCLD(LEV,IB,IANG)
                  IF (ODTOT .LT. 0.06) THEN
                     ATRANS(LEV,IANG) = ODEPTH - 0.5*ODEPTH*ODEPTH
                     ODEPTH_REC = REC_6*ODEPTH
                     GASSRC = PLFRAC*(BLAY+DPLANKDN*ODEPTH_REC)
     &                  *ATRANS(LEV,IANG)

                     ATOT(LEV,IANG) =  ODTOT - 0.5*ODTOT*ODTOT
                     ODTOT_REC = REC_6*ODTOT
                     BBDTOT =  PLFRAC * (BLAY+DPLANKDN*ODTOT_REC)
                  
                     BBUGAS(LEV,IANG) =  PLFRAC *
     &                 (BLAY+DPLANKUP*ODEPTH_REC)
                     BBUTOT(LEV,IANG) =  PLFRAC * 
     &                 (BLAY+DPLANKUP*ODTOT_REC)
                  ELSEIF (ODEPTH .LE. 0.06) THEN
                     ATRANS(LEV,IANG) = ODEPTH - 0.5*ODEPTH*ODEPTH
                     ODEPTH_REC = REC_6*ODEPTH
                     GASSRC = PLFRAC*(BLAY+DPLANKDN*ODEPTH_REC)
     &                  *ATRANS(LEV,IANG)

                     ODTOT = ODEPTH + ODCLD(LEV,IB,IANG)
                     TBLIND = ODTOT/(BPADE+ODTOT)
                     ITTOT = TBLINT*TBLIND + 0.5
                     TFACTOT = TF(ITTOT)
                     BBDTOT = PLFRAC * (BLAY + TFACTOT*DPLANKDN)
                     ATOT(LEV,IANG) = 1. - TRANS(ITTOT)

                     BBUGAS(LEV,IANG) = PLFRAC * 
     &                 (BLAY + DPLANKUP*ODEPTH_REC)
                     BBUTOT(LEV,IANG) = PLFRAC * 
     &                 (BLAY + TFACTOT * DPLANKUP)
                  ELSE
                     TBLIND = ODEPTH/(BPADE+ODEPTH)
                     ITGAS = TBLINT*TBLIND+0.5
                     ODEPTH = TAUTBL(ITGAS)
                     ATRANS(LEV,IANG) = 1. - TRANS(ITGAS)
                     TFACGAS = TF(ITGAS)
                     GASSRC = ATRANS(LEV,IANG) * PLFRAC * 
     &                    (BLAY + TFACGAS*DPLANKDN)

                     ODTOT = ODEPTH + ODCLD(LEV,IB,IANG)
                     TBLIND = ODTOT/(BPADE+ODTOT)
                     ITTOT = TBLINT*TBLIND + 0.5
                     TFACTOT = TF(ITTOT)
                     BBDTOT = PLFRAC * (BLAY + TFACTOT*DPLANKDN)
                     ATOT(LEV,IANG) = 1. - TRANS(ITTOT)

                     BBUGAS(LEV,IANG) = PLFRAC * 
     &                 (BLAY + TFACGAS * DPLANKUP)
                     BBUTOT(LEV,IANG) = PLFRAC * 
     &                 (BLAY + TFACTOT * DPLANKUP)
                  ENDIF

                  IF (ISTCLDD(LEV) .EQ. 1) THEN
                     CLDRADD = CLDFRAC(LEV) * RADLD
                     CLRRADD = RADLD - CLDRADD
                     OLDCLD = CLDRADD
                     OLDCLR = CLRRADD
                     RADT = 0.
                  ENDIF
                  TTOT = 1. - ATOT(LEV,IANG)
                  CLDSRC = BBDTOT * ATOT(LEV,IANG)
                  CLDRADD = CLDRADD * TTOT + 
     &                 CLDFRAC(LEV) * CLDSRC
                  CLRRADD = CLRRADD * (1.-ATRANS(LEV,IANG)) +
     &                 (1. - CLDFRAC(LEV)) * GASSRC
                  radld = cldradd + clrradd
                  DRAD(LEV-1,IANG) = DRAD(LEV-1,IANG) + RADLD

                  RADMOD = RADT * 
     &                 (FACCLR1D(LEV-1) * (1.-ATRANS(LEV,IANG)) +
     &                 FACCLD1D(LEV-1) *  TTOT) - 
     &                 FACCMB1D(LEV-1) * GASSRC + 
     &                 FACCMB2D(LEV-1) * CLDSRC

                  OLDCLD = CLDRADD - RADMOD
                  OLDCLR = CLRRADD + RADMOD
                  RADT = -RADMOD + FACCLR2D(LEV-1)*OLDCLR -
     &                 FACCLD2D(LEV-1)*OLDCLD
                  CLDRADD = CLDRADD + RADT
                  CLRRADD = CLRRADD - RADT
               ELSE
                  IF (ODEPTH .LE. 0.06) THEN
                     ATRANS(LEV,IANG) = ODEPTH-0.5*ODEPTH*ODEPTH
                     ODEPTH = REC_6*ODEPTH
                     BBD = PLFRAC*(BLAY+DPLANKDN*ODEPTH)
                     BBUGAS(LEV,IANG) = PLFRAC*
     &                    (BLAY+DPLANKUP*ODEPTH)
                  ELSE
                     TBLIND = ODEPTH/(BPADE+ODEPTH)
                     ITR = TBLINT*TBLIND+0.5
                     TRANSC = TRANS(ITR)
                     ATRANS(LEV,IANG) = 1.-TRANSC
                     TAUSFAC = TF(ITR)
                     BBD = PLFRAC*(BLAY+TAUSFAC*DPLANKDN)
                     BBUGAS(LEV,IANG) = PLFRAC * 
     &                    (BLAY + TAUSFAC * DPLANKUP)
                  ENDIF   
                  RADLD = RADLD + (BBD-RADLD)*ATRANS(LEV,IANG)
                  DRAD(LEV-1,IANG) = DRAD(LEV-1,IANG) + RADLD
               ENDIF
 2500       CONTINUE
            RAD(IANG) = RADLD
            RADSUM = RADSUM + ANGWEIGH(IANG) * RADLD
 3000    CONTINUE 

         RAD0 = FRACS(1,IG) * PLANKBND(IBAND)
         REFLECT = 1. - SEMISS(IBAND)
         DO 4000 IANG = 1, NUMANG
            RADLD = 0.
            CLDRADD = 0.
            CLRRADD = 0.
            OLDCLD = 0.
            OLDCLR = 0.
            RADT = 0.
C           Add in reflection of surface downward radiance.
            IF (IREFLECT .EQ. 1) THEN
C              Specular reflection.
               RADLU = RAD0 + REFLECT * RAD(IANG)
            ELSE
C              Lambertian reflection.
               RADLU = RAD0 + 2. * REFLECT * RADSUM
            ENDIF
            URAD(0,IANG) = URAD(0,IANG) + RADLU
C ***       Upward radiative transfer.
            DO 2600 LEV = 1, NLAYERS
            IF (ICLDLYR(LEV) .EQ. 1) THEN
               GASSRC = BBUGAS(LEV,IANG) * ATRANS(LEV,IANG)
               IF (ISTCLD(LEV) .EQ. 1) THEN
                  CLDRADU = CLDFRAC(LEV) * RADLU
                  CLRRADU = RADLU - CLDRADU
                  OLDCLD = CLDRADU
                  OLDCLR = CLRRADU
                  RADT = 0.
               ENDIF
               TTOT = 1. - ATOT(LEV,IANG)
               CLDSRC = BBUTOT(LEV,IANG) * ATOT(LEV,IANG)
               CLDRADU = CLDRADU * TTOT + 
     &              CLDFRAC(LEV) * CLDSRC
               CLRRADU = CLRRADU * (1.0-ATRANS(LEV,IANG)) +
     &              (1. - CLDFRAC(LEV)) * GASSRC
C     Total sky radiance
               RADLU = CLDRADU + CLRRADU
               URAD(LEV,IANG) = URAD(LEV,IANG) + RADLU
               RADMOD = RADT * 
     &              (FACCLR1(LEV+1)*(1.0-ATRANS(LEV,IANG))+
     &              FACCLD1(LEV+1) *  TTOT) - 
     &              FACCMB1(LEV+1) * GASSRC + 
     &              FACCMB2(LEV+1) * CLDSRC
               OLDCLD = CLDRADU - RADMOD
               OLDCLR = CLRRADU + RADMOD
               RADT = -RADMOD + FACCLR2(LEV+1)*OLDCLR -
     &           FACCLD2(LEV+1)*OLDCLD
               CLDRADU = CLDRADU + RADT
               CLRRADU = CLRRADU - RADT
            ELSE
               RADLU = RADLU + (BBUGAS(LEV,IANG)-RADLU)*ATRANS(LEV,IANG)
               URAD(LEV,IANG) = URAD(LEV,IANG) + RADLU
            ENDIF
 2600       CONTINUE
 4000    CONTINUE 
         RADSUM = 0.

         IG = IG + 1
         IF (IG .LE. 16) GO TO 1000

C ***    Calculate upward, downward, and net flux.
         DO 5000 LEV = NLAYERS, 0, -1
            UFLUX(LEV) = 0.0
            DFLUX(LEV) = 0.0
            DO 4500 IANG = 1, NUMANG
               UFLUX(LEV) = UFLUX(LEV) + URAD(LEV,IANG)*ANGWEIGH(IANG)
               DFLUX(LEV) = DFLUX(LEV) + DRAD(LEV,IANG)*ANGWEIGH(IANG)
               URAD(LEV,IANG) = 0.0
               DRAD(LEV,IANG) = 0.0
 4500       CONTINUE
            TOTUFLUX(LEV) = TOTUFLUX(LEV) + UFLUX(LEV) * DELWAVE(IBAND)
            TOTDFLUX(LEV) = TOTDFLUX(LEV) + DFLUX(LEV) * DELWAVE(IBAND)
 5000    CONTINUE
 6000 CONTINUE 

      DO 7000 LEV = 0, NLAYERS
         TOTUFLUX(LEV) = TOTUFLUX(LEV) * FLUXFAC
         TOTDFLUX(LEV) = TOTDFLUX(LEV) * FLUXFAC
         FNET(LEV) = TOTUFLUX(LEV) - TOTDFLUX(LEV)
 7000 CONTINUE

C *** Calculate Heating Rates.
      HTR(NLAYERS) = 0.0
      DO 8000 LEV  = NLAYERS-1, 0, -1
         LAY = LEV + 1
         HTR(LEV)=HEATFAC*(FNET(LEV)-FNET(LAY))/(PZ(LEV)-PZ(LAY)) 
 8000 CONTINUE

      RETURN
      END   


