NASA Ocean Color

ocssw V2022
       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**********************************************************************
attenew
subroutine attenew
Definition: attenew.f:2
spline
subroutine spline(s, x, y, n, in, t, il, iu, vl, vu, e, u)
Definition: phs.f:1348
real
#define real
Definition: DbAlgOcean.cpp:26