crftgcr.f

Go to the documentation of this file.

      subroutine crftgcr
c
c     apply geometric correction to the stokes parameters of the diffuse
c     radiation at atmospheric levels bracketing the aircraft levels
c
c**********************************************************************
c
      implicit real*8 (a-h,o-z)
      include 'afrt_rt2.cmn'
c
c**********************************************************************
c
      m1=jpass-2
      m2=jpass-1
      m3=jpass
c
c     apply geo. series correction to fluxes and radiances leaving aircraft
c     level lvlcrft1
c
      read(73,rec=m3)ftmp
      read(73,rec=m2)ftmpa
      read(73,rec=m1)ftmpb
c
      call fluxlvl(ftmpb,crftd1(1),0)
      call fluxlvl(ftmpb,crftu1(1),1)
      call fluxlvl(ftmpa,crftd1(2),0)
      call fluxlvl(ftmpa,crftu1(2),1)
      call fluxlvl(ftmp,crftd1(3),0)
      call fluxlvl(ftmp,crftu1(3),1)
c
      call geom(crftd1(1),crftd1(2),crftd1(3),crr1,crftd1(4))
      call geom(crftu1(1),crftu1(2),crftu1(3),crr1,crftu1(4))
c
      do i=1,(nx-1)
         do j=1,jpart
            do k=1,4
               if(ftmp(k,i,j).le.1.0d-15)then
                  fiolvl1(k,i,j)=ftmp(k,i,j)
               else
                  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
     1                      crftrd1,fiolvl1(k,i,j))
               endif
            enddo
         enddo
      enddo
c
      do i=nx,nmum1
         do j=1,jpart
            do k=1,4
               if(ftmp(k,i,j).le.1.0d-15)then
                  fiolvl1(k,i,j)=ftmp(k,i,j)
               else
                  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
     1                      crftru1,fiolvl1(k,i,j))
               endif
            enddo
         enddo
      enddo
c
      read(74,rec=m3)ftmp
      read(74,rec=m2)ftmpa
      read(74,rec=m1)ftmpb
c
c
      call fluxlvl(ftmpb,crftd2(1),0)
      call fluxlvl(ftmpb,crftu2(1),1)
      call fluxlvl(ftmpa,crftd2(2),0)
      call fluxlvl(ftmpa,crftu2(2),1)
      call fluxlvl(ftmp,crftd2(3),0)
      call fluxlvl(ftmp,crftu2(3),1)
c
      call geom(crftd2(1),crftd2(2),crftd2(3),crr2,crftd2(4))
      call geom(crftu2(1),crftu2(2),crftu2(3),crr2,crftu2(4))
c
      do i=1,(nx-1)
         do j=1,jpart
            do k=1,4
               if(ftmp(k,i,j).le.1.0d-15)then
                  fiolvl2(k,i,j)=ftmp(k,i,j)
               else
                  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
     1                      crftrd2,fiolvl2(k,i,j))
               endif
            enddo
         enddo
      enddo
c
      do i=nx,nmum1
         do j=1,jpart
            do k=1,4
               if(ftmp(k,i,j).le.1.0d-15)then
                  fiolvl2(k,i,j)=ftmp(k,i,j)
               else
                  call geom(ftmpb(k,i,j),ftmpa(k,i,j),ftmp(k,i,j),
     1                      crftru2,fiolvl2(k,i,j))
               endif
            enddo
         enddo
      enddo
c
c     interpolate the fluxes and radiances at the aircraft height
c
      call xntpln(pcrft,pl(lvlcrft),pl(lvlcrft+1),crftd1(4),
     1            crftd2(4),crftfd)
      call xntpln(pcrft,pl(lvlcrft),pl(lvlcrft+1),crftu1(4),
     1            crftu2(4),crftfu)
c
      do i=1,nmum1
         do j=1,jpart
            do k=1,4
            call xntpln(pcrft,pl(lvlcrft),pl(lvlcrft+1),
     1                  fiolvl1(k,i,j),fiolvl2(k,i,j),fiocrft(k,i,j))
            enddo
         enddo
      enddo
c
c     
      if(kzz.eq.1)then
        call crftout
c
        cfdown(ksza)=crftfd*pi
        cfup(ksza)=crftfu*pi
        do i=1,(nx-1)
           do j=1,jpart
              crftzd(ksza,i,j)=fiocrft(1,i,j)+fiocrft(2,i,j)
           enddo
        enddo
        do i=nx,nmum1
           m=nmum1-i+1
           do j=1,jpart
              crftzu(ksza,m,j)=fiocrft(1,i,j)+fiocrft(2,i,j)
           enddo
        enddo
c
      endif
c
      if(kzz.eq.2)then
        call crftout
        ef=amuo*efactb(nolyr+1)
        ftot=(gz+ef)
          do i=1,(nx-1)
             do j=1,jpart                                                  
                cttdn(i,j)=(fiocrft(1,i,j)+fiocrft(2,i,j))
             enddo
          enddo
          do i=nx,nmum1
             m=(nmum1-i+1)
             do j=1,jpart
                cttup(m,j)=(fiocrft(1,i,j)+fiocrft(2,i,j))
             enddo
          enddo
          do i=1,(nx-1)
             do j=1,jpart
                crfttup(ksza,i,j)=cttup(i,j)*ftot
                crfttdn(ksza,i,j)=cttdn(i,j)*ftot
             enddo
          enddo
      endif
c
      if(nsza.gt.1)then
        ef=amuo*efactb(nolyr+1)
        ftot=(gz+ef)
          do i=1,(nx-1)
             do j=1,jpart
                crfttup(ksza,i,j)=cttup(i,j)*ftot
                crfttdn(ksza,i,j)=cttdn(i,j)*ftot
             enddo
          enddo
      endif
c
      return
      end
c                                                                       
c**********************************************************************