diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a31daadb31..89417a3cf5 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -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 diff --git a/src/kpoint_mo_symmetry_methods.F b/src/kpoint_mo_symmetry_methods.F new file mode 100644 index 0000000000..3483dc7889 --- /dev/null +++ b/src/kpoint_mo_symmetry_methods.F @@ -0,0 +1,238 @@ +!--------------------------------------------------------------------------------------------------! +! CP2K: A general program to perform molecular dynamics simulations ! +! Copyright 2000-2026 CP2K developers group ! +! ! +! 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 diff --git a/src/qs_wannier90.F b/src/qs_wannier90.F index 33d326aeec..ad9bb42de0 100644 --- a/src/qs_wannier90.F +++ b/src/qs_wannier90.F @@ -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