snglup.f

Go to the documentation of this file.

      subroutine snglup
c
c     compute the stokes parameters for the upwelling radiation in single  
c     scattering approx. when the atmosphere is illuminated from below
c
c*************************************************************************
c.....includes the common blocks
      implicit real*8 (a-h,o-z)
      include 'common_all.cmn'
c
c**************************************************************************
c
c     initialize the buffers  
c
c     write(6,*)'welcome to subroutine snglup'
      do i=1,nmum1
         do j=1,jpart
            do k=1,4
               fio(k,i,j)=0.0d0
               ftmp(k,i,j)=0.0d0
               ftmpa(k,i,j)=0.0d0
            enddo
         enddo
      enddo
c
c     compute the upwelling single scattered diffused radiation.
c     save the upwelling diffuse radiation for level nolyrp in the
c     buffer ftmpa
c
c     write(6,*)'begin the upwrad loop'
      read(55,rec=nolyrp)fiib
      read(55,rec=nolyrp)ftmpa
c
      do il=1,nolyr
         im=nolyr-il+1
c
         tmsl=dtmm(im)*qsqt*const
         trsl=dtrr(im)*conr
         dlyr=dtot(im)
c
         do i=jjj,nmum1
            do j=1,jpart
               do k=1,4
                  ftmp(k,i,j)=0.0d0
                  fiic(k,i,j)=ftmpa(k,i,j)*emtm(im,i)
               enddo
            enddo
         enddo
c
         call mdiffn(jjj,nmum1,im,dlyr)
c
         do i=jjj,nmum1
            do j=1,jpart
               do k=1,4
                  fio(k,i,j)=fiib(k,i,j)*emdtm(im,i)+
     1                       ftmp(k,i,j)*(1.0d0-emdtm(im,i))
               enddo
            enddo
         enddo
c
c        write(6,*)'upward loop..top of layer no.',im
         write(55,rec=im)fio
c
c        transfer the values from fio to fiib
c
         do i=jjj,nmum1
            do j=1,jpart
               do k=1,4
                  fiib(k,i,j)=fio(k,i,j)
               enddo
            enddo
         enddo
c
      enddo
c
c
c     compute the downward radiation
c
      read(55,rec=1)fiib
      do il=1,nolyr
         ilp=il+1
         read(55,rec=ilp)fio
c
         tmsl=dtmm(il)*qsqt*const
         trsl=dtrr(il)*conr
         dlyr=dtot(il)
c
         do i=1,jjjj
            do j=1,jpart
               do k=1,4
                  fiic(k,i,j)=ftmpa(k,i,j)*emtm(il,i)
               enddo
            enddo
         enddo
c
         call mdiffn(1,jjjj,il,dlyr)
c
         do i=1,jjjj
            do j=1,jpart
               do k=1,4
                  fio(k,i,j)=fiib(k,i,j)*emdtm(il,i)+
     1                       ftmp(k,i,j)*(1.0d0-emdtm(il,i))
               enddo
            enddo
         enddo
c
c        transfer the values from fio to fiib
c
         do i=1,jjjj
            do j=1,jpart
               do k=1,4
                  fiib(k,i,j)=fio(k,i,j)
               enddo
            enddo
         enddo
c
         write(55,rec=ilp)fio
      enddo
c
c     if iref=0 then copy all records to unit 64 for multiple scattering 
c     calculations
c
      if(iref.eq.0 .or. itrans .eq.1)then
        do il=1,nolyrp
           read(55,rec=il)ftmp
           write(64,rec=il)ftmp
        enddo
        eo(1)=0.0d0
        eo(2)=0.0d0
c
      endif
      return
      end
c***********************************************************************