src/exci/reclat.f

Fortran project EXCI, source module src/exci/reclat.f.

Source module last modified on Thu, 6 Apr 2006, 11:05;
HTML image of Fortran source automatically generated by for2html on Mon, 29 May 2006, 15:06.


#--------------------------------------------------
#//////////////////////////////////////////////////////////////////////
#////
#////  R E S T R A X   4.8.0
#////
#////  Operations in reciprocal lattice
#////  Linked both with EXCI library and RESTRAX
#////  
#//////////////////////////////////////////////////////////////////////

#-----------------------------------------------------------------------------
      SUBROUTINE POLVECT(q,tau,sig1,sig2,sig3,icom)
# return polarization unit vectors for phonon q=Q-TAU in r.l.u.
# SIG1 .. L
# SIG2 .. T in plane
# SIG3 .. T off plane
# To speed-up the procedure, calculation is made only if Q or TAU has changed or ICOM<>0
#-----------------------------------------------------------------------------
      implicit none
      INCLUDE 'reclat.inc
      
      real*8 eps
      parameter (eps=1.d-8)
      real*8 q(3),tau(3),sig1(3),sig2(3),sig3(3)
      integer*4 icom,i,j
      real*8 w1(3),w2(3),w3(3),v2(3),v3(3),qab(3),tab(3)
      real*8 lastq(3),lastt(3)
      real*8 qnr1,qnr2,qnr3,dum
      save w1,w2,w3   ! save last result for subsequent use
      data lastq /0.d0,0.d0,0.d0/
      data lastt /0.d0,0.d0,0.d0/
      
      
      if (icom.eq.0) then
        dum=abs(lastq(1)-q(1))+abs(lastq(2)-q(2))+abs(lastq(3)-q(3))
        dum=dum+
     &    abs(lastt(1)-tau(1))+abs(lastt(2)-tau(2))+abs(lastt(3)-tau(3))
        if (dum.lt.eps) goto 10
      endif
      
      do j=1,3
         w1(j)=q(j)-tau(j)  ! phonon q
      end do 
            
      do i=1,3
         qab(i)=0.d0
         tab(i)=0.d0
         do j=1,3
            qab(i)=qab(i)+smat(i,j)*w1(j)     ! convert qph to AB coordinates
            tab(i)=tab(i)+smat(i,j)*tau(j)    ! convert tau to AB coordinates
         enddo
      enddo

# vector parallel to (qab x tab)  
      v3(1)=qab(2)*tab(3)-qab(3)*tab(2)
      v3(2)=qab(3)*tab(1)-qab(1)*tab(3)
      v3(3)=qab(1)*tab(2)-qab(2)*tab(1)

# vector parallel to (V3 x qab)          
      v2(1)=v3(2)*qab(3)-v3(3)*qab(2)
      v2(2)=v3(3)*qab(1)-v3(1)*qab(3)
      v2(3)=v3(1)*qab(2)-v3(2)*qab(1)

# convert V2,V3 back to rec. lat. coordinates:
      do i=1,3
         w2(i)=0.d0
         w3(i)=0.d0
         do j=1,3
            w2(i)=w2(i)+sinv(i,j)*v2(j)      
            w3(i)=w3(i)+sinv(i,j)*v3(j)      
         enddo
      enddo
      
# normalize:            
      call QNORM(w1,qnr1,dum)
      call QNORM(w2,qnr2,dum)
      call QNORM(w3,qnr3,dum)
      do i=1,3
        w1(i)=w1(i)/qnr1
        w2(i)=w2(i)/qnr2
        w3(i)=w3(i)/qnr3
        lastq(i)=q(i)
        lastt(i)=tau(i)
      enddo
            
#20    format(3(2x,G12.6))
#      write(*,*) 'polarization unit vectors: '
#      do i=1,3
#        write(*,20) W1(i),W2(i),W3(i)
#      enddo      
      
10    do i=1,3
        sig1(i)=w1(i)
        sig2(i)=w2(i)
        sig3(i)=w3(i)
      enddo
      
      end      
      
 
#--------------------------------------------
      SUBROUTINE QNORM(x,qrlu,qang)
#  input: X in r.l.u.
#  returns: norm of X in r.l.u and A^-1
#--------------------------------------------
      implicit none
      INCLUDE 'reclat.inc
      
      real*8 x(3),qrlu,qang
      real*8 v3(3),z  
      integer*4 i        
      
      z=0.d0
      do i=1,3
        z=z+x(i)**2
      enddo        
              
      qrlu=sqrt(z+2*x(1)*x(2)*cosb(3)+
     1   2*x(2)*x(3)*cosb(1)+ 2*x(1)*x(3)*cosb(2))       ! norm of X in r.l.u.
      
      do i=1,3
         v3(i)=smat(i,1)*x(1)+smat(i,2)*x(2)+smat(i,3)*x(3)
      end do  
      qang= sqrt(v3(1)**2+v3(2)**2+v3(3)**2)    ! norm of X in [A-1]
      
      end  

#-----------------------------------------------------------
      real*8 FUNCTION QxQ(a,b)
#     returns dot-product of two vectors in r.l. coordinates
#-----------------------------------------------------------
      implicit none
      INCLUDE 'reclat.inc
           
      real*8 a(3),b(3),z           
      integer*4 i        
      
      z=0.d0
      do i=1,3
        z=z+a(i)*b(i)
      enddo        
      QxQ=z+(a(1)*b(2)+a(2)*b(1))*cosb(3)
     1              +(a(1)*b(3)+a(3)*b(1))*cosb(2)
     2              +(a(2)*b(3)+a(3)*b(2))*cosb(1)  
      
      end  

#--------------------------------------------------------------------
      SUBROUTINE GET_ANGLE(q1,q2,angle)
# returns angle between two rec. lattice vectors 
# Q1,Q2 must lay in scattering (horizontal) plane !!
# ANGLE is taken relative to Q1 in the interval (-PI,+PI)
#--------------------------------------------------------------------
      implicit none
      INCLUDE 'reclat.inc'      
      
      real*8 q1(3),q2(3),angle
      real*8 vq1(3),vq2(3),qn1,qn2,co,si
      integer*4 i,j        
      
      do i=1,3
        vq1(i)=0.d0
        vq2(i)=0.d0
        do j=1,3
          vq1(i)=vq1(i)+smat(i,j)*q1(j)
          vq2(i)=vq2(i)+smat(i,j)*q2(j)
        enddo
      enddo        
      qn1=sqrt(vq1(1)**2+vq1(2)**2)
      qn2=sqrt(vq2(1)**2+vq2(2)**2)
      if(qn1*qn2.lt.1e-10) then
        angle=0.d0
        return
      endif
      co=(vq1(1)*vq2(1)+vq1(2)*vq2(2))/(qn1*qn2)
      si=(vq1(1)*vq2(2)-vq1(2)*vq2(1))/(qn1*qn2)
      if (abs(si).lt.1e-8) then
        angle=0.d0
      else  
        angle=sign(1.d0,si)*abs(acos(co))
      endif  
      end