subroutine uvheat(rh,col,den,ntau,swave,sflx,crs,nwav,ht)

        implicit double precision (a-h,o-z)
        include "parameters.dat"

        dimension col(nd1,0:4), den(nd1,0:4), swave(nd5),sflx(nd5)
     &   , crs(nd5,0:3),ht(nd1),wav0(0:3)

        data wav0/1265.d0,1870.d0,3000.d0,2000.d0/

        do jt = 1, ntau
           ht(jt) = zero
        end do

        efac = 1.d8*hc/rh/rh

        do jw = 1, nwav
           ergs = efac*sflx(jw)/swave(jw)
           do js = 0, 3
              eff = dmax1(one-swave(jw)/wav0(js),zero)
              fac = half*ergs*eff

              do jt = 1, ntau
                 opp = den(jt,js)*crs(jw,js)
                 tau = col(jt,js)*crs(jw,js)
c                 if(swave(jw) .gt. 1000.d0) then
                 ht(jt)=ht(jt)+fac*den(jt,js)*crs(jw,js)*en(2,tau)
c     --- LAY
                 if (js .eq. 2 .and. jt .eq. ntau .and. jw .eq. nwav) 
     &                then
                    d = fac*den(jt,js)*crs(jw,js)*en(2,tau)
                    write(*,*) 
     &                   'uvheat: js = 1, lowest atm, last wavelength'
                    write(*,*) 'wave = ', swave(jw)
                    write(*,*) 'den = ', den(jt,js)
                    write(*,*) 'crs = ', crs(jw,js)
                    write(*,*) 'opp = ', opp
                    write(*,*) 'tau = ', tau
                    write(*,*) 'en2(tau)= ', en(2,tau)
                    write(*,*) 'fac = ', fac
                    write(*,*) 'h = ', d
                 end if
c     --- LAY
c                 else
c                 ht(jt)=ht(jt)+two*fac*den(jt,js)*crs(jw,js)*en(2,tau)
c                 end if
              end do

           end do
        end do

        return
        end