phase.f

Go to the documentation of this file.

      subroutine phase                                                  
c***********************************************************************
c     subroutine phase computes the phase matirx for first scatter in   
c     the half layer and subsequent scatter in the full layer           
c     and stores it in the buffer ppin                                  
c***********************************************************************
c.....include the common blocks                                         
      implicit real*8 (a-h,o-z)
      include 'afrt_rt2.cmn'
c***********************************************************************
c     compute gamma for molecular depolarization correction             
      if(ipol.eq.1)then                                                 
        gamma=rho/(2.0-rho)                                             
        agm=(1.0-gamma)/(1+2.0*gamma)                                   
        bgm=gamma/(1.0+2.0*gamma)                                       
        cgm=(1.0-3.0*gamma)/(1.0+2.0*gamma)                            
      endif                                                             
c                                                                       
c     write(6,121)ipol,rho,gamma,agm,bgm,cgm                            
121   format('ipol,rho,gamma,agm,bgm,cgm',i2,1x,1p5e11.3)               
      lrec=1
      ltrec=lrec*jpart*32*nmum1
c     compute phase matrices for first scatter                          
      kk=kkx                                                            
      do 821 ii=1,nmum1                                                 
      call matrx1                                                       
      do i=1,jpart
         do k=1,32
            pc(k,i,ii)=p(k,i)
         enddo
      enddo
  821 continue                                                          
c     compute phase matrices for second scatter
      do 880 i=1,(nx-1)
  880 qsp(i)=0.                                                         
      do 825 ii=1,nmum1                                                 
      do 830 kk=1,nmum1                                                 
c     call matrx2                                                       
      call matrx1
      do i=1,jpart
         do k=1,32
            ppin(k,i,ii,kk)=p(k,i)
         enddo
      enddo
  830 continue
      if(ifc.eq.0)go to 973                                             
      call compc                                                        
  973 continue                                                          
c     write(6,440)ltrec,ii
440   format('ltrec,ii',2i8)
  825 continue                                                          
c     write(6,135)ifc,nmum1,(nx-1)
135   format('phase..ifc,nmum1,(nx-1)=',3i5)
      if(ifc.eq.0)go to 974                                             
c     write(6,882)                                                      
882   format(t3,'i',t17,'qsp',t29,'c')                                  
      do 881 i=1,na(nx-1)
      c(i)=1.d0/qsp(i)                                                    
      c(2*nx-1-i)=c(i)
  881 continue                                                          
      do i=1,(nx-1)
c         write(6,883)i,qsp(i),c(i)                                     
883       format(i5,1p2e12.4)                                           
      enddo                                                             
  974 continue                                                          
      return                                                            
      end                                                               
c**********************************************************************