outcrftz.f

Go to the documentation of this file.

      subroutine outcrftz(tmcfd,tmcfu,ocrfttup,ocrftzu,ocrfttdn,ocrftzd)
c
c     subroutine outcrftz creates output datasets for upwelling and        
c     downwelling diffused radiation at the aircraft height when the
c     lower surface is a lambertian reflector
c***********************************************************************
c.....include the common blocks                                         
      implicit real*8 (a-h,o-z)
      include 'afrt_rt2.cmn'
      real*8 tma(nsz),tmb(nsz),tmc(nsz),tmfd(nsz),tmfu(nsz)
      real*8 tmcfd(nsz),tmcfu(nsz),ocrfttup(nph,nth,nsz),
     1  ocrftzu(nph,nth,nsz),ocrfttdn(nph,nth,nsz),ocrftzd(nph,nth,nsz)
c***********************************************************************
c     
      lsza=bfr1(35)+0.001
      do i=1,lsza,1
         m=msza(i)
         tma(i)=the0in(m)
         tmb(i)=fdirc(m)
         tmc(i)=sbarz(m)
         tmfd(i)=fdown(m)
         tmfu(i)=fup(m)
         tmcfd(i)=cfdown(m)
         tmcfu(i)=cfup(m)
      enddo
c
      iprn=14
      call headr(iprn)
c
      do 5567 i=1,lsza
      it=msza(i)
      write(iprn,6659)
      write(iprn,6660)tma(i),pi
      write(iprn,6661)tmb(i),tmfd(i)
      write(iprn,6672)tmfu(i),tmc(i)
      write(iprn,6674)tmcfd(i),tmcfu(i)
      write(iprn,6668)
      write(iprn,6664)(the(ir),ir=1,(nx-1))
      do is=1,jpart                                                
         write(iprn,6667)jphi(is),(crftzu(it,ir,is)*pi,ir=1,(nx-1))
         do ir=1,(nx-1)
            ocrftzu(is,ir,it) = crftzu(it,ir,is)*pi
         enddo
      enddo
      write(iprn,6665)
      write(iprn,6664)(the(ir),ir=1,(nx-1))
c     do is=1,jpart
         is=1
         write(iprn,6667)jphi(is),(crfttup(it,ir,is)*pi,ir=1,(nx-1))
         do ir=1,(nx-1)
            ocrfttup(is,ir,it) = crfttup(it,ir,is)*pi
         enddo
c     enddo
5567  continue                                                          
c
      iprn=13
      call headr(iprn)
c
      do 5568 i=1,lsza
      it=msza(i)
      write(iprn,6659)
      write(iprn,6660)tma(i),pi
      write(iprn,6661)tmb(i),tmfd(i)
      write(iprn,6672)tmfu(i),tmc(i)
      write(iprn,6674)tmcfd(i),tmcfu(i)
      write(iprn,6668)
      write(iprn,6664)(the(ir),ir=1,nangl)
      do is=1,jpart                                                
        write(iprn,6667)jphi(is),(crftzd(it,ir,is)*pi,ir=1,nangl)       
         do ir=1,nangl
            ocrftzd(is,ir,it) = crftzd(it,ir,is)*pi
         enddo
      enddo
      write(iprn,6665)
      write(iprn,6664)(the(ir),ir=1,nangl)
c     do is=1,jpart
         is=1
         write(iprn,6667)jphi(is),(crfttdn(it,ir,is)*pi,ir=1,nangl)
         do ir=1,nangl
            ocrfttdn(is,ir,it) = crfttdn(it,ir,is)*pi
         enddo
c     enddo
5568  continue                                                          
c*****format statements*************************************************
c
6659  format(t1,'fluxes')
6660  format(t8,'sza',t32,f6.1,t40,'f0_top',t64,1pe12.4)
6661  format(t8,'fdir_btm',t26,1pe12.4,t40,'fdif_btm',t64,1pe12.4)
6662  format(t8,'sbar',t26,1pe12.4,t40,'f0_top',t64,1pe12.4)
6664  format('phi theta',7(2x,f5.1,3x)/3(9x,7(2x,f5.1,3x)/))
6665  format(t1,'t function'/)
6667  format(i3,6x,1p7e10.3/3(9x,1p7e10.3/))
6668  format(t1,'radiances (f0=pi)')
6672  format(t8,'fdif_up',t26,1pe12.4,t40,'sbar',t64,1pe12.4)
6674  format(t8,'acrft_fdif_dn',t26,1pe12.4,t40,'acrft_fdif_up',
     1       t64,1pe12.4)
c***********************************************************************
      return                                                            
      end                                                               
c**********************************************************************