multp2d_trans.f

Go to the documentation of this file.

      subroutine multp2d_trans
c
c     compute the multiple scattering contribution when the atmosphere is
c     illuminated from the bottom.  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'
c
c**************************************************************************
c
c     compute the downward diffuse radiation at each level
c
      read(irad,rec=1)fiib
      write(iwrt,rec=1)fiib
      do il=1,nolyr
        ilp=il+1
        ilm=il-1
        if(il.eq.1)then
             read(iwrt,rec=il)fiib
             read(irad,rec=ilp)fio
c        determine average intensity at the center of the layer il
             do i=1,nmum1
             do j=1,jpart
                do k=1,4
                   fiic(k,i,j)=0.50d0*(fio(k,i,j)+fiib(k,i,j))
                   ftmp(k,i,j)=0.0d0
                enddo
             enddo
             enddo
             tmsl=dtmm(il)*qsqt*const
             trsl=dtrr(il)*conr
             dlyr=dtot(il)
             if(ifc.eq.0)tmsl=0.0d0
             call mdiffn(1,nx-1,il,dlyr)
             do i=1,nx-1
                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
             write(iwrt,rec=ilp)fio
        else
             read(iwrt,rec=ilm)fiib
             do i=1,nmum1
                 do j=1,jpart
                    do k=1,4
                       fiic(k,i,j)=fio(k,i,j)
                       ftmp(k,i,j)=0.0d0
                    enddo
                 enddo
             enddo
             read(irad,rec=ilp)fio
             tmsl=(dtmm(ilm)+dtmm(il))*qsqt*const
             trsl=(dtrr(ilm)+dtrr(il))*conr
             dlyr=(dtot(ilm)+dtot(il))
             if(ifc.eq.0)tmsl=0.0d0
             call mdiffn(1,nx-1,il,dlyr)
             do i=1,nx-1
                do j=1,jpart
                   do k=1,4
                      fio(k,i,j)=fiib(k,i,j)*emdtm(ilm,i)*emdtm(il,i)+
     1              ftmp(k,i,j)*(1.0d0-emdtm(ilm,i)*emdtm(il,i))
                   enddo
                enddo
             enddo
             write(iwrt,rec=ilp)fio
        endif
      enddo
c
      if(iref.eq.1 .and. itrans.eq.1)then
         call fltocn_diff
         write(iwrt,rec=nolyr+1)fio
      endif
c
c     compute the upward diffuse radiation at each level
      do il=1,nolyr
         im=nolyr-il+1
         imp=im+1
         impp=imp+1
        if(il.eq.1)then
             read(iwrt,rec=imp)fiib
             read(iwrt,rec=im)fio
             do i=1,nmum1
                 do j=1,jpart
                    do k=1,4
                       fiic(k,i,j)=0.50d0*(fio(k,i,j)+fiib(k,i,j))
                       ftmp(k,i,j)=0.0d0
                    enddo
                 enddo
             enddo
             tmsl=dtmm(im)*qsqt*const
             trsl=dtrr(im)*conr
             dlyr=dtot(im)
             if(ifc.eq.0)tmsl=0.0d0
             call mdiffn(nx,nmum1,im,dlyr)
             do i=nx,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
             write(iwrt,rec=im)fio
            else
             read(iwrt,rec=impp)fiib
             do i=1,nmum1
                 do j=1,jpart
                    do k=1,4
                       fiic(k,i,j)=fio(k,i,j)
                       ftmp(k,i,j)=0.0d0
                    enddo
                 enddo
             enddo
             read(iwrt,rec=im)fio
             tmsl=(dtmm(imp)+dtmm(im))*qsqt*const
             trsl=(dtrr(imp)+dtrr(im))*conr
             dlyr=(dtot(imp)+dtot(im))
             if(ifc.eq.0)tmsl=0.0d0
             call mdiffn(nx,nmum1,im,dlyr)
             do i=nx,nmum1
                do j=1,jpart
                   do k=1,4
                      fio(k,i,j)=fiib(k,i,j)*emdtm(imp,i)*emdtm(im,i)+
     1               ftmp(k,i,j)*(1.0d0-emdtm(imp,i)*emdtm(im,i))
                   enddo
                enddo
             enddo
             write(iwrt,rec=im)fio
        endif
      enddo
c
      return
      end
c***********************************************************************