NASA Ocean Color

ocssw V2022

 c***********************************************************************
 c                                                                       
 c                                                                       
 c     radiative transfer program (part 2)                               
 c                                                                       
 c
  
       SUBROUTINE af_rt2_process(odir,ailm,aisd,airh,aitau,aiwnd,airef,
      1   aitrans,aiset,airh1,airh2,ailm1,ailm2,aisd1,aisd2,aitau1,aitau2,
      2   aithe01,aithe02,aiwnd1,aiwnd2,anx,anthe0,anwl,anrh,ansd,aiww,akrhum,aiprin,
      3   aipol,anpass1,anpass2,aicrft,aiactflx,aisurf,aiglint,aiocn,aifoam,
      4   aiwatr,aiconc,adtheta,adphi,ahcrft,arx,athe0in,awwl,aalbwat,
      5   aifunc,amfunc,arefr,arefi,armin,armax,adelr,adelx,arg,asig,anpar,
      6   ar11,ar22,ar33,ar44,areff,aveff,accn,absr,
      7   asalb,aasf,aqscat,aqext,at,athd,
      8   axr,axi,av,athcel,aphcel,atxx,apti,awvlth,apsrfc,arrho,
      9   axozn,atautot,adeltau,atrp,atmp,atap,atcar,atwat,atozn,
      *   ahtlvl,applvl,adtrr,adtmm,adtaa,adtot,ahtdv,apdv,
      *   ataur,ataum,ataua,aifc,anmodl,anolyr,aipsudo,abfr,
      *   otma,otmb,otmc,otmfd,otmfu,otms,otmg,otmh,otmp,otmq,otmt,otmpp,otmqq,
      *   otmrr,otmss,otransm,otmcfd,otmcfu,otmf1,otmf2,oxzeroz,oxzerod,otupz,
      *   otdwnz)
 c
 c***********************************************************************
 c.....include the common and declaration statemnets.....................
       implicit real*8 (a-h,o-z)
       include 'afrt_rt2.cmn'
 c
       integer*4 ailm,airh,aisd,aitau,aiwnd,aifc,anmodl,anolyr,
      1          aiww(nwnd),akrhum(nw),aifunc,amfunc,aipsudo
       integer*4 airef,aiprin,aipol,anpass1,anpass2,ailm1,ailm2,aisd1,aisd2,
      1          aitau1,aitau2,aithe01,aithe02,aiwind,aifoam,aiwatr,aiconc,
      2          anx,anthe0,aisza,aksza,aicrft,aiactflx,aisurf,aiglint,aiocn,
      3          aiwnd1,aiwnd2,aitrans,anwl,anrh,ansd,aiset,airh1,airh2
       real*8    ar11,ar22,ar33,ar44,areff,aveff,accn,absr,asalb,aasf,
      1          arefr(nmd),arefi(nmd),armin(nmd),armax(nmd),
      2          adelr(nmd),adelx(nmd),arg(nmd),asig(nmd),anpar(nmd),
      3          aqscat,aqext,at(ntf,nstk),athd(ntf),atxx(ntrx,nph,nth,nsz),
      4          apti(npti,nph,nth,nsz),awvlth,apsrfc,arrho,axozn,
      5          atautot,adeltau,atrp,atmp,atap,atcar,atwat,atozn,
      6          ahtlvl(nlyr),applvl(nlyr),adtrr(nlyr),adtmm(nlyr),
      7          adtaa(nlyr),adtot(nlyr),ahtdv(nlyr),apdv(nlyr),
      8          ataur(nlyr),ataum(nlyr),ataua(nlyr)
       real*8 axr,axi,av,athcel,aphcel,xxx,zzz
       real*8 adtheta,adphi,ahcrft,totl(1000),dtotl(1000)
       real*8 arx(nph),athe0in(nsz),awwl(nw),aalbwat(nwnd)
       real*4 abfr(nlyr)
       real*8 otma(nsz),otmb(nsz),otmc(nsz),otmfd(nsz),otmfu(nsz),otms(nsz),
      1  otmg(nsz),otmh(nsz),otmp(nsz),otmq(nsz),otmt(nsz),otmpp(nsz),
      2  otmqq(nsz),otmrr(nsz),otmss(nsz),otransm(nth),otmcfd(nsz),otmcfu(nsz),
      3  otmf1(nlyr,nsz),otmf2(nlyr),oxzeroz(nstk,nph,nth,nsz),
      4  oxzerod(nstk,nph,nth,nsz),otupz(nstk,nph,nth,nsz),
      5  otdwnz(nstk,nph,nth,nsz),oradocn(nph,nth,nsz)
 c     5  ocrfttup(nph,nth,nsz),
 c     6  ocrftzu(nph,nth,nsz),ocrfttdn(nph,nth,nsz),
 c     7  ocrftzd(nph,nth,nsz),osurfzu(nph,nth,nsz),
 c     8  oradsky(nph,nth,nsz),oraddir(nph,nth,nsz)
       real*8 glint_tmp(4,2*nsz,nph)
       real*4 ee(2),qspp(2*nsz)
       character*255 odir,xname1,xname2
       character*1 ciconc
       character*2 ciwind
       character*2 citau,crh,cset
       character*2 cisd,cilmd,cwind
       character*4 cilm
       logical OK
  
       otma(:)=0.0
       otmb(:)=0.0
       otmc(:)=0.0
       otmfd(:)=0.0
       otmfu(:)=0.0
       otms(:)=0.0
       otmg(:)=0.0
       otmh(:)=0.0
       otmp(:)=0.0
       otmq(:)=0.0
       otmt(:)=0.0
       otmpp(:)=0.0
       otmqq(:)=0.0
       otmrr(:)=0.0
       otmss(:)=0.0
       otransm(:)=0.0
       otmcfd(:)=0.0
       otmcfu(:)=0.0
       otmf1(:,:)=0.0
       otmf2(:)=0.0
       oxzeroz(:,:,:,:)=0.0
       oxzerod(:,:,:,:)=0.0
       oradocn(:,:,:)=0.0
       otupz(:,:,:,:)=0.0
       otdwnz(:,:,:,:)=0.0
 c      ocrfttup(:,:,:)=0.0
 c      ocrftzu(:,:,:)=0.0
 c      ocrfttdn(:,:,:)=0.0
 c      ocrftzd(:,:,:)=0.0
 c      osurfzu(:,:,:)=0.0
 c      oradsky(:,:,:)=0.0
 c      oraddir(:,:,:)=0.0
 c***********************************************************************
 c                                                                       
 c
 c     get the upper and lower indices for wavelength, size dist. and 
 c     optical thickness.  also, flags for wind speed, foam, water leaving
 c     radiances and chlorophyll conc.
 c
       izia=1
 c      iglint=1         !subtract the glint radiance
       iocn=1           !wind speed in sigma of slope dist.
 c      call inusr
  
       ilm = ailm
       isd = aisd
       irh = airh
       itau = aitau
       iwnd = aiwnd
       nolyr = anolyr
       nmodl = anmodl
       iref = airef
       itrans = aitrans
       iset = aiset
       irh1 = airh1
       irh2 = airh2
       ilm1 = ailm1
       ilm2 = ailm2
       isd1 = aisd1
       isd2 = aisd2
       itau1 = aitau1
       itau2 = aitau2
       ithe01 = aithe01
       ithe02 = aithe02
       iwnd1 = aiwnd1
       iwnd2 = aiwnd2
       nx = anx
       nthe0 = anthe0
       nwl = anwl
       nrh = anrh
       iww(:) = aiww(:)
       krhum(:) = akrhum(:)
       iprin = aiprin
       ipol = aipol
       npass1 = anpass1
       npass2 = anpass2
       icrft = aicrft
       iactflx = aiactflx
       isurf = aisurf
       iglint = aiglint
       iocn = aiocn
       ifoam = aifoam
       iwatr = aiwatr
       iconc = aiconc
       dtheta = adtheta
       dphi = adphi
       hcrft = ahcrft
       rx(:) = arx(:)
       the0in(:) = athe0in(:)
       wwl(:) = awwl(:)
       albwat(:) = aalbwat(:)
       ifunc = aifunc
       mfunc = amfunc
       xrw = axr
       xiw = axi
       vz = av
       mtha = athcel
       mphi = aphcel
       r11 = ar11
       r22 = ar22
       r33 = ar33
       r44 = ar44
       reff = areff
       veff = aveff
       ccn = accn
       bsr = absr
       salb = asalb
       asf = aasf
       qs = aqscat
       qt = aqext
       t(:,:) = at(:,:)
       thd(:) = athd(:)
       txx(:,:,:,:) = atxx(:,:,:,:)
 c      pti(:,:,:,:) = apti(:,:,:,:)
       wvlth = awvlth
       psrfc = apsrfc
       rho = arrho
       xozn = axozn
       tautot = atautot
       deltau = adeltau
       nolyr = anolyr
       tr = atrp
       tm = atmp
       ta = atap
       tcar = atcar
       twat = atwat
       tozn = atozn
       ifc = aifc
       ht(:) = ahtlvl(:)
       pl(:) = applvl(:)
       dtrr(:) = adtrr(:)
       dtmm(:) = adtmm(:)
       dtaa(:) = adtaa(:)
       dtot(:) = adtot(:)
       htp(:) = ahtdv(:)
       ppo(:) = apdv(:)
       taur(:) = ataur(:)
       taum(:) = ataum(:)
       tauabs(:) = ataua(:)
       ipsudo = aipsudo
       bfr1(:) = abfr(:)
       do i=1,1915
          ebfr1(i)=-777.0
          ebfr2(i)=-777.0
          ebfr3(i)=-777.0
       enddo
       if(iref.lt.2)then
         iwnd1=1
         iwnd2=1
       endif
       do i=1,nlyr
          bfr1(i)=-999.9
          bfr2(i)=-999.9
          bfr3(i)=-999.9
       enddo
 c      bfr1(1)=xyear
 c      bfr1(2)=xmonth
 c      bfr1(3)=xday
 c      bfr1(4)=-777.0
       bfr1(5)=wvlth*1.0d4
       bfr1(6)=arefr(1)
       bfr1(7)=arefi(1)
       bfr1(8)=arg(1)
       bfr1(9)=asig(1)
       bfr1(10)=armin(1)
       bfr1(11)=armax(1)
       bfr1(12)=adelx(1)
       bfr1(13)=reff
       bfr1(14)=r11
       bfr1(15)=r22
       bfr1(16)=r33
       bfr1(17)=r44
       bfr1(18)=salb
       bfr1(19)=asf
       bfr1(20)=qs
       bfr1(21)=qt
       bfr1(22)=av
       bfr1(23)=axr
       bfr1(24)=axi
       bfr1(25)=tr
       bfr1(26)=tm
       bfr1(27)=ta
       bfr1(28)=twat
       bfr1(29)=tautot
       bfr1(30)=rho
       bfr1(31)=ccn
       bfr1(32)=bsr
       bfr1(33)=float(ipol)
       bfr1(34)=float(ipsudo)
       bfr1(41)=dfloat(ifoam)
       bfr1(42)=dfloat(iwatr)
 c     bfr1(43)=chl(iconc)
       bfr1(44)=albwat(ilm)
       bfr1(45)=dfloat(iref)
       bfr1(46)=psrfc
       bfr1(47)=dfloat(ifc)
       bfr1(48)=dfloat(ifunc)
       bfr1(49)=dfloat(mfunc)
  
       bfr1(58)=anpar(1)
       bfr1(59)=arg(2)
       bfr1(60)=asig(2)
       bfr1(61)=anpar(2)
       bfr1(62)=adelx(2)
       bfr1(63)=arefr(2)
       bfr1(64)=arefi(2)
       bfr1(65)=armin(2)
       bfr1(66)=armax(2)
       bfr1(67)=arg(3)
       bfr1(68)=asig(3)
       bfr1(69)=anpar(3)
       bfr1(70)=adelx(3)
       bfr1(71)=arefr(3)
       bfr1(72)=arefi(3)
       bfr1(73)=armin(3)
       bfr1(74)=armax(3)
       bfr1(76)=itrans
 c
 c      write(*,*) ilm, isd, irh, itau, iwnd
 c
       len=index(odir,' ')-1
       call convtc(idnint(awwl(ilm)*1.0d3+0.01),4,cilm)
 c      write(*,*) awwl(ilm),cilm
       iisd = mod(isd-1,ansd/anrh) + 1
       call convtc(iisd,2,cisd)
       call convtc(itau,2,citau)
       call convtc(iwnd-1,2,ciwind)
 c     call convtc(iconc,1,ciconc)
 c      call convtc(iww(iwind),2,cwind)
       call convtc(krhum(isd),2,crh)
       call convtc(iset,2,cset)    !iset is passed through the common block zeroa
 c
       if(iref.eq.1)ciwind='00'
       if(iref.eq.0)ciwind='99'
       if(iset.eq.0)crh='00'  !iset is read in sub. inusr and passed through common zeroa
 c
       xname1='rt2_wl'//cilm//'x'//ciwind
       xname2='sd'//cisd//'rh'//crh//'ta'//citau//'_set'//cset
       nm1=index(xname1,' ')-1
       nm2=index(xname2,' ')-1
       open(3,file=
      1     odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'dn.dat',
      2     status='unknown')
       open(4,file=
      1     odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'up.dat',
      2     status='unknown')
       open(24,file=
      1 odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'.dat',
      2 access='direct',recl=1915*4,
      3 form='unformatted',status='unknown',convert='big_endian')
 c
       if(icrft.eq.1)then
           open(13,file=
      1         odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'crftdn.dat',
      2         status='unknown')
           open(14,file=
      1         odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'crftup.dat',
      2         status='unknown')
            open(15,file=
      1     odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'crft.dat',
      2     access='direct',recl=1915*4,
      3     form='unformatted',status='unknown',convert='big_endian')
       endif
 c
       if(iactflx.eq.1)then
           open(30,file=
      1         odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'flx.dat',
      2         status='unknown')
       endif
 c
       if(isurf.eq.1)then
       open(16,file=
      1     odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'surfup.dat',
      2     status='unknown')
         if(airef.eq.2)then
            open(41,file=
      1     odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'dirup.dat',
      2     status='unknown')
            open(42,file=
      1     odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'ocnup.dat',
      2     status='unknown')
            open(43,file=
      1     odir(1:len)//'/'//xname1(1:nm1)//xname2(1:nm2)//'skyup.dat',
      2     status='unknown')
         endif
       endif
  
       open(53,access='direct',
 c     1     form='unformatted',status='scratch',recl=18400*96)
      1     form='unformatted',status='scratch',recl=18400*4)
       open(54,access='direct',
      1     form='unformatted',status='scratch',recl=18400*4)
       open(55,access='direct',
      1     form='unformatted',status='scratch',recl=18400*4)
       open(64,access='direct',
      1     form='unformatted',status='scratch',recl=18400*4)
       open(65,access='direct',
      1     form='unformatted',status='scratch',recl=18400*4)
       open(71,access='direct',
      1     form='unformatted',status='scratch',recl=18400*4)
       open(72,access='direct',
      1     form='unformatted',status='scratch',recl=18400*4)
 c
       if(icrft.eq.1)then
           open(73,access='direct',
      1     form='unformatted',status='scratch',recl=18400*4)
           open(74,access='direct',
      1     form='unformatted',status='scratch',recl=18400*4)
       endif
  
       if(icrft.eq.1)then
          call crftlvl
       endif
       xlam=wvlth                                                        
       alw=albwat(ilm)
  
 c     loop over solar zenith angle                                      
       pi=dacos(-1.0d0)
       conv=pi/180.0d0
       nmum1=2*nx-2
       nophi=360.0d0/dphi
       jpart=nophi/2+1
       ddphi=dphi*conv
       const=wvlth**2/(4.0*pi**2*qs)
       qsqt=qs/qt
       conr=3.0d0/(8.0d0*pi)
       nsza=0                                                            
       do ksza=ithe01,ithe02,1
           isza=ksza-ithe01+1
           msza(isza)=ksza
           nsza=nsza+1
           calb=0.0d0
           jpass=1
           do i=1,nmum1
              c(i)=1.
           enddo
           do ij=1,2*nmum1
              do ik=1,4
                 pp(ij,ik)=0.0d0
                 qq(ij,ik)=0.0d0
              enddo
           enddo
           do i=1,2
              ei(i)=0.50d0
              ei(i+2)=0.0d0
           enddo
           do i=1,nx
              j=2*nx-i
              rmu(i)=rx(i)
              rmu(j)=180.0-rx(i)
           enddo
           rmuo=the0in(ksza)
           do i=1,nmum1+1
              cmu(i)=dcos(rmu(i)*conv)
           enddo
           do i=1,nmum1
              xmu = (rmu(i)+rmu(i+1))/2.0d0
              the(i)=xmu
              if(i .gt. nx-1)then
                 the(i)=the(nmum1-i+1)
              endif
              if(dabs(xmu-rmuo).le.1.0d-3)then
                 amuo=dcos(xmu*conv)
                 kkx=i
              endif
              cosmu(i)=dcos(xmu*conv)
              sinmu(i)=dsin(xmu*conv)
           enddo
           do l=1,nophi+1
               phi(l)=(l-1.0d0)*dphi
               jphi(l)=phi(l)+0.001
           enddo
           do i=1,jpart
               th=(i-1)*dphi*conv
               costh(i)=dcos(th)
               sinth(i)=dsin(th)
           enddo
           do i=1,nmum1
               dcmusq(i)=(cmu(i)**2-cmu(i+1)**2)/2.d0
               dcmu(i) = cmu(i) - cmu(i+1)
           enddo
           if(isza.eq.1)then
              call hdrmds(ithe01,ithe02,ebfr1)
           endif
 c         if ipsudo=1 then determine optical path length for
 c         spherical atmosphere
           if(ipsudo.eq.1)then
              call spathz(amuo,htp,taur,taum,tauabs,totsp,nmodl)
           endif
 c         determine an average value of phase matrix in the forward/
 c         backward direction
           if(ifc.eq.1)then
              call hump (const,t,pp,nmum1,dphi+0.001d0,rmu,thd,0,nmum1+1)
              call hump (const,t,qq,nmum1,dphi+0.001d0,rmu,thd,1,nmum1+1)
           endif
           if(iref.eq.2)then
 c             read(19)xrw,xiw,vz,mtha,mphi
              call anglw
           endif
 c      compute the attenuation parameters
 c      determine the total optical thickness at every level in the atmosphere
           taupl(1)=0.0d0
           do i=1,nolyr
              taupl(i+1)=taupl(i)+dtot(i)
           enddo
           totl(1)=1.0d-10
           efactb(1)=1.0d0
           if(ipsudo.eq.1)then
               do i=2,(nolyr+1)
                  call spline(pl(i),ppo,totsp,nmodl,1,totl(i),1,1,vl,vu,e,u)
               enddo
               do i=1,nolyr
                  dtotl(i)=totl(i+1)-totl(i)
               enddo
 c      compute the solar attenuation  upto the middle as well as
 c      bottom of the layer
               do i=1,nolyr
                   efact(i)=dexp(-(0.5d0*dtotl(i)+totl(i)))
                   efactb(i+1)=dexp(-totl(i+1))
               enddo
               eo(1)=0.5d0*dexp(-totl(nolyr+1))
               eo(2)=0.5d0*dexp(-totl(nolyr+1))
           else
 c      compute the solar attenuation up to the middle as well as
 c      bottom of the layer (plane parallel case)
               do i=1,nolyr
                   totl(i+1)=totl(i)+dtot(i)
                   efact(i)=dexp(-(0.50d0*dtot(i)+taupl(i))/amuo)
                   efactb(i+1)=dexp(-taupl(i+1)/amuo)
               enddo
               eo(1)=0.5d0*dexp(-taupl(nolyr+1)/amuo)
               eo(2)=0.5d0*dexp(-taupl(nolyr+1)/amuo)
           endif
           do i=1,nolyr
               do j=1,nmum1
                  emdtm(i,j)=dexp(-dtot(i)/dabs(cosmu(j)))
                  emtm(i,j)=dexp(-(totl(i+1)-0.5d0*dtot(i))/dabs(cosmu(j)))
               enddo
           enddo
           do i=1,nolyr+1
               do j=1,nx-1
                  atnflx(i,j)=dexp(-totl(i)/dabs(cosmu(j)))
               enddo
           enddo
 c      compute the scattering phase matrices (rayleigh/aerosol)
 c      compute gamma for molecular depolarization correction
           if(ipol.eq.1)then
               gam=rho/(2.0-rho)
               agm=(1.0-gam)/(1+2.0*gam)
               bgm=gam/(1.0+2.0*gam)
               cgm=(1.0-3.0*gam)/(1.0+2.0*gam)
           endif
 c      compute phase matrices for first scatter
           kk=kkx
           do ii=1,nmum1
               call matrx
               do i=1,jpart
                  do k=1,32
                     pc(k,i,ii)=p(k,i)
                  enddo
               enddo
           enddo
 c      compute phase matrices for second scatter
           qsp(:)=0.
           do ii=1,nmum1
               do kk=1,nmum1
                   call matrx
                   do i=1,jpart
                      do k=1,32
                         ppin(k,i,ii,kk)=p(k,i)
                      enddo
                   enddo
               enddo
               if(ifc.ne.0) then
                   ee(1) = 0.5
                   ee(2) = 0.5
                   do k=1,(nx-1)
                       i=ii
                       qspp(i)=0.
                       do m=1,jpart
                           xfot=const*(ee(1)*(ppin(1,m,i,k)+ppin(5,m,i,k))+
      1                                ee(2)*(ppin(2,m,i,k)+ppin(6,m,i,k)))
                           if(m.eq.1.or.m.eq.jpart) then
                              qspp(i)=qspp(i)+xfot
                           else
                              qspp(i)=qspp(i)+2.*xfot
                           endif
                       enddo
                       qsp(k)=qsp(k)+qspp(i)*dcmu(i)*ddphi
                   enddo
               endif
           enddo
           if(ifc .ne. 0) then
               do i=1,(nx-1)
                   c(i)=1.d0/qsp(i)
                   c(nmum1+1-i)=c(i)
               enddo
           endif
 c      begin radiative transfer calculations
           ibgn=1
           iend=1
           if(nsza.eq.1 .and. (iref.eq.0 .or. itrans.eq.1) )then
              iend=2
           endif
 c      illumination from the top of the atmosphere(kzz=1)
 c      illumination from the bottom of the atmosphere(kzz=2)
           do kzz=ibgn,iend,1
              jpass=1
              nump=npass1
              do k=1,2
                 do i=1,nx-1
                    do j=1,jpart
                       d1px(k,i,j)=0.0d0
                       d2px(k,i,j)=0.0d0
                    enddo
                 enddo
              enddo
              if(nsza.eq.1 .and. (iref.eq.0 .or. itrans.eq.1) )then
                  nump=npass2
              endif
              if(kzz.eq.1)then
                  call single
                  minitr=4
              endif
              if(kzz.eq.2 .and. iref.eq.0)then
                  call grefl
                  call snglup
                  minitr=4
              endif
              if(kzz.eq.2 .and. itrans.eq.1)then
                  call focn_below
                  call snglup
                  minitr=4
              endif
              call getrad
              do ka=1,nump
 c               initialize the disk units
                 kdx=ka-(ka/2)*2
                 if(kdx.eq.1)then
                   irad=64
                   iwrt=65
                 else
                   irad=65
                   iwrt=64
                 endif
                 if(kzz.eq.1)then
                   call multp1d
                 elseif(kzz.eq.2 .and. iref.eq.0)then
                   call multp2d
                 elseif(kzz.eq.2 .and. itrans.eq.1)then
                   call multp2d_trans
                 endif
                 jpass=jpass+1
                 call getrad
                 call contst
                 call fiotb
                 if(iactflx.eq.1)then
                    call actflx
                 endif
                 if(jpass.ge.minitr)then
                    if(d3.le.0.1 .or. jpass.ge.20) exit
                 endif
              enddo
              if(kzz.eq.1 .and. iglint.eq.1)then
                  do k=1,4
                      do i=nx,nmum1
                         do j=1,jpart
                            glint_tmp(k,i,j)=fglint(k,i,j)*
      1                      dexp(-tautot/dabs(cosmu(i)))
                         enddo
                      enddo
                  enddo
 c                if(kzz .eq.2)then
 c                do i=nx,nmum1
 c                    call radnce(pi,conv,cosmu,the,fio,i,jpart,jphi)
 c                enddo
 c                endif
              endif
              call geocor
              if(icrft.eq.1)then
                 call crftgcr
              endif
              if(iactflx.eq.1)then
                 call actfgrc
              endif
              if(isurf.eq.1)then
                 call surfgcr
              endif
 c      illumination from bottom is done only once
              if(kzz.eq.2) exit
           enddo
       enddo
       lsza=bfr1(35)+0.001
       do i=1,lsza,1
         m=msza(i)
         otma(i)=the0in(m)
         otmb(i)=fdirc(m)
         otmc(i)=sbarz(m)
         otmfd(i)=fdown(m)
         otmfu(i)=fup(m)
         otms(i)=oalb(m)
         otmg(i)=albtdr(m)
         otmh(i)=albtdf(m)
         otmp(i)=albtrf(m)
         otmq(i)=albwl(m)
         otmpp(i)=otmq(i)/(otmb(i)+otmfd(i))
         otmqq(i)=otms(i)-otmpp(i)
         otmrr(i)=albrdr(m)
         otmss(i)=albrdf(m)
         do is=1,jpart
           do ir=1,(nx-1)
             do ik=1,nstk
                oxzerod(ik,is,ir,m) = xzerod(ik,m,ir,is)
                oxzeroz(ik,is,ir,m) = xzeroz(ik,m,ir,is)
             enddo
           enddo
         enddo
       enddo
       m=msza(1)
       do ir=1,(nx-1)
          otransm(ir)=xzero_up(m,ir,1)/xzero_btm(m,ir,1)
       enddo
  
 c     create output datasets for upwelling and downwelling radiances    
 c     leaving the top and bottom of the atmosphere                      
       if((iref.eq.1 .or. iref.eq.2) .and. itrans.eq.1)then
          call outdt_trans(otransm,oxzeroz)
       endif
       if(iref.eq.1 .or. iref.eq.2 .or. iref.eq.3)then
          call outdty(oxzeroz,oxzerod)
          if(icrft.eq.1)then
 c            call outcrfty(otmcfd,otmcfu,ocrftzu,ocrftzd)
          endif
          if(iactflx.eq.1)then
 c            call outactfy(otmf1)
          endif
          if(isurf.eq.1)then
             call outsurfy(osurfzu)
             if(iref.eq.2)then
 c             call outsurfdir(oraddir)
                 call outsurfocn(oradocn)
 c             call outsurfsky(oradsky)
             endif
          endif
       endif
 c
       if(iref.eq.0 .and.itrans.eq.0)then
          call outdtz(otupz,oxzeroz,otdwnz,oxzerod)
          if(icrft.eq.1)then
 c            write(*,*)'ready to call outcrftz'
 c            call outcrftz(otmcfd,otmcfu,ocrfttup,ocrftzu,ocrfttdn,ocrftzd)
          endif
          if(iactflx.eq.1)then
 c            call outactfz(otmf1,otmf2)
          endif
       endif
 c     close the temp files
 c      close (18)
 c      close (19)
       INQUIRE( unit=53, opened=ok )
       IF ( ok ) close (53)
       INQUIRE( unit=54, opened=ok )
       IF ( ok ) close (54)
       INQUIRE( unit=55, opened=ok )
       IF ( ok ) close (55)
       INQUIRE( unit=64, opened=ok )
       IF ( ok ) close (64)
       INQUIRE( unit=65, opened=ok )
       IF ( ok ) close (65)
       INQUIRE( unit=71, opened=ok )
       IF ( ok ) close (71)
       INQUIRE( unit=72, opened=ok )
       IF ( ok ) close (72)
       INQUIRE( unit=73, opened=ok )
       IF ( ok ) close (73)
       INQUIRE( unit=74, opened=ok )
       IF ( ok ) close (74)
       INQUIRE( unit=3, opened=ok )
       IF ( ok ) close (3)
       INQUIRE( unit=4, opened=ok )
       IF ( ok ) close (4)
       INQUIRE( unit=6, opened=ok )
       IF ( ok ) close (6)
       INQUIRE( unit=13, opened=ok )
       IF ( ok ) close (13)
       INQUIRE( unit=14, opened=ok )
       IF ( ok ) close (14)
       INQUIRE( unit=15, opened=ok )
       IF ( ok ) close (15)
       INQUIRE( unit=16, opened=ok )
       IF ( ok ) close (16)
       INQUIRE( unit=24, opened=ok )
       IF ( ok ) close (24)
       INQUIRE( unit=30, opened=ok )
       IF ( ok ) close (30)
 c********************************************************************** 
 c                   format statements                                   
 355    format( t10,'fresnel reflection (by a rough surface)',1x,
      1 'at the lower boundary '/ t10,'refractive index',t45,'=',1pe15.5,
      2 '-',1pe15.5,'i' / t10,'velocity',t45,'=', 1pe15.5,'meter/sec'/)
 c***********************************************************************
       return
       end                                                               
 c**********************************************************************

index

an array had not been initialized Several spelling and grammar corrections were which is read from the appropriate MCF the above metadata values were hard coded A problem calculating the average background DN for SWIR bands when the moon is in the space view port was corrected The new algorithm used to calculate the average background DN for all reflective bands when the moon is in the space view port is now the same as the algorithm employed by the thermal bands For non SWIR changes in the averages are typically less than Also for non SWIR the black body DNs remain a backup in case the SV DNs are not available For SWIR the changes in computed averages were larger because the old which used the black body suffered from contamination by the micron leak As a consequence of the if SV DNs are not available for the SWIR the EV pixels will not be the granule time is used to identify the appropriate tables within the set given for one LUT the first two or last two tables respectively will be used for the interpolation If there is only one LUT in the set of it will be treated as a constant LUT The manner in which Earth View data is checked for saturation was changed Previously the raw Earth View DNs and Space View DNs were checked against the lookup table values contained in the table dn_sat The change made is to check the raw Earth and Space View DNs to be sure they are less than the maximum saturation value and to check the Space View subtracted Earth View dns against a set of values contained in the new lookup table dn_sat_ev The metadata configuration and ASSOCIATEDINSTRUMENTSHORTNAME from the MOD02HKM product The same metatdata with extensions and were removed from the MOD021KM and MOD02OBC products ASSOCIATEDSENSORSHORTNAME was set to MODIS in all products These changes are reflected in new File Specification which users may consult for exact the pow functions were eliminated in Emissive_Cal and Emissive bands replaced by more efficient code Other calculations throughout the code were also made more efficient Aside from a few round off there was no difference to the product The CPU time decreased by about for a day case and for a night case A minor bug in calculating the uncertainty index for emissive bands was corrected The frame index(0-based) was previously being used the frame number(1-based) should have been used. There were only a few minor changes to the uncertainty index(maximum of 1 digit). 3. Some inefficient arrays(Sigma_RVS_norm_sq) were eliminated and some code lines in Preprocess_L1A_Data were moved into Process_OBCEng_Emiss. There were no changes to the product. Required RAM was reduced by 20 MB. Now

actflx

subroutine actflx

Definition: actflx.f:2

multp2d_trans

subroutine multp2d_trans

Definition: multp2d_trans.f:2

hump

subroutine hump(const, t, tp, nm, lp, rmu, thd, ixy, nmu)

Definition: hump.f:2

focn_below

subroutine focn_below

Definition: focn_below.f:2

fiotb

subroutine fiotb

Definition: fiotb.f:2

anglw

subroutine anglw

Definition: anglw.f:2

grefl

subroutine grefl

Definition: grefl.f:2

ccn

subroutine ccn(ifunc, irgm)

Definition: phs.f:940

snglup

subroutine snglup

Definition: snglup.f:2

spline

subroutine spline(s, x, y, n, in, t, il, iu, vl, vu, e, u)

Definition: phs.f:1348

spathz

subroutine spathz(amu0, htp, taur, taum, taua, totsp, nmodl)

Definition: spathz.f:2

hdrmds

subroutine hdrmds(nthe01, nthe02, ebfr1)

Definition: hdrmds.f:2

real

#define real

Definition: DbAlgOcean.cpp:26

const

subroutine const(NGAUSS, NMAX, MMAX, P, X, W, AN, ANN, S, SS, NP, EPS)

Definition: ampld.lp.f:924

multp2d

subroutine multp2d

Definition: multp2d.f:2

contst

subroutine contst

Definition: contst.f:2

surfgcr

subroutine surfgcr

Definition: surfgcr.f:2

outdtz

subroutine outdtz(otupz, oxzeroz, otdwnz, oxzerod)

Definition: outdtz.f:2

outsurfy

subroutine outsurfy(osurfzu)

Definition: outsurfy.f:2

geocor

subroutine geocor

Definition: geocor.f:2

multp1d

subroutine multp1d

Definition: multp1d.f:2

matrx

subroutine matrx

Definition: matrx.f:2

outdty

subroutine outdty(oxzeroz, oxzerod)

Definition: outdty.f:2

outsurfocn

subroutine outsurfocn(oradocn)

Definition: outsurfocn.f:2

crftgcr

subroutine crftgcr

Definition: crftgcr.f:2

#define pi

Definition: vincenty.c:23

float ei(float x)

single

subroutine single

Definition: single.f:2

outdt_trans

subroutine outdt_trans(transm, oxzeroz)

Definition: outdt_trans.f:2

crftlvl

subroutine crftlvl

Definition: crftlvl.f:2

getrad

subroutine getrad

Definition: getrad.f:2

convtc

subroutine convtc(num, nchar, loc)

Definition: ocn.f:156

actfgrc

subroutine actfgrc

Definition: actfgrc.f:2

af_rt2_process

subroutine af_rt2_process(odir, ailm, aisd, airh, aitau, aiwnd, airef, aitrans, aiset, airh1, airh2, ailm1, ailm2, aisd1, aisd2, aitau1, aitau2 aithe01, aithe02, aiwnd1, aiwnd2, anx, anthe0, anwl, anrh, ansd, aiww, ak aipol, anpass1, anpass2, aicrft, aiactflx, aisurf, aiglint, aiocn, aifo aiwatr, aiconc, adtheta, adphi, ahcrft, arx, athe0in, awwl, aalbwat, aifunc, amfunc, arefr, arefi, armin, armax, adelr, adelx, arg, asig, anpa ar11, ar22, ar33, ar44, areff, aveff, accn, absr, asalb, aasf, aqscat, aqext, at, athd, axr, axi, av, athcel, aphcel, atxx, apti, awvlth, apsrfc, arrho, axozn, atautot, adeltau, atrp, atmp, atap, atcar, atwat, atozn, ahtlvl, applvl, adtrr, adtmm, adtaa, adtot, ahtdv, apdv, ataur, ataum, ataua, aifc, anmodl, anolyr, aipsudo, abfr, otma, otmb, otmc, otmfd, otmfu, otms, otmg, otmh, otmp, otmq, otmt, otmpp, otmrr, otmss, otransm, otmcfd, otmcfu, otmf1, otmf2, oxzeroz, oxzerod, o otdwnz)

Definition: afrt_rt2_process.f:23