mats.f

Go to the documentation of this file.

      subroutine mats(l)                                                
c                                                                       
c***********************************************************************
c     include the common statements.....................................
      implicit real*8 (a-h,o-z)
      include 'afrt_rt2.cmn'
c***********************************************************************
c                                                                       
      x = amu * amup + anu * anup * coosn                               
      xabs=dabs(x)                                                       
      if(x.gt.1.0d0)x=1.0d0
      if(x.lt.-1.0d0)x=-1.0d0
      if(xabs .lt. 1.0e-6)x=0.0                                         
      xza=dacos(x)*57.29578d0
c     write(6,213)kk,ii,l,amup,amu,anup,anu,coosn,x,xza
213   format('mats kk,ii,l,amup,amu,anup,anu,coosn,x'/3i3,7f7.3)
      y=dasin(x)*57.29578d0
      mtz=91.5-y
      tf1=(dacos(x)/conv)
      tf=10.0d0*tf1+1.0
      tfm1=idint(tf+0.01d0)
      tfp1=tfm1+1.0d0
      if(l-jpart)16,16,17                                               
   17 mt=1                                                              
      mn=nomat                                                          
      go to 19                                                          
   16 continue
      mt=idint(tf+0.01d0)
   18 mn=(l-1)*32                                                       
   19 continue
c     write(6,1253)mtz,y,mt,tf1,tf
1253  format('mtz,y,mt,tf1,tf',i3,1x,1pe11.3,1x,i3,1x,1p2e11.3)
      call xntpln(tf,tfm1,tfp1,t(mt,1),t(mt+1,1),tmt1) 
      call xntpln(tf,tfm1,tfp1,t(mt,2),t(mt+1,2),tmt2) 
      call xntpln(tf,tfm1,tfp1,t(mt,3),t(mt+1,3),tmt3) 
      call xntpln(tf,tfm1,tfp1,t(mt,4),t(mt+1,4),tmt4) 
c
c     tmt1=t(mt,1)
c     tmt2=t(mt,2)
c     tmt3=t(mt,3)
c     tmt4=t(mt,4)
c
c     write(6,565)kk,ii,l,mt,xza,tf,tfm1,tfp1,t(mt,1),t(mt+1,1),tmt1
565   format('kk,ii,l,mt,xza,tf,tfm1,tfp1,tm1,tm+1,tmt1'/
     1       3i3,i5,0p4f8.3,1p3e11.3)
c
      p(1,l)=cfisq*tmt1+sisq*tmt2+2.0d0*sifi*tmt3             
      p(2,l)=sfisq*(amups*tmt1+amusq*tmt2+2.0d0*amumu*tmt3)   
      p(3,l)=siin*(amup*coosn*tmt1+amu*copsi*tmt2+(amup*copsi+   
     1amu*coosn)*tmt3)                                               
      p(4,l)=siin*(amu*coosn-amup*copsi)*tmt4                       
      p(5,l)=sfisq*(amups*tmt2+amusq*tmt1+2.0d0*amumu*tmt3)   
      p(6,l)=sisq*tmt1+cfisq*tmt2+2.0d0*sifi*tmt3             
c
      pmats=const*0.5d0*(p(1,l)+p(2,l)+p(5,l)+p(6,l))*4.0d0*pi
c     write(6,560)kk,ii,l,mt,xza,tf,tfm1,tfp1,tmt1,tmt2,pmats
560   format('kk,ii,l,mt,xza,tf,tfm1,tfp1,tmt1,tmt2,pmats'/
     1       3i3,i5,0p4f8.3,1p3e11.3)
c
      p(7,l)=-siin*(amup*coosn*tmt2+amu*copsi*tmt1+(amup*copsi+  
     1amu*coosn)*tmt3)                                               
      p(8,l)=-p(4,l)                                                  
      p(9,l) = -2.0d0*siin*(amu*coosn*tmt1+amup*copsi*tmt2+      
     1 (amup*coosn+amu*copsi)*tmt3)                                  
      p(10,l) = 2.0d0*siin*(amu*coosn*tmt2+amup*copsi*tmt1+      
     1 (amup*coosn+amu*copsi)*tmt3)                                  
      p(11,l)=(sifi-amumu*sfisq)*(tmt1+tmt2)+(cfisq+sisq-sfisq   
     1*(amusq+amups))*tmt3                                           
      p(12,l)=(cfisq-sisq-sfisq*(amusq-amups))*tmt4                 
      p(13,l) = -2.0d0*siin*(amu*copsi-amup*coosn)*tmt4             
      p(14,l)=-p(13,l)                                                
      p(15,l)=(sisq-cfisq-sfisq*(amusq-amups))*tmt4                 
      p(16,l)=(sifi+amumu*sfisq)*(tmt1+tmt2)+(cfisq+sisq+sfisq   
     1*(amusq+amups))*tmt3                                           
      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     write(6,121)ipol,rho,gamma,agm,bgm,cgm                            
121   format('mtrx..ipol,rho,gamma,agm,bgm,cgm',i2,1x,1p5e11.3)         
      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                                                                       
c     write(6,*)'leaving mats'
      return                                                            
      end                                                               
c
c************************************************************************