mirror of
https://github.com/cp2k/cp2k.git
synced 2026-07-21 06:25:15 -04:00
Move SCF MO k-point symmetry transform helper out of qs_wannier90 (#5598)
This commit is contained in:
SY Wang
GitHub
parent
df8ab74de5
commit
8f16beb039
3 changed files with 259 additions and 222 deletions
|
|
@ -329,6 +329,7 @@ list(
|
|||
kpoint_k_r_trafo_simple.F
|
||||
kpoint_methods.F
|
||||
kpoint_mo_dump.F
|
||||
kpoint_mo_symmetry_methods.F
|
||||
kpoint_transitional.F
|
||||
kpoint_types.F
|
||||
kpsym.F
|
||||
|
|
|
|||
238
src/kpoint_mo_symmetry_methods.F
Normal file
238
src/kpoint_mo_symmetry_methods.F
Normal file
|
|
@ -0,0 +1,238 @@
|
|||
!--------------------------------------------------------------------------------------------------!
|
||||
! CP2K: A general program to perform molecular dynamics simulations !
|
||||
! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
|
||||
! !
|
||||
! SPDX-License-Identifier: GPL-2.0-or-later !
|
||||
!--------------------------------------------------------------------------------------------------!
|
||||
|
||||
! **************************************************************************************************
|
||||
!> \brief Utilities for transforming k-point MO coefficients under symmetry operations
|
||||
! **************************************************************************************************
|
||||
MODULE kpoint_mo_symmetry_methods
|
||||
USE cp_fm_types, ONLY: cp_fm_copy_general,&
|
||||
cp_fm_get_info,&
|
||||
cp_fm_get_submatrix,&
|
||||
cp_fm_set_submatrix,&
|
||||
cp_fm_type
|
||||
USE kinds, ONLY: dp
|
||||
USE kpoint_types, ONLY: kind_rotmat_type,&
|
||||
kpoint_sym_type,&
|
||||
kpoint_type
|
||||
USE mathconstants, ONLY: twopi
|
||||
USE message_passing, ONLY: mp_para_env_type
|
||||
#include "./base/base_uses.f90"
|
||||
|
||||
IMPLICIT NONE
|
||||
PRIVATE
|
||||
|
||||
CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'kpoint_mo_symmetry_methods'
|
||||
|
||||
PUBLIC :: kpoint_same_periodic, &
|
||||
kpoint_transform_scf_mo
|
||||
|
||||
CONTAINS
|
||||
|
||||
! **************************************************************************************************
|
||||
!> \brief Compare two fractional k-points modulo reciprocal lattice vectors.
|
||||
!> \param xkp_a first k-point
|
||||
!> \param xkp_b second k-point
|
||||
!> \return true if the k-points are equivalent
|
||||
! **************************************************************************************************
|
||||
LOGICAL FUNCTION kpoint_same_periodic(xkp_a, xkp_b) RESULT(same)
|
||||
REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b
|
||||
|
||||
REAL(KIND=dp), DIMENSION(3) :: diff
|
||||
|
||||
diff(1:3) = xkp_a(1:3) - xkp_b(1:3)
|
||||
diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp)
|
||||
same = SUM(ABS(diff(1:3))) < 1.0e-8_dp
|
||||
|
||||
END FUNCTION kpoint_same_periodic
|
||||
|
||||
! **************************************************************************************************
|
||||
!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point.
|
||||
!> \param src_real real part of source MO coefficients
|
||||
!> \param src_imag imaginary part of source MO coefficients
|
||||
!> \param dst_real real part of transformed MO coefficients
|
||||
!> \param dst_imag imaginary part of transformed MO coefficients
|
||||
!> \param qs_kpoint SCF k-point object containing symmetry operations
|
||||
!> \param ikred representative k-point index
|
||||
!> \param isym symmetry operation index; 0 direct copy, -1 time reversal
|
||||
!> \param para_env global parallel environment
|
||||
!> \param success true if the transformation was performed
|
||||
!> \param reason diagnostic message
|
||||
! **************************************************************************************************
|
||||
SUBROUTINE kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, &
|
||||
isym, para_env, success, reason)
|
||||
TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag
|
||||
TYPE(kpoint_type), POINTER :: qs_kpoint
|
||||
INTEGER, INTENT(IN) :: ikred, isym
|
||||
TYPE(mp_para_env_type), POINTER :: para_env
|
||||
LOGICAL, INTENT(OUT) :: success
|
||||
CHARACTER(LEN=*), INTENT(OUT) :: reason
|
||||
|
||||
INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, &
|
||||
nmo, rot_slot, source_atom, source_dim, target_atom, target_dim
|
||||
INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start
|
||||
LOGICAL :: reverse_phase, time_reversal
|
||||
REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, &
|
||||
phase_imag, phase_real, sinkl
|
||||
REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r
|
||||
REAL(KIND=dp), DIMENSION(3) :: xkp_phase
|
||||
REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat
|
||||
TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot
|
||||
TYPE(kpoint_sym_type), POINTER :: kpsym
|
||||
|
||||
success = .FALSE.
|
||||
reason = ""
|
||||
IF (isym == 0) THEN
|
||||
CALL cp_fm_copy_general(src_real, dst_real, para_env)
|
||||
CALL cp_fm_copy_general(src_imag, dst_imag, para_env)
|
||||
success = .TRUE.
|
||||
RETURN
|
||||
END IF
|
||||
|
||||
CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo)
|
||||
ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo))
|
||||
CALL cp_fm_get_submatrix(src_real, src_r)
|
||||
CALL cp_fm_get_submatrix(src_imag, src_i)
|
||||
dst_r(:, :) = 0.0_dp
|
||||
dst_i(:, :) = 0.0_dp
|
||||
|
||||
IF (isym == -1) THEN
|
||||
dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo)
|
||||
dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo)
|
||||
CALL cp_fm_set_submatrix(dst_real, dst_r)
|
||||
CALL cp_fm_set_submatrix(dst_imag, dst_i)
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
success = .TRUE.
|
||||
RETURN
|
||||
END IF
|
||||
|
||||
IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN
|
||||
reason = "SCF symmetry operation data are not available"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym
|
||||
IF (.NOT. ASSOCIATED(kpsym)) THEN
|
||||
reason = "SCF k-point symmetry operation is not available"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
IF (isym > kpsym%nwred) THEN
|
||||
reason = "SCF k-point symmetry operation index is out of range"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN
|
||||
reason = "SCF atom mappings or basis rotation matrices are not available"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
|
||||
rot_slot = find_kpoint_rotation_slot(qs_kpoint, kpsym%rotp(isym))
|
||||
IF (rot_slot == 0) THEN
|
||||
reason = "could not match the SCF symmetry operation to a basis rotation"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
kind_rot => qs_kpoint%kind_rotmat(rot_slot, :)
|
||||
natom = SIZE(qs_kpoint%atype)
|
||||
ALLOCATE (ao_start(natom), ao_size(natom))
|
||||
irow = 1
|
||||
DO iatom = 1, natom
|
||||
ikind = qs_kpoint%atype(iatom)
|
||||
IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN
|
||||
reason = "a required basis rotation matrix is not available"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size)
|
||||
RETURN
|
||||
END IF
|
||||
ao_start(iatom) = irow
|
||||
ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2)
|
||||
irow = irow + ao_size(iatom)
|
||||
END DO
|
||||
IF (irow - 1 /= nao) THEN
|
||||
reason = "atom-resolved AO dimensions do not match the MO coefficient matrix"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size)
|
||||
RETURN
|
||||
END IF
|
||||
|
||||
time_reversal = kpsym%rotp(isym) < 0
|
||||
reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0)
|
||||
IF (ASSOCIATED(kpsym%phase_mode)) THEN
|
||||
IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2
|
||||
END IF
|
||||
xkp_phase(1:3) = kpsym%xkp(1:3, isym)
|
||||
DO iatom = 1, natom
|
||||
source_atom = iatom
|
||||
target_atom = kpsym%f0(iatom, isym)
|
||||
ikind = qs_kpoint%atype(source_atom)
|
||||
rotmat => kind_rot(ikind)%rmat
|
||||
source_dim = ao_size(source_atom)
|
||||
target_dim = ao_size(target_atom)
|
||||
IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN
|
||||
reason = "basis rotation dimensions do not match the atom/AO symmetry transform"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size)
|
||||
RETURN
|
||||
END IF
|
||||
arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + &
|
||||
REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + &
|
||||
REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3)
|
||||
IF (ASSOCIATED(kpsym%kgphase)) THEN
|
||||
arg = arg + kpsym%kgphase(source_atom, isym)
|
||||
END IF
|
||||
IF (reverse_phase) arg = -arg
|
||||
coskl = COS(twopi*arg)
|
||||
sinkl = SIN(twopi*arg)
|
||||
DO imo = 1, nmo
|
||||
DO irow_work = 1, source_dim
|
||||
irow_source = ao_start(source_atom) + irow_work - 1
|
||||
coeff_real = src_r(irow_source, imo)
|
||||
coeff_imag = src_i(irow_source, imo)
|
||||
IF (time_reversal) coeff_imag = -coeff_imag
|
||||
phase_real = coskl*coeff_real - sinkl*coeff_imag
|
||||
phase_imag = sinkl*coeff_real + coskl*coeff_imag
|
||||
DO iao = 1, target_dim
|
||||
irow_target = ao_start(target_atom) + iao - 1
|
||||
dst_r(irow_target, imo) = dst_r(irow_target, imo) + &
|
||||
rotmat(iao, irow_work)*phase_real
|
||||
dst_i(irow_target, imo) = dst_i(irow_target, imo) + &
|
||||
rotmat(iao, irow_work)*phase_imag
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
|
||||
CALL cp_fm_set_submatrix(dst_real, dst_r)
|
||||
CALL cp_fm_set_submatrix(dst_imag, dst_i)
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size)
|
||||
success = .TRUE.
|
||||
|
||||
END SUBROUTINE kpoint_transform_scf_mo
|
||||
|
||||
! **************************************************************************************************
|
||||
!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation.
|
||||
!> \param qs_kpoint SCF k-point object
|
||||
!> \param rotp signed operation identifier
|
||||
!> \return rotation slot, or zero when no slot matches
|
||||
! **************************************************************************************************
|
||||
INTEGER FUNCTION find_kpoint_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot)
|
||||
TYPE(kpoint_type), POINTER :: qs_kpoint
|
||||
INTEGER, INTENT(IN) :: rotp
|
||||
|
||||
INTEGER :: irot, rot_abs
|
||||
|
||||
rot_slot = 0
|
||||
rot_abs = ABS(rotp)
|
||||
IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN
|
||||
DO irot = 1, SIZE(qs_kpoint%ibrot)
|
||||
IF (rot_abs == qs_kpoint%ibrot(irot)) THEN
|
||||
rot_slot = irot
|
||||
RETURN
|
||||
END IF
|
||||
END DO
|
||||
|
||||
END FUNCTION find_kpoint_rotation_slot
|
||||
|
||||
END MODULE kpoint_mo_symmetry_methods
|
||||
|
|
@ -57,8 +57,9 @@ MODULE qs_wannier90
|
|||
kpoint_initialize_mo_set,&
|
||||
kpoint_initialize_mos,&
|
||||
rskp_transform
|
||||
USE kpoint_mo_symmetry_methods, ONLY: kpoint_same_periodic,&
|
||||
kpoint_transform_scf_mo
|
||||
USE kpoint_types, ONLY: get_kpoint_info,&
|
||||
kind_rotmat_type,&
|
||||
kpoint_create,&
|
||||
kpoint_env_type,&
|
||||
kpoint_release,&
|
||||
|
|
@ -1168,12 +1169,12 @@ CONTAINS
|
|||
num_candidates = 0
|
||||
! Little-group operations can reach the same target k-point; keep the first valid eigenspace.
|
||||
DO isym_try = 1, kpsym%nwred
|
||||
IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), &
|
||||
IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), &
|
||||
kpsym%xkp(1:3, isym_try))) CYCLE
|
||||
num_candidates = num_candidates + 1
|
||||
CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, &
|
||||
qs_kpoint, ikred, isym_try, para_env, ok, &
|
||||
candidate_reason)
|
||||
CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, &
|
||||
qs_kpoint, ikred, isym_try, para_env, ok, &
|
||||
candidate_reason)
|
||||
IF (.NOT. ok) THEN
|
||||
reason = candidate_reason
|
||||
CYCLE
|
||||
|
|
@ -1191,9 +1192,9 @@ CONTAINS
|
|||
END IF
|
||||
IF (.NOT. ok) THEN
|
||||
IF (source_window) THEN
|
||||
CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, &
|
||||
dst_real_full, dst_imag_full, qs_kpoint, &
|
||||
ikred, isym_try, para_env, ok, candidate_reason)
|
||||
CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, &
|
||||
dst_real_full, dst_imag_full, qs_kpoint, &
|
||||
ikred, isym_try, para_env, ok, candidate_reason)
|
||||
IF (ok) THEN
|
||||
CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, &
|
||||
dst_real, dst_imag, matrix_s, &
|
||||
|
|
@ -1239,8 +1240,8 @@ CONTAINS
|
|||
reason = "SCF k-point symmetry operation is not available"
|
||||
END IF
|
||||
ELSE
|
||||
CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, &
|
||||
ikred, sym_index(ik), para_env, ok, reason)
|
||||
CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, &
|
||||
ikred, sym_index(ik), para_env, ok, reason)
|
||||
END IF
|
||||
IF (ok .AND. sym_index(ik) <= 0) THEN
|
||||
! Even a direct k-point copy must be a closed H(k),S(k) subspace. This catches
|
||||
|
|
@ -1251,9 +1252,9 @@ CONTAINS
|
|||
ok, reason, aligned_blocks, aligned_max_size, &
|
||||
aligned_min_svalue, candidate_residual)
|
||||
IF (.NOT. ok .AND. source_window) THEN
|
||||
CALL transform_wannier90_scf_mo(src_real_full, src_imag_full, dst_real_full, &
|
||||
dst_imag_full, qs_kpoint, ikred, sym_index(ik), &
|
||||
para_env, ok, reason)
|
||||
CALL kpoint_transform_scf_mo(src_real_full, src_imag_full, dst_real_full, &
|
||||
dst_imag_full, qs_kpoint, ikred, sym_index(ik), &
|
||||
para_env, ok, reason)
|
||||
IF (ok) THEN
|
||||
CALL ritz_reconstruct_wannier90_window(dst_real_full, dst_imag_full, dst_real, &
|
||||
dst_imag, matrix_s, matrix_ks, &
|
||||
|
|
@ -1723,8 +1724,8 @@ CONTAINS
|
|||
best_residual = 0.0_dp
|
||||
best_svalue = 0.0_dp
|
||||
IF (sym_index(ik) <= 0) THEN
|
||||
CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, &
|
||||
ikred, sym_index(ik), para_env, ok, reason)
|
||||
CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, &
|
||||
ikred, sym_index(ik), para_env, ok, reason)
|
||||
IF (ok) THEN
|
||||
CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, matrix_s, &
|
||||
kpoint%xkp(1:3, ik), cell_to_index, sab_nl, &
|
||||
|
|
@ -1756,10 +1757,10 @@ CONTAINS
|
|||
kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym
|
||||
IF (ASSOCIATED(kpsym)) THEN
|
||||
DO isym_try = 1, kpsym%nwred
|
||||
IF (.NOT. same_periodic_kpoint(kpoint%xkp(1:3, ik), &
|
||||
IF (.NOT. kpoint_same_periodic(kpoint%xkp(1:3, ik), &
|
||||
kpsym%xkp(1:3, isym_try))) CYCLE
|
||||
CALL transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, &
|
||||
qs_kpoint, ikred, isym_try, para_env, ok, reason)
|
||||
CALL kpoint_transform_scf_mo(src_real, src_imag, dst_real, dst_imag, &
|
||||
qs_kpoint, ikred, isym_try, para_env, ok, reason)
|
||||
IF (.NOT. ok) CYCLE
|
||||
CALL measure_wannier90_subspace_error(ref_real, ref_imag, dst_real, dst_imag, &
|
||||
matrix_s, kpoint%xkp(1:3, ik), cell_to_index, &
|
||||
|
|
@ -2615,7 +2616,7 @@ CONTAINS
|
|||
|
||||
ik_match = 0
|
||||
DO ik = 1, SIZE(xkp_mesh, 2)
|
||||
IF (same_periodic_kpoint(xkp_mesh(1:3, ik), xkp_search)) THEN
|
||||
IF (kpoint_same_periodic(xkp_mesh(1:3, ik), xkp_search)) THEN
|
||||
ik_match = ik
|
||||
RETURN
|
||||
END IF
|
||||
|
|
@ -2623,209 +2624,6 @@ CONTAINS
|
|||
|
||||
END FUNCTION find_matching_kpoint
|
||||
|
||||
! **************************************************************************************************
|
||||
!> \brief Compare two fractional k-points modulo reciprocal lattice vectors.
|
||||
!> \param xkp_a first k-point
|
||||
!> \param xkp_b second k-point
|
||||
!> \return true if the k-points are equivalent
|
||||
! **************************************************************************************************
|
||||
LOGICAL FUNCTION same_periodic_kpoint(xkp_a, xkp_b) RESULT(same)
|
||||
REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: xkp_a, xkp_b
|
||||
|
||||
REAL(KIND=dp), DIMENSION(3) :: diff
|
||||
|
||||
diff(1:3) = xkp_a(1:3) - xkp_b(1:3)
|
||||
diff(1:3) = diff(1:3) - REAL(NINT(diff(1:3)), KIND=dp)
|
||||
same = SUM(ABS(diff(1:3))) < 1.0e-8_dp
|
||||
|
||||
END FUNCTION same_periodic_kpoint
|
||||
|
||||
! **************************************************************************************************
|
||||
!> \brief Transform one SCF MO coefficient matrix to an equivalent full-mesh k-point.
|
||||
!> \param src_real real part of source MO coefficients
|
||||
!> \param src_imag imaginary part of source MO coefficients
|
||||
!> \param dst_real real part of transformed MO coefficients
|
||||
!> \param dst_imag imaginary part of transformed MO coefficients
|
||||
!> \param qs_kpoint SCF k-point object containing symmetry operations
|
||||
!> \param ikred representative k-point index
|
||||
!> \param isym symmetry operation index; 0 direct copy, -1 time reversal
|
||||
!> \param para_env global parallel environment
|
||||
!> \param success true if the transformation was performed
|
||||
!> \param reason diagnostic message
|
||||
! **************************************************************************************************
|
||||
SUBROUTINE transform_wannier90_scf_mo(src_real, src_imag, dst_real, dst_imag, qs_kpoint, ikred, &
|
||||
isym, para_env, success, reason)
|
||||
TYPE(cp_fm_type), INTENT(IN) :: src_real, src_imag, dst_real, dst_imag
|
||||
TYPE(kpoint_type), POINTER :: qs_kpoint
|
||||
INTEGER, INTENT(IN) :: ikred, isym
|
||||
TYPE(mp_para_env_type), POINTER :: para_env
|
||||
LOGICAL, INTENT(OUT) :: success
|
||||
CHARACTER(LEN=*), INTENT(OUT) :: reason
|
||||
|
||||
INTEGER :: iao, iatom, ikind, imo, irow, irow_source, irow_target, irow_work, nao, natom, &
|
||||
nmo, rot_slot, source_atom, source_dim, target_atom, target_dim
|
||||
INTEGER, ALLOCATABLE, DIMENSION(:) :: ao_size, ao_start
|
||||
LOGICAL :: reverse_phase, time_reversal
|
||||
REAL(KIND=dp) :: arg, coeff_imag, coeff_real, coskl, &
|
||||
phase_imag, phase_real, sinkl
|
||||
REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: dst_i, dst_r, src_i, src_r
|
||||
REAL(KIND=dp), DIMENSION(3) :: xkp_phase
|
||||
REAL(KIND=dp), DIMENSION(:, :), POINTER :: rotmat
|
||||
TYPE(kind_rotmat_type), DIMENSION(:), POINTER :: kind_rot
|
||||
TYPE(kpoint_sym_type), POINTER :: kpsym
|
||||
|
||||
success = .FALSE.
|
||||
reason = ""
|
||||
IF (isym == 0) THEN
|
||||
CALL cp_fm_copy_general(src_real, dst_real, para_env)
|
||||
CALL cp_fm_copy_general(src_imag, dst_imag, para_env)
|
||||
success = .TRUE.
|
||||
RETURN
|
||||
END IF
|
||||
|
||||
CALL cp_fm_get_info(src_real, nrow_global=nao, ncol_global=nmo)
|
||||
ALLOCATE (src_r(nao, nmo), src_i(nao, nmo), dst_r(nao, nmo), dst_i(nao, nmo))
|
||||
CALL cp_fm_get_submatrix(src_real, src_r)
|
||||
CALL cp_fm_get_submatrix(src_imag, src_i)
|
||||
dst_r(:, :) = 0.0_dp
|
||||
dst_i(:, :) = 0.0_dp
|
||||
|
||||
IF (isym == -1) THEN
|
||||
dst_r(1:nao, 1:nmo) = src_r(1:nao, 1:nmo)
|
||||
dst_i(1:nao, 1:nmo) = -src_i(1:nao, 1:nmo)
|
||||
CALL cp_fm_set_submatrix(dst_real, dst_r)
|
||||
CALL cp_fm_set_submatrix(dst_imag, dst_i)
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
success = .TRUE.
|
||||
RETURN
|
||||
END IF
|
||||
|
||||
IF (.NOT. ASSOCIATED(qs_kpoint%kp_sym)) THEN
|
||||
reason = "SCF symmetry operation data are not available"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
kpsym => qs_kpoint%kp_sym(ikred)%kpoint_sym
|
||||
IF (.NOT. ASSOCIATED(kpsym)) THEN
|
||||
reason = "SCF k-point symmetry operation is not available"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
IF (isym > kpsym%nwred) THEN
|
||||
reason = "SCF k-point symmetry operation index is out of range"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
IF (.NOT. ASSOCIATED(qs_kpoint%atype) .OR. .NOT. ASSOCIATED(qs_kpoint%kind_rotmat)) THEN
|
||||
reason = "SCF atom mappings or basis rotation matrices are not available"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
|
||||
rot_slot = find_wannier90_rotation_slot(qs_kpoint, kpsym%rotp(isym))
|
||||
IF (rot_slot == 0) THEN
|
||||
reason = "could not match the SCF symmetry operation to a basis rotation"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i)
|
||||
RETURN
|
||||
END IF
|
||||
kind_rot => qs_kpoint%kind_rotmat(rot_slot, :)
|
||||
natom = SIZE(qs_kpoint%atype)
|
||||
ALLOCATE (ao_start(natom), ao_size(natom))
|
||||
irow = 1
|
||||
DO iatom = 1, natom
|
||||
ikind = qs_kpoint%atype(iatom)
|
||||
IF (.NOT. ASSOCIATED(kind_rot(ikind)%rmat)) THEN
|
||||
reason = "a required basis rotation matrix is not available"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size)
|
||||
RETURN
|
||||
END IF
|
||||
ao_start(iatom) = irow
|
||||
ao_size(iatom) = SIZE(kind_rot(ikind)%rmat, 2)
|
||||
irow = irow + ao_size(iatom)
|
||||
END DO
|
||||
IF (irow - 1 /= nao) THEN
|
||||
reason = "atom-resolved AO dimensions do not match the MO coefficient matrix"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size)
|
||||
RETURN
|
||||
END IF
|
||||
|
||||
time_reversal = kpsym%rotp(isym) < 0
|
||||
reverse_phase = qs_kpoint%gamma_centered .AND. ANY(MOD(qs_kpoint%nkp_grid, 2) == 0)
|
||||
IF (ASSOCIATED(kpsym%phase_mode)) THEN
|
||||
IF (kpsym%phase_mode(isym) > 0) reverse_phase = kpsym%phase_mode(isym) == 2
|
||||
END IF
|
||||
xkp_phase(1:3) = kpsym%xkp(1:3, isym)
|
||||
DO iatom = 1, natom
|
||||
source_atom = iatom
|
||||
target_atom = kpsym%f0(iatom, isym)
|
||||
ikind = qs_kpoint%atype(source_atom)
|
||||
rotmat => kind_rot(ikind)%rmat
|
||||
source_dim = ao_size(source_atom)
|
||||
target_dim = ao_size(target_atom)
|
||||
IF (SIZE(rotmat, 1) /= target_dim .OR. SIZE(rotmat, 2) /= source_dim) THEN
|
||||
reason = "basis rotation dimensions do not match the atom/AO symmetry transform"
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size)
|
||||
RETURN
|
||||
END IF
|
||||
arg = REAL(kpsym%fcell_gauge(1, source_atom, isym), KIND=dp)*xkp_phase(1) + &
|
||||
REAL(kpsym%fcell_gauge(2, source_atom, isym), KIND=dp)*xkp_phase(2) + &
|
||||
REAL(kpsym%fcell_gauge(3, source_atom, isym), KIND=dp)*xkp_phase(3)
|
||||
IF (ASSOCIATED(kpsym%kgphase)) THEN
|
||||
arg = arg + kpsym%kgphase(source_atom, isym)
|
||||
END IF
|
||||
IF (reverse_phase) arg = -arg
|
||||
coskl = COS(twopi*arg)
|
||||
sinkl = SIN(twopi*arg)
|
||||
DO imo = 1, nmo
|
||||
DO irow_work = 1, source_dim
|
||||
irow_source = ao_start(source_atom) + irow_work - 1
|
||||
coeff_real = src_r(irow_source, imo)
|
||||
coeff_imag = src_i(irow_source, imo)
|
||||
IF (time_reversal) coeff_imag = -coeff_imag
|
||||
phase_real = coskl*coeff_real - sinkl*coeff_imag
|
||||
phase_imag = sinkl*coeff_real + coskl*coeff_imag
|
||||
DO iao = 1, target_dim
|
||||
irow_target = ao_start(target_atom) + iao - 1
|
||||
dst_r(irow_target, imo) = dst_r(irow_target, imo) + &
|
||||
rotmat(iao, irow_work)*phase_real
|
||||
dst_i(irow_target, imo) = dst_i(irow_target, imo) + &
|
||||
rotmat(iao, irow_work)*phase_imag
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
|
||||
CALL cp_fm_set_submatrix(dst_real, dst_r)
|
||||
CALL cp_fm_set_submatrix(dst_imag, dst_i)
|
||||
DEALLOCATE (src_r, src_i, dst_r, dst_i, ao_start, ao_size)
|
||||
success = .TRUE.
|
||||
|
||||
END SUBROUTINE transform_wannier90_scf_mo
|
||||
|
||||
! **************************************************************************************************
|
||||
!> \brief Locate the basis-rotation slot corresponding to a signed k-point symmetry operation.
|
||||
!> \param qs_kpoint SCF k-point object
|
||||
!> \param rotp signed operation identifier
|
||||
!> \return rotation slot, or zero when no slot matches
|
||||
! **************************************************************************************************
|
||||
INTEGER FUNCTION find_wannier90_rotation_slot(qs_kpoint, rotp) RESULT(rot_slot)
|
||||
TYPE(kpoint_type), POINTER :: qs_kpoint
|
||||
INTEGER, INTENT(IN) :: rotp
|
||||
|
||||
INTEGER :: irot, rot_abs
|
||||
|
||||
rot_slot = 0
|
||||
rot_abs = ABS(rotp)
|
||||
IF (.NOT. ASSOCIATED(qs_kpoint%ibrot)) RETURN
|
||||
DO irot = 1, SIZE(qs_kpoint%ibrot)
|
||||
IF (rot_abs == qs_kpoint%ibrot(irot)) THEN
|
||||
rot_slot = irot
|
||||
RETURN
|
||||
END IF
|
||||
END DO
|
||||
|
||||
END FUNCTION find_wannier90_rotation_slot
|
||||
|
||||
! **************************************************************************************************
|
||||
!> \brief Infer a tensor-product Wannier90 mesh from explicit fractional k-point coordinates.
|
||||
!> \param kpt_latt explicit k-point coordinates in reciprocal-lattice units
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue