mirror of https://gitlab.com/QEF/q-e.git
67 lines
2.0 KiB
Fortran
67 lines
2.0 KiB
Fortran
!
|
|
! Copyright (C) 2003-2010 Quantum ESPRESSO group
|
|
! This file is distributed under the terms of the
|
|
! GNU General Public License. See the file `License'
|
|
! in the root directory of the present distribution,
|
|
! or http://www.gnu.org/copyleft/gpl.txt .
|
|
!
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
SUBROUTINE generate_effective_charges (nat, nsym, s, invs, irt, at, bg, &
|
|
n_diff_sites, equiv_atoms, has_equivalent, zstar)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! generate all effective charges
|
|
!
|
|
USE kinds, ONLY : DP
|
|
USE symme, ONLY : crys_to_cart, cart_to_crys
|
|
IMPLICIT NONE
|
|
INTEGER :: nat, nsym, n_diff_sites, irt(48,nat), equiv_atoms(nat,nat),&
|
|
s(3,3,48), has_equivalent(nat), invs(48)
|
|
INTEGER :: isym, na, ni, nj, sni, i, j, k, l
|
|
real(DP) :: zstar(3,3,nat), at(3,3), bg(3,3)
|
|
LOGICAL :: done(nat), no_equivalent_atoms
|
|
!
|
|
no_equivalent_atoms=.true.
|
|
DO na = 1,nat
|
|
no_equivalent_atoms = no_equivalent_atoms .and. has_equivalent(na)==0
|
|
ENDDO
|
|
IF (no_equivalent_atoms) RETURN
|
|
! transform to crystal axis
|
|
DO na = 1,nat
|
|
IF (has_equivalent(na)==0 ) THEN
|
|
CALL cart_to_crys ( zstar(:,:,na) )
|
|
done(na)=.true.
|
|
ELSE
|
|
zstar(:,:,na) = 0.d0
|
|
done(na)=.false.
|
|
ENDIF
|
|
ENDDO
|
|
!
|
|
DO isym = 1,nsym
|
|
DO na = 1,n_diff_sites
|
|
ni = equiv_atoms(na,1)
|
|
sni = irt(isym,ni)
|
|
IF ( .not.done(sni) ) THEN
|
|
DO i = 1,3
|
|
DO j = 1,3
|
|
DO k = 1,3
|
|
DO l = 1,3
|
|
zstar(i,j,sni) = zstar(i,j,sni) + &
|
|
s(i,k,invs(isym))*s(j,l,invs(isym))*zstar(k,l,ni)
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
ENDDO
|
|
done(sni)=.true.
|
|
ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
! back to cartesian axis
|
|
DO na = 1,nat
|
|
CALL crys_to_cart ( zstar(:,:,na) )
|
|
ENDDO
|
|
!
|
|
RETURN
|
|
END SUBROUTINE generate_effective_charges
|