matrx1.f

Go to the documentation of this file.

      subroutine matrx1                                                 
c                                                                       
c     include the common statements.....................................
      implicit real*8 (a-h,o-z)
      include 'common_all.cmn'                                          
c***********************************************************************
c                                                                       
c     write(6,*)'entering matrix'
      amu=-bmu(ii)                                                      
      anu=bnu(ii)                                                       
      amup=-bmu(kk)                                                     
      anup=bnu(kk)                                                      
      amusq=amu**2                                                      
      amumu=amu*amup                                                    
      amups=amup**2                                                     
      do 1 l=1,jpart                                                    
      coosn=cosn(l)                                                     
      siin=sn(l)                                                        
      copsi=anu*anup+amu*amup*coosn                                     
      sisq=copsi**2                                                     
      cfisq=coosn**2                                                    
      sifi=copsi*coosn                                                  
      sfisq=siin**2                                                     
      if(amu-amup)17,212,17                                             
   17 if(amu+amup)16,213,16                                             
  212 if(l-1)16,11,16                                                   
  213 if(l-jpart)16,214,16                                              
   11 if(ii-jjj)72,73,73                                                
   72 iq=4*(ii-1)                                                       
      go to 75                                                          
   73 iq=(nmum1-ii)*4                                                   
      go to 75                                                          
  214 if(ii-jjj)82,83,83                                                
   82 iq=4*(ii-1)                                                       
      go to 76                                                          
   83 iq=(nmum1-ii)*4                                                   
      go to 76                                                          
   16 continue
      call mats(l)
      go to 1                                                           
   75 mn=0                                                              
      do 350 ik=1,16                                                    
      jp=((ik-1)/4)*4                                                   
      ip=iq+jp/4+1                                                      
      ir=ik-jp                                                          
  350 p(ik,l)=pp(ip,ir)                                                   
  351 p(17,l)=sisq                                                     
      p(18,l)=amusq*sfisq                                              
      p(19,l)=amu*copsi*siin                                           
      p(20,l)=0.0d0                                                    
      p(21,l)=amups*sfisq                                              
      p(22,l)=cfisq                                                    
      p(23,l)=-amup*coosn*siin                                         
      p(24,l)=0.0d0                                                    
      p(25,l)=-2.0d0*amup*copsi*siin                                
      p(26,l)=2.0d0*amu*coosn*siin                                  
      p(27,l)=-amumu*sfisq+sifi                                        
      p(28,l)=0.0d0                                                 
      p(29,l)=0.0d0                                                 
      p(30,l)=0.0d0                                                 
      p(31,l)=0.0d0                                                    
      p(32,l)=amumu*sfisq+sifi                                         
c     apply molecular depolarization correction                         
c
c     write(6,1501)ipol,rho,gamma,agm,bgm,cgm
1501  format('ipol,rho,gamma,agm,bgm,cgm'/i2,1x,1p5e11.3)
c
      if(ipol.eq.1)then                                                 
        do i=1,3                                                        
          do j=1,3                                                      
             k=16+(i-1)*4+j                                             
             dgm=bgm
             if(i.eq.3 .or. j.eq.3)dgm=0.0d0
             p(k,l)=agm*p(k,l)+dgm                                    
          enddo                                                         
        enddo                                                           
        p(32,l)=p(32,l)+cgm                                           
      endif                                                             
c                                                                       
      if(ii-jjj)1139,1,1                                                
 1139 if(l-1)1,1140,1                                                   
 1140 lz=jjpart                                                         
      call mats(lz)                                                     
      go to 1                                                           
   76 mn=nomat-31                                                       
      mnz=nomat-32
      mnn=mn+15                                                         
      do 352 ik=mn,mnn                                                  
      jp=((ik-mn)/4)*4                                                  
      ip=iq+jp/4+1                                                      
      ir=ik-jp-mn+1                                                     
  352 p(ik-mnz,l)=qq(ip,ir)                                                   
      mn=mn-1                                                           
      go to 351                                                         
    1 continue                                                          
c
      return                                                            
      end                                                               
c***********************************************************************