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 'common_all.cmn'
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,nolyrp),fluxd(m2,nolyrp),fluxd(m3,nolyrp),
     1          rr1,temp1(nolyrp))
      call geom(fluxu(m1,1),fluxu(m2,1),fluxu(m3,1),
     1          rr2,temp2(1))
c
      if(kzz.eq.1)then
         totflxgs=temp1(nolyrp)+temp2(1)+amuo*factr
         ctest=totflxgs/amuo
      endif
      if(kzz.eq.1)gz=temp1(nolyrp)
      if(kzz.eq.2 .and. itrans.eq.0)sb=temp1(nolyrp)
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=jjj,nmum1
            do j=1,jpart
               do k=1,4
                  abcz=dexp(-tautot/dabs(bmu(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=jjj,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
      if(iref .eq.1 .and. itrans.eq.1)then
c
      do i=jjj,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
      else
c
      do i=1,jjjj
         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
 
      endif
c
      if(kzz.eq.1)then
        call outmds
c
        fdirc(ksza)=amufpi
        fdown(ksza)=temp1(nolyrp)*pi
        fup(ksza)=temp2(1)*pi
        do i=1,jjjj
           do j=1,jpart
              xzeroz(ksza,i,j)=fioup(1,i,j)+fioup(2,i,j)
              xzerod(ksza,i,j)=fiodn(1,i,j)+fiodn(2,i,j)
           enddo
        enddo
        if(iref.eq.1 .or. iref.eq.2 .or.iref.eq.3)then
          oalb(ksza)=calb
        endif
      endif
c
      if(kzz.eq.2 .and. itrans.eq.1)then
        call outmds_trans
        do i=1,jjjj
           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(nolyrp)
        ftot=(gz+ef)
          do i=1,jjjj                                                   
             do j=1,jpart              
                tdn(i,j)=(fiodn(1,i,j)+fiodn(2,i,j))
                tup(i,j)=(fioup(1,i,j)+fioup(2,i,j))
             enddo
          enddo
c
          sbarz(ksza)=sb                     
          do i=1,jjjj                 
             do j=1,jpart            
                    tupz(ksza,i,j)=tup(i,j)*ftot
                    tdwnz(ksza,i,j)=tdn(i,j)*ftot          
             enddo
          enddo
      endif
c
      if(nsza.gt.1)then
        ef=amuo*efactb(nolyrp)
        ftot=(gz+ef)
        sbarz(ksza)=sb
          do i=1,jjjj
             do j=1,jpart
                    tupz(ksza,i,j)=tup(i,j)*ftot
                    tdwnz(ksza,i,j)=tdn(i,j)*ftot
             enddo
          enddo
      endif
c                                                                       
c**********************************************************************
      return                                                            
      end                                                               
c************************************************************************