geocor.f

Go to the documentation of this file.

      subroutine geocor
c
c     apply geometric correction to the stokes parameters of the diffuse
c     radiation leaving the top and bottom of the atmosphere
c
c**********************************************************************
c
      implicit real*8 (a-h,o-z)
      include 'afrt_rt2.cmn'
      integer*4 s
c
c**********************************************************************
c
      m1=jpass-2
      m2=jpass-1
      m3=jpass
c
c     apply geo. series correction to the fluxes leaving the bottom
c     of the atmosphere
c
      call geom(fluxd(m1,nolyr+1),fluxd(m2,nolyr+1),fluxd(m3,nolyr+1),
     1          rr1,temp1(nolyr+1))
      call geom(fluxu(m1,1),fluxu(m2,1),fluxu(m3,1),
     1          rr2,temp2(1))
c
      if(kzz.eq.1)then
         totflxgs=temp1(nolyr+1)+temp2(1)+amuo*factr
         ctest=totflxgs/amuo
      endif
      if(kzz.eq.1)gz=temp1(nolyr+1)
      if(kzz.eq.2 .and. itrans.eq.0)sb=temp1(nolyr+1)
c
c     apply geo. series correction to the radiances leaving the top &
c     bottom of the atmosphere
c
      read(71,rec=m3)ftmp
      read(71,rec=m2)ftmpa
      read(71,rec=m1)ftmpb
c     if iglint=1 then remove the direct component
      if(kzz.eq.1 .and. iglint.eq.1)then
         do i=nx,nmum1
            do j=1,jpart
               do k=1,4
                  abcz=dexp(-tautot/dabs(cosmu(i)))
                  ftmp(k,i,j)=ftmp(k,i,j)-fglint(k,i,j)*abcz
                  ftmpa(k,i,j)=ftmpa(k,i,j)-fglint(k,i,j)*abcz
                  ftmpb(k,i,j)=ftmpb(k,i,j)-fglint(k,i,j)*abcz
               enddo
            enddo
         enddo
      endif
c     
      do i=nx,nmum1
         m=nmum1-i+1
         do j=1,jpart
            do k=1,4
               if(ftmp(k,i,j).le.1.0d-15)then
                  fioup(k,m,j)=ftmp(k,i,j)
               else
                  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
     1                      ratiog,fioup(k,m,j))
               endif
            enddo
         enddo
      enddo
c
      read(72,rec=m3)ftmp
      read(72,rec=m2)ftmpa
      read(72,rec=m1)ftmpb
c
c      if(iref .eq.1 .and. itrans.eq.1)then
c
      do i=nx,nmum1
         m=nmum1-i+1
         do j=1,jpart
            do k=1,4
               if(ftmp(k,i,j).le.1.0d-15)then
                  fioup_btm(k,m,j)=ftmp(k,i,j)
               else
                  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
     1                      ratiog,fioup_btm(k,m,j))
               endif
            enddo
         enddo
      enddo
c
c      else
c
      do i=1,nx-1
         do j=1,jpart
            do k=1,4
               if(ftmp(k,i,j).le.1.0d-15)then
                  fiodn(k,i,j)=ftmp(k,i,j)
               else
                  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
     1                      ratiog,fiodn(k,i,j))
               endif
            enddo
         enddo
      enddo
c
 
c      endif
c
      if(kzz.eq.1)then
        call outmds
c
        fdirc(ksza)=amufpi
        fdown(ksza)=temp1(nolyr+1)*pi
        fup(ksza)=temp2(1)*pi
        do i=1,nx-1
           do j=1,jpart
              xzeroz(1,ksza,i,j)=fioup(1,i,j)+fioup(2,i,j)
              xzeroz(2,ksza,i,j)=fioup(1,i,j)-fioup(2,i,j)
              xzeroz(3,ksza,i,j)=fioup(3,i,j)
              xzeroz(4,ksza,i,j)=fioup(4,i,j)
              xzerod(1,ksza,i,j)=fiodn(1,i,j)+fiodn(2,i,j)
              xzerod(2,ksza,i,j)=fiodn(1,i,j)-fiodn(2,i,j)
              xzerod(3,ksza,i,j)=fiodn(3,i,j)
              xzerod(4,ksza,i,j)=fiodn(4,i,j)
           enddo
        enddo
        if(iref.eq.1 .or. iref.eq.2 .or.iref.eq.3)then
          oalb(ksza)=calb
        endif
      endif
c
      do i=1,nx-1
         do j=1,jpart
            xzero_up(ksza,i,j)=fioup(1,i,j)+fioup(2,i,j)
            xzero_btm(ksza,i,j)=fioup_btm(1,i,j)+fioup_btm(2,i,j)
         enddo
      enddo
      if(kzz.eq.2 .and. itrans.eq.1)then
        call outmds_trans
        do i=1,nx-1
           do j=1,jpart
              xzero_up(ksza,i,j)=fioup(1,i,j)+fioup(2,i,j)
              xzero_btm(ksza,i,j)=fioup_btm(1,i,j)+fioup_btm(2,i,j)
           enddo
        enddo
      else if(kzz.eq.2 .and. itrans.eq.0)then
        call outmds
        ef=amuo*efactb(nolyr+1)
        ftot=(gz+ef)
          do i=1,nx-1
             do j=1,jpart              
                tdn(1,i,j)=(fiodn(1,i,j)+fiodn(2,i,j))
                tdn(2,i,j)=(fiodn(1,i,j)-fiodn(2,i,j))
                tdn(3,i,j)=(fiodn(3,i,j))
                tdn(4,i,j)=(fiodn(4,i,j))
                tup(1,i,j)=(fioup(1,i,j)+fioup(2,i,j))
                tup(2,i,j)=(fioup(1,i,j)-fioup(2,i,j))
                tup(3,i,j)=(fioup(3,i,j))
                tup(4,i,j)=(fioup(4,i,j))
             enddo
          enddo
c
          sbarz(ksza)=sb                     
          do i=1,nx-1
             do j=1,jpart
                do s=1,nstk
                    tupz(s,ksza,i,j)=tup(s,i,j)*ftot
                    tdwnz(s,ksza,i,j)=tdn(s,i,j)*ftot
                enddo
             enddo
          enddo
      endif
c
      if(nsza.gt.1)then
        ef=amuo*efactb(nolyr+1)
        ftot=(gz+ef)
        sbarz(ksza)=sb
          do i=1,nx-1
             do j=1,jpart
                do s=1,nstk
                    tupz(s,ksza,i,j)=tup(s,i,j)*ftot
                    tdwnz(s,ksza,i,j)=tdn(s,i,j)*ftot
                enddo
             enddo
          enddo
      endif
c                                                                       
c**********************************************************************
      return                                                            
      end                                                               
c************************************************************************