single.f

Go to the documentation of this file.

      subroutine single
c
c     compute the single scattering contribution when the atmosphere is
c     illuminated from the top.  also, for each level, store the 
c     upwelling/downwelling diffuse radiation.
c
c*************************************************************************
c.....includes the common blocks
      implicit real*8 (a-h,o-z)
      include 'afrt_rt2.cmn'
      real*8 pfs(32,nph,2*nsz)
      equivalence(pfs(1,1,1),pc(1,1,1))
c
c**************************************************************************
c
c     initialize the buffers
c
      do i=1,4
         do j=1,nmum1
            do k=1,jpart
               fio(i,j,k)=0.0d0
               ftmp(i,j,k)=0.0d0
            enddo
         enddo
      enddo
c
c     initialize all levels
c
      do il=1,nolyr+1
         write(53,rec=il)fio
         write(64,rec=il)fio
      enddo
c
c     compute the downward diffuse radiation at each level
c
      write(53,rec=1)fio
c
      do il=1,nolyr
         ilp=il+1
         read(53,rec=il)fiib
         read(53,rec=ilp)fio
         tmsl=dtmm(il)*qsqt*const
         trsl=dtrr(il)*conr
c
         do is=1,4      
             qfi(is)=ei(is)*efact(il)/dtot(il)
         enddo
c        write(6,*)'layer no,qfi,efact,ei(1),dtot',il,qfi,efact(il),
c    1              ei(1),dtot(il)
c
         do it=1,(nx-1)
           do ip=1,jpart
              do is=1,4
                 gfot(is)=0.0d0
              enddo
              do i=1,4
                 do j=1,4
                    ij=(i-1)*4+j
                      gfot(i)=gfot(i)+(pfs(ij,ip,it)*tmsl +
     1                        pfs(ij+16,ip,it)*trsl)*qfi(j)
                 enddo
                 ftmp(i,it,ip)=gfot(i)*(1.0d0-emdtm(il,it))
                 if(i.gt.2)then
                   do ks=3,4
                      ftmp(ks,it,ip)=-ftmp(ks,it,ip)
                   enddo
                 endif
                 fio(i,it,ip)=fiib(i,it,ip)*emdtm(il,it)+
     1                        ftmp(i,it,ip)
              enddo
           enddo
         enddo
c
c          write(6,*)'Bottom of layer num  ',il
c          do i=1,(nx-1)
c             call radnce(pi,conv,cosmu,the,fio,i,jpart,jphi)
c          enddo
 
         write(53,rec=ilp)fio
         write(54,rec=il)ftmp
c
      enddo
c
c          write(6,*)'Single....Bottom....Downwelling'
c          do i=1,(nx-1)
c             call radnce(pi,conv,cosmu,the,fio,i,jpart,jphi)
c          enddo
c
      if(iref.eq.1)then
c        write(*,*)'Ready to call fltocn'
c        write(*,*)'rmu',rmu
         call fltocn_new
c        call fltocn(fio,cosmu,dmu,dmus2,eo,ddphi,amuo,pi,sumc,sumcpi,
c    1               sumdwn,calb,rmu,conv,eox,kkx,(nx-1),nmum1,jpart)
        write(53,rec=nolyr+1)fio
      endif
c
c         write(6,*)'Single....Bottom....Upwelling...After Relection'
c          do i=nx,nmum1
c             call radnce(pi,conv,cosmu,the,fio,i,jpart,jphi)
c          enddo
c
c     save the reflected radiation
      do i=nx,nmum1
         do j=1,jpart
            do  k=1,4
                  ftmpb(k,i,j)=fio(k,i,j)
            enddo  
         enddo 
      enddo
c     compute the upward diffuse radiation at each level
 
      do il=1,nolyr
         im=nolyr-il+1
         imp=im+1
         read(53,rec=imp)fiib
         read(53,rec=im)fio
         read(54,rec=im)ftmp
         tmsl=dtmm(im)*qsqt*const
         trsl=dtrr(im)*conr
 
         do is=1,4      
            qfi(is)=ei(is)*efact(im)/dtot(im)
         enddo
 
         do it=nx,nmum1
           do ip=1,jpart
              do is=1,4
                 gfot(is)=0.0d0
              enddo
              do i=1,4
                 do j=1,4
                    ij=(i-1)*4+j
                      gfot(i)=gfot(i)+(pfs(ij,ip,it)*tmsl+
     1                        pfs(ij+16,ip,it)*trsl)*qfi(j)
                 enddo
                 ftmp(i,it,ip)=gfot(i)*(1.0d0-emdtm(im,it))
                 if(i.gt.2)then
                   do ks=3,4
                      ftmp(ks,it,ip)=-ftmp(ks,it,ip)
                   enddo
                 endif
                 fio(i,it,ip)=fiib(i,it,ip)*emdtm(im,it)+ftmp(i,it,ip)
              enddo
           enddo
         enddo
c
c     add the contribution from the specular reflection
c        do is=1,4
c            qfi(is)=eox(is)*efact(il)/dtot(il)
c        enddo
c
c        do it=nx,nmum1
c           itp=nmum1-it+1
c          do ip=1,jpart
c             do is=1,4
c                gfot(is)=0.0d0
c             enddo
c             do i=1,4
c                do j=1,4
c                   ij=(i-1)*4+j
c                     gfot(i)=gfot(i)+(pfs(ij,ip,itp)*tmsl +
c    1                        pfs(ij+16,ip,itp)*trsl)*qfi(j)
c                enddo
c                ftmp(i,it,ip)=gfot(i)*(1.0d0-emdtm(im,itp))
c                if(i.gt.2)then
c                  do ks=3,4
c                     ftmp(ks,it,ip)=-ftmp(ks,it,ip)
c                  enddo
c                endif
c                fio(i,it,ip)=fio(i,it,ip)+ftmp(i,it,ip)+
c    1               ftmpb(i,it,ip)*atnflx(il+1,it)
c             enddo
c          enddo
c        enddo
c
c
         write(53,rec=im)fio
         write(54,rec=im)ftmp
c
      enddo
c     copy all records to unit 64 for multiple scattering calculations
c
      do il=1,nolyr+1
         read(53,rec=il)ftmp
         write(64,rec=il)ftmp
      enddo
c
c     write(6,*)'Single....Top....Upwelling'
      do i=nx,nmum1
c         call radnce(pi,conv,cosmu,the,fio,i,jpart,jphi)
      enddo
c
      return
      end
c***********************************************************************