mirror of https://gitlab.com/QEF/q-e.git
Clean star and transport.
This commit is contained in:
Samuel Ponce
parent
0392d3f6d4
commit
55bbe35e59
|
|
@ -10,123 +10,141 @@
|
|||
! Adapted from QE
|
||||
!
|
||||
!-----------------------------------------------------------------------
|
||||
SUBROUTINE star_q2 (xq, at, bg, nsym, s, invs, nq, sxq, isq, imq, verbosity, sym_smallq )
|
||||
SUBROUTINE star_q2(xq, at, bg, nsym, s, invs, nq, sxq, isq, imq, verbosity, sym_smallq)
|
||||
!-----------------------------------------------------------------------
|
||||
!
|
||||
! Generate the star of q vectors that are equivalent to the input one
|
||||
! NB: input s(:,:,1:nsym) must contain all crystal symmetries,
|
||||
! i.e. not those of the small-qroup of q only
|
||||
!
|
||||
!!
|
||||
!! Generate the star of q vectors that are equivalent to the input one
|
||||
!! NB: input s(:,:,1:nsym) must contain all crystal symmetries,
|
||||
!! i.e. not those of the small-qroup of q only
|
||||
!!
|
||||
!! SP - Sept. 2019 - Cleaning
|
||||
USE io_global, ONLY : stdout
|
||||
USE kinds, ONLY : DP
|
||||
!
|
||||
IMPLICIT NONE
|
||||
!
|
||||
REAL(DP), parameter :: accep=1.e-5_dp
|
||||
!
|
||||
LOGICAL, INTENT(in) :: verbosity
|
||||
!! if true prints several messages.
|
||||
INTEGER, INTENT(in) :: nsym
|
||||
!! nsym matrices of symmetry operations
|
||||
INTEGER, INTENT(in) :: s(3, 3, 48)
|
||||
!! Symmetry operations
|
||||
INTEGER, INTENT(in) :: invs(48)
|
||||
!! list of inverse operation indices
|
||||
INTEGER, INTENT(out) :: nq
|
||||
!! degeneracy of the star of q
|
||||
INTEGER, INTENT(out) :: isq(48)
|
||||
!! index of q in the star for a given sym
|
||||
INTEGER, INTENT(out) :: imq
|
||||
!! index of -q in the star (0 if not present)
|
||||
REAL(KIND = DP), INTENT(in) :: xq(3)
|
||||
!! q vector
|
||||
REAL(KIND = DP), INTENT(in) :: at(3, 3)
|
||||
!! direct lattice vectors
|
||||
REAL(KIND = DP), INTENT(in) :: bg(3, 3)
|
||||
!! reciprocal lattice vectors
|
||||
REAL(KIND = DP), INTENT(in) ::
|
||||
!!
|
||||
REAL(KIND = DP), INTENT(out) :: sxq(3, 48)
|
||||
!! list of vectors in the star of q
|
||||
!
|
||||
! Local variables
|
||||
LOGICAL, EXTERNAL :: eqvect
|
||||
!! function used to compare two vectors
|
||||
INTEGER :: sym_smallq(48)
|
||||
!
|
||||
integer, intent(in) :: nsym, s (3, 3, 48), invs(48)
|
||||
! nsym matrices of symmetry operations
|
||||
! invs: list of inverse operation indices
|
||||
REAL(DP), intent(in) :: xq (3), at (3, 3), bg (3, 3)
|
||||
! xq: q vector
|
||||
! at: direct lattice vectors
|
||||
! bg: reciprocal lattice vectors
|
||||
!
|
||||
integer, intent(out) :: nq, isq (48), imq
|
||||
! nq : degeneracy of the star of q
|
||||
! isq : index of q in the star for a given sym
|
||||
! imq : index of -q in the star (0 if not present)
|
||||
!
|
||||
REAL(DP), intent(out) :: sxq (3, 48)
|
||||
! list of vectors in the star of q
|
||||
logical, intent(in) :: verbosity
|
||||
! if true prints several messages.
|
||||
!
|
||||
INTEGER :: nsq (48), isym, ism1, iq, i
|
||||
! number of symmetry ops. of bravais lattice
|
||||
! counters on symmetry ops.
|
||||
! index of inverse of isym
|
||||
! counters
|
||||
REAL(DP) :: saq (3, 48), aq (3), raq (3), zero (3)
|
||||
! auxiliary list of q (crystal coordinates)
|
||||
! input q in crystal coordinates
|
||||
! rotated q in crystal coordinates
|
||||
! coordinates of fractionary translations
|
||||
! a zero vector: used in eqvect
|
||||
!
|
||||
logical, EXTERNAL :: eqvect
|
||||
! function used to compare two vectors
|
||||
!
|
||||
!!
|
||||
INTEGER :: nsq(48)
|
||||
!! number of symmetry ops. of bravais lattice
|
||||
INTEGER :: isym
|
||||
!! counters on symmetry ops.
|
||||
INTEGER :: ism1
|
||||
!! index of inverse of isym
|
||||
INTEGER :: iq
|
||||
!! q-counter
|
||||
INTEGER :: i
|
||||
!! Counter
|
||||
REAL(KIND = DP) :: saq(3, 48)
|
||||
!! auxiliary list of q (crystal coordinates)
|
||||
REAL(KIND = DP) :: aq(3)
|
||||
!! input q in crystal coordinates
|
||||
REAL(KIND = DP) :: raq(3)
|
||||
!! rotated q in crystal coordinates
|
||||
REAL(KIND = DP) :: zero(3)
|
||||
!! a zero vector: used in eqvect
|
||||
REAL(KIND = DP), PARAMETER :: accep = 1.e-5_dp
|
||||
!! Tolerence
|
||||
|
||||
zero(:) = 0.d0
|
||||
!
|
||||
! go to crystal coordinates
|
||||
!
|
||||
do i = 1, 3
|
||||
aq(i) = xq(1) * at(1,i) + xq(2) * at(2,i) + xq(3) * at(3,i)
|
||||
enddo
|
||||
DO i = 1, 3
|
||||
aq(i) = xq(1) * at(1,i) + xq(2) * at(2,i) + xq(3) * at(3,i)
|
||||
ENDDO
|
||||
!
|
||||
! create the list of rotated q
|
||||
!
|
||||
do i = 1, 48
|
||||
nsq (i) = 0
|
||||
isq (i) = 0
|
||||
enddo
|
||||
DO i = 1, 48
|
||||
nsq(i) = 0
|
||||
isq(i) = 0
|
||||
ENDDO
|
||||
nq = 0
|
||||
do isym = 1, nsym
|
||||
ism1 = invs (isym)
|
||||
do i = 1, 3
|
||||
raq (i) = s (i, 1, ism1) * aq (1) &
|
||||
+ s (i, 2, ism1) * aq (2) &
|
||||
+ s (i, 3, ism1) * aq (3)
|
||||
enddo
|
||||
do i = 1, 3
|
||||
sxq (i, 48) = bg (i, 1) * raq (1) &
|
||||
+ bg (i, 2) * raq (2) &
|
||||
+ bg (i, 3) * raq (3)
|
||||
enddo
|
||||
do iq = 1, nq
|
||||
if (eqvect (raq, saq (1, iq), zero, accep) ) then
|
||||
isq (isym) = iq
|
||||
nsq (iq) = nsq (iq) + 1
|
||||
endif
|
||||
enddo
|
||||
if (isq (isym) == 0) then
|
||||
nq = nq + 1
|
||||
nsq (nq) = 1
|
||||
isq (isym) = nq
|
||||
saq(:,nq) = raq(:)
|
||||
sym_smallq(nq) = isym
|
||||
do i = 1, 3
|
||||
sxq (i, nq) = bg (i, 1) * saq (1, nq) &
|
||||
+ bg (i, 2) * saq (2, nq) &
|
||||
+ bg (i, 3) * saq (3, nq)
|
||||
enddo
|
||||
endif
|
||||
enddo
|
||||
DO isym = 1, nsym
|
||||
ism1 = invs(isym)
|
||||
DO i = 1, 3
|
||||
raq(i) = s(i, 1, ism1) * aq(1) &
|
||||
+ s(i, 2, ism1) * aq(2) &
|
||||
+ s(i, 3, ism1) * aq(3)
|
||||
ENDDO
|
||||
DO i = 1, 3
|
||||
sxq(i, 48) = bg(i, 1) * raq(1) &
|
||||
+ bg(i, 2) * raq(2) &
|
||||
+ bg(i, 3) * raq(3)
|
||||
ENDDO
|
||||
DO iq = 1, nq
|
||||
IF (eqvect(raq, saq(1, iq), zero, accep)) THEN
|
||||
isq(isym) = iq
|
||||
nsq(iq) = nsq(iq) + 1
|
||||
ENDDIF
|
||||
ENDDO
|
||||
IF (isq(isym) == 0) THEN
|
||||
nq = nq + 1
|
||||
nsq(nq) = 1
|
||||
isq(isym) = nq
|
||||
saq(:, nq) = raq(:)
|
||||
sym_smallq(nq) = isym
|
||||
DO i = 1, 3
|
||||
sxq(i, nq) = bg(i, 1) * saq(1, nq) &
|
||||
+ bg(i, 2) * saq(2, nq) &
|
||||
+ bg(i, 3) * saq(3, nq)
|
||||
ENDDO
|
||||
ENDIF
|
||||
ENDDO
|
||||
!
|
||||
! SP: Now determine which q in the star is obtained
|
||||
!
|
||||
! Set imq index if needed and check star degeneracy
|
||||
!
|
||||
raq (:) = - aq(:)
|
||||
raq(:) = -aq(:)
|
||||
imq = 0
|
||||
do iq = 1, nq
|
||||
if (eqvect (raq, saq (1, iq), zero, accep) ) imq = iq
|
||||
if (nsq(iq)*nq /= nsym) call errore ('star_q', 'wrong degeneracy', iq)
|
||||
enddo
|
||||
DO iq = 1, nq
|
||||
IF (eqvect(raq, saq(1, iq), zero, accep)) imq = iq
|
||||
IF (nsq(iq) * nq /= nsym) CALL errore('star_q', 'wrong degeneracy', iq)
|
||||
ENDDO
|
||||
!
|
||||
! writes star of q
|
||||
!
|
||||
IF (verbosity) THEN
|
||||
WRITE( stdout, * )
|
||||
WRITE( stdout, '(5x,a,i4)') 'Number of q in the star = ', nq
|
||||
WRITE( stdout, '(5x,a)') 'List of q in the star:'
|
||||
WRITE( stdout, '(7x,i4,3f14.9)') (iq, (sxq(i,iq), i = 1,3), iq = 1,nq)
|
||||
if (imq == 0) then
|
||||
WRITE( stdout, '(5x,a)') 'In addition there is the -q list: '
|
||||
WRITE( stdout, '(7x,i4,3f14.9)') (iq, (-sxq(i,iq), i = 1,3), iq = 1,nq)
|
||||
endif
|
||||
WRITE(stdout, *)
|
||||
WRITE(stdout, '(5x,a,i4)') 'Number of q in the star = ', nq
|
||||
WRITE(stdout, '(5x,a)') 'List of q in the star:'
|
||||
WRITE(stdout, '(7x,i4,3f14.9)') (iq, (sxq(i, iq), i = 1, 3), iq = 1, nq)
|
||||
IF (imq == 0) THEN
|
||||
WRITE(stdout, '(5x,a)') 'In addition there is the -q list: '
|
||||
WRITE(stdout, '(7x,i4,3f14.9)') (iq, (-sxq(i, iq), i = 1, 3), iq = 1, nq)
|
||||
ENDIF
|
||||
ENDIF
|
||||
return
|
||||
END SUBROUTINE star_q2
|
||||
RETURN
|
||||
!-----------------------------------------------------------------------
|
||||
END SUBROUTINE star_q2
|
||||
!-----------------------------------------------------------------------
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue