Source module last modified on Tue, 9 May 2006, 20: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 'lattice.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 'lattice.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 'lattice.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 'lattice.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)
#11 format(a,6(1x,G12.6))
# write(*,*) 'VQ1: ',VQ1
# write(*,*) 'VQ2: ',VQ2
# write(*,*) 'CO, SI: ',CO,SI
# pause
if (abs(si).lt.1e-8) then
angle=0.d0
else
# write(*,*) 'ANGLE: ',SIGN(1.D0,SI)*ABS(ACOS(CO))/deg
angle=sign(1.d0,si)*abs(acos(co))
endif
end
#***********************************************************************
real*8 FUNCTION TRANS(a,i)
# Get I-th component of vector A in AX..BZ coordinates
# TRANS(i)=SMAT(i,j)*A(j)
# A is in r.l.u.
#***********************************************************************
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'lattice.inc'
real*8 a(3)
integer*4 i
TRANS=smat(i,1)*a(1)+smat(i,2)*a(2)+smat(i,3)*a(3)
return
end
#***********************************************************************
SUBROUTINE GetTransRLU(u,w,mur)
# Get transformation matrices MUR
# MUR(3,3) transforms vectors from r.l.u. to another system defined by
# two vectors U,W
# Equivalent to a rotation from hkl system to a system with x,y axes || to U,W
# U(3), W(3) are both expressed in r.l.u.
# U,W must be nonzero and non-parallel (not checked !)
#***********************************************************************
implicit none
INCLUDE 'const.inc'
INCLUDE 'inout.inc'
INCLUDE 'lattice.inc'
real*8 u(3),w(3),mur(3,3)
real*8 zz(3),uab(3),wab(3),zab(3),dum
real*8 un,wn,zn
integer*4 i,j
#// convert U,W to AB coordinates
do i=1,3
uab(i)=0.d0
wab(i)=0.d0
do j=1,3
uab(i)=uab(i)+smat(i,j)*u(j)
wab(i)=wab(i)+smat(i,j)*w(j)
enddo
enddo
#// get vector ZAB perpendicular to U,W (in AB coord.)
zab(1)=uab(2)*wab(3)-uab(3)*wab(2)
zab(2)=uab(3)*wab(1)-uab(1)*wab(3)
zab(3)=uab(1)*wab(2)-uab(2)*wab(1)
#// convert ZAB back to r.l.u.
do i=1,3
zz(i)=0.d0
do j=1,3
zz(i)=zz(i)+sinv(i,j)*zab(j)
enddo
enddo
#// get norms of the 3 vectors in r.l.u.
call QNORM(u,un,dum)
call QNORM(w,wn,dum)
call QNORM(zz,zn,dum)
#// get the trans. matrix from U,W,Z
do j=1,3
mur(1,j)=u(j)/un
mur(2,j)=w(j)/wn
mur(3,j)=zz(j)/zn
enddo
end