attenew.f

Go to the documentation of this file.

      subroutine attenew                                                  
c
c     subroutine atten computes the attenuation factors for the         
c      direct and the difffused beams                                   
c***********************************************************************
c.....includes the common blocks                                        
      implicit real*8 (a-h,o-z)
      include 'afrt_rt2.cmn'
      real*8 dtotl(1000)                                                
      real*8 totl(1000),e(1000),u(1000)                                 
c                                                                       
c***********************************************************************
c                                                                       
c     determine the total optical thickness at every level in the 
c     atmosphere
c
      taupl(1)=0.0d0
      do i=1,nolyr                                                 
         taupl(i+1)=taupl(i)+dtot(i)
      enddo
c
       in=1                                                             
       il=1                                                             
       iu=1                                                             
       if(ipsudo.eq.1)then                                              
           totl(1)=1.0d-10
           do i=2,(nolyr+1)
               call spline(pl(i),ppo,totsp,nmodl,in,totl(i),il,iu,vl,      
     1                     vu,e,u)                                   
           enddo                                                        
           do i=1,nolyr     
              dtotl(i)=totl(i+1)-totl(i)                                
           enddo                                                        
c
c          compute the solar attenuation  upto the middle as well as
c          bottom of the layer
c
           efactb(1)=1.0d0
           do i=1,nolyr
              plths=0.5d0*dtotl(i)+totl(i)
              efact(i)=dexp(-plths)                                  
              efactb(i+1)=dexp(-totl(i+1))
           enddo                                                        
           eo(1)=0.5d0*dexp(-totl(nolyr+1))
           eo(2)=0.5d0*dexp(-totl(nolyr+1))
       else                                                             
c
c          compute the solar attenuation  upto the middle as well as
c          bottom of the layer (plane parallel case)
c
           efactb(1)=1.0d0
           do i=1,nolyr
              plthx=0.50d0*dtot(i)+taupl(i)
              efact(i)=dexp(-plthx/amuo)
              efactb(i+1)=dexp(-taupl(i+1)/amuo)
c          write(6,193)amuo,i,dtrr(i),dtmm(i),dtaa(i),efact(i) 
193    format('amuo,i,dtrr,dtmm,dtaa,amuo,efact',1pe11.3/i2,1p6e11.3)  
           enddo
           eo(1)=0.5d0*dexp(-taupl(nolyr+1)/amuo)
           eo(2)=0.5d0*dexp(-taupl(nolyr+1)/amuo)
       endif                                                            
c                                                                       
       if(ipsudo.eq.1)then                                              
         do i=1,(nolyr+1)
c           write(6,149)ht(i),totl(i),dtotl(i),efact(i)       
149         format('htl,totl,dtotl,efact'/1p5e12.5)              
         enddo                                                          
       endif                                                            
c
       if(ipsudo.ne.1)then
       totl(1)=1.0d-10
       do i=1,nolyr
          totl(i+1)=totl(i)+dtot(i)
       enddo
       endif
       do i=1,nolyr
          xxx=totl(i+1)-0.5d0*dtot(i)
          do j=1,nmum1                                                 
             zzz = dabs(cosmu(j))
             emdtm(i,j)=dexp(-dtot(i)/zzz)
c            emd2tm(i,j)=dexp(-(0.5d0*dtot(i))/zzz)
             emtm(i,j)=dexp(-xxx/zzz)
          enddo
       enddo
c
       do i=1,(nolyr+1)
          do j=1,(nx-1)
             zzz=dabs(cosmu(j))
             xxx=totl(i)
             atnflx(i,j)=dexp(-xxx/zzz)
          enddo
       enddo
c                                                                       
       return                                                           
       end                                                              
c**********************************************************************