outdty.f

Go to the documentation of this file.

      subroutine outdty
 
c***********************************************************************
c     subroutine outdt creates output datasets for upwelling and        
c     downwelling diffused radiation leaving the top and bottom of      
c     the atmosphere                                                    
c***********************************************************************
c.....include the common blocks                                         
      implicit real*8 (a-h,o-z)
      include 'common_all.cmn'                                          
      real*8 tma(25),tmb(25),tmc(25),tmfd(25),tmfu(25),tms(25)
      real*8 tmg(25),tmh(25),tmp(25),tmq(25),tmpp(25),tmqq(25)
      real*8 tmrr(25),tmss(25)
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)
         tms(i)=oalb(m)
         tmg(i)=albtdr(m)*pi
         tmh(i)=albtdf(m)*pi
         tmp(i)=albtrf(m)*pi
         tmq(i)=albwl(m)*pi
         tmpp(i)=tmq(i)/(tmb(i)+tmfd(i))
         tmqq(i)=tms(i)-tmpp(i)
         tmrr(i)=albrdr(m)
         tmss(i)=albrdf(m)
      enddo
c
      iprn=4
      call headr(iprn)
c
      write(iprn,6659)
      do 5567 i=1,lsza
      it=msza(i)
      write(iprn,6660)tma(i),pi
      write(iprn,6661)tmb(i),tmfd(i)
      if(iref.eq.1 .or. iref.eq.2)then
         write(iprn,6662)tmfu(i),tms(i)
         write(iprn,7663)tmg(i),tmh(i)
         write(iprn,7664)tmp(i),tmq(i)
         write(iprn,7665)tmpp(i),tmqq(i)
         write(iprn,7666)tmrr(i),tmss(i)
      endif
      if(iref.eq.3)write(iprn,6665)tmfu(i),tms(i)
      write(iprn,6668)
      write(iprn,6664)(the(ir),ir=1,nangl)
      do is=1,jpart                                                
         write(iprn,6667)jphi(is),(xzeroz(it,ir,is)*pi,ir=1,nangl)       
      enddo
5567  continue                                                          
c
      iprn=3
      call headr(iprn)
c
      write(iprn,6659)
      do 5568 i=1,lsza
      it=msza(i)
      write(iprn,6660)tma(i),pi
      write(iprn,6661)tmb(i),tmfd(i)
      if(iref.eq.1 .or. iref.eq.2)then
         write(iprn,6662)tmfu(i),tms(i)
         write(iprn,7663)tmg(i),tmh(i)
         write(iprn,7664)tmp(i),tmq(i)
         write(iprn,7665)tmpp(i),tmqq(i)
         write(iprn,7666)tmrr(i),tmss(i)
      endif
      if(iref.eq.3)write(iprn,6665)tmfu(i),tms(i)
      write(iprn,6668)
      write(iprn,6664)(the(ir),ir=1,nangl)
      do is=1,jpart                                                
        write(iprn,6667)jphi(is),(xzerod(it,ir,is)*pi,ir=1,nangl)       
      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,'fdif_up',t26,1pe12.4,t40,'hem. ref(ocean)',t64,1pe12.4)
6664  format('phi theta',7(2x,f5.1,3x)/3(9x,7(2x,f5.1,3x)/))
6665  format(t8,'fdif_up',t26,1pe12.4,t40,'hem. ref(surf)',t64,1pe12.4)
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)
7663  format(t8,'ftw_dir(ocn)',t26,1pe12.4,
     1       t40,'ftw_difdn(ocn)',t64,1pe12.4)
7664  format(t8,'ftw_difup(blow_ocn)',t27,1pe11.4,
     1       t40,'ftw_difup(above_ocn)',t64,1pe12.4)
7665  format(t8,'hem_ref(ocn_trans)',t26,1pe12.4,
     1       t40,'hem_ref(ocn_refl)',t64,1pe12.4)
7666  format(t8,'hem_ref(ocn_dirrfl)',t27,1pe11.4,
     1       t40,'hem_ref(ocn_difrfl)',t64,1pe12.4)
c***********************************************************************
      return                                                            
      end                                                               
c************************************************************************