Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : MODULE qs_basis_rotation_methods
10 : USE basis_set_types, ONLY: get_gto_basis_set,&
11 : gto_basis_set_type
12 : USE cell_types, ONLY: cell_type
13 : USE cp_control_types, ONLY: dft_control_type
14 : USE input_constants, ONLY: do_method_dftb
15 : USE kinds, ONLY: dp
16 : USE kpoint_types, ONLY: kpoint_sym_type,&
17 : kpoint_type
18 : USE orbital_pointers, ONLY: nso
19 : USE orbital_transformation_matrices, ONLY: calculate_rotmat,&
20 : orbrotmat_type,&
21 : release_rotmat
22 : USE qs_dftb_types, ONLY: qs_dftb_atom_type
23 : USE qs_dftb_utils, ONLY: get_dftb_atom_param
24 : USE qs_environment_types, ONLY: get_qs_env,&
25 : qs_environment_type
26 : USE qs_kind_types, ONLY: get_qs_kind,&
27 : get_qs_kind_set,&
28 : qs_kind_type
29 : #include "./base/base_uses.f90"
30 :
31 : IMPLICIT NONE
32 :
33 : PRIVATE
34 :
35 : ! Global parameters (only in this module)
36 :
37 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_basis_rotation_methods'
38 :
39 : ! Public subroutines
40 :
41 : PUBLIC :: qs_basis_rotation
42 :
43 : CONTAINS
44 :
45 : ! **************************************************************************************************
46 : !> \brief Construct basis set rotation matrices
47 : !> \param qs_env ...
48 : !> \param kpoints ...
49 : !> \param basis_type ...
50 : ! **************************************************************************************************
51 1088 : SUBROUTINE qs_basis_rotation(qs_env, kpoints, basis_type)
52 :
53 : TYPE(qs_environment_type), POINTER :: qs_env
54 : TYPE(kpoint_type), POINTER :: kpoints
55 : CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: basis_type
56 :
57 : CHARACTER(LEN=12) :: my_basis
58 : INTEGER :: ik, ikind, ir, ira, irot, jr, lval, &
59 : nkind, nrot
60 : REAL(KIND=dp), DIMENSION(3, 3) :: rotmat
61 : TYPE(cell_type), POINTER :: cell
62 : TYPE(dft_control_type), POINTER :: dft_control
63 : TYPE(gto_basis_set_type), POINTER :: orb_basis
64 : TYPE(kpoint_sym_type), POINTER :: kpsym
65 1088 : TYPE(orbrotmat_type), DIMENSION(:), POINTER :: orbrot
66 : TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter
67 1088 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
68 :
69 0 : CPASSERT(ASSOCIATED(qs_env))
70 1088 : CPASSERT(ASSOCIATED(kpoints))
71 1088 : IF (PRESENT(basis_type)) THEN
72 12 : my_basis = basis_type
73 : ELSE
74 1076 : my_basis = "ORB"
75 : END IF
76 1088 : IF (ASSOCIATED(kpoints%kind_rotmat)) THEN
77 950 : CALL get_qs_env(qs_env, cell=cell)
78 950 : CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set)
79 950 : CALL get_qs_kind_set(qs_kind_set, maxlgto=lval)
80 950 : nrot = SIZE(kpoints%kind_rotmat, 1)
81 950 : nkind = SIZE(kpoints%kind_rotmat, 2)
82 : ! remove possible old rotation matrices
83 6626 : DO irot = 1, nrot
84 12326 : DO ikind = 1, nkind
85 11376 : IF (ASSOCIATED(kpoints%kind_rotmat(irot, ikind)%rmat)) THEN
86 0 : DEALLOCATE (kpoints%kind_rotmat(irot, ikind)%rmat)
87 : END IF
88 : END DO
89 : END DO
90 : ! check all rotations needed
91 950 : NULLIFY (orbrot)
92 950 : CALL get_qs_env(qs_env, dft_control=dft_control)
93 5896 : DO ik = 1, kpoints%nkp
94 4946 : kpsym => kpoints%kp_sym(ik)%kpoint_sym
95 5896 : IF (kpsym%apply_symmetry) THEN
96 2950 : DO irot = 1, SIZE(kpsym%rotp)
97 2652 : ir = ABS(kpsym%rotp(irot))
98 2652 : ira = 0
99 202248 : DO jr = 1, SIZE(kpoints%ibrot)
100 202248 : IF (ir == kpoints%ibrot(jr)) ira = jr
101 : END DO
102 2950 : IF (ira > 0) THEN
103 2652 : IF (.NOT. ASSOCIATED(kpoints%kind_rotmat(ira, 1)%rmat)) THEN
104 568 : rotmat(1:3, 1:3) = MATMUL(cell%h_inv, &
105 115872 : MATMUL(kpsym%rot(:, :, irot), cell%hmat))
106 568 : CALL calculate_rotmat(orbrot, rotmat, lval)
107 568 : IF (dft_control%qs_control%method_id == do_method_dftb) THEN
108 364 : DO ikind = 1, nkind
109 192 : CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_parameter)
110 192 : NULLIFY (kpoints%kind_rotmat(ira, ikind)%rmat)
111 : CALL set_rotmat_dftb(kpoints%kind_rotmat(ira, ikind)%rmat, &
112 364 : orbrot, dftb_parameter)
113 : END DO
114 : ELSE
115 792 : DO ikind = 1, nkind
116 396 : CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis, basis_type=my_basis)
117 396 : NULLIFY (kpoints%kind_rotmat(ira, ikind)%rmat)
118 792 : CALL set_rotmat_basis(kpoints%kind_rotmat(ira, ikind)%rmat, orbrot, orb_basis)
119 : END DO
120 : END IF
121 : END IF
122 : END IF
123 : END DO
124 : END IF
125 : END DO
126 950 : CALL release_rotmat(orbrot)
127 : END IF
128 :
129 1088 : END SUBROUTINE qs_basis_rotation
130 :
131 : ! **************************************************************************************************
132 : !> \brief Construct DFTB basis-set rotation matrices
133 : !> \param rmat ...
134 : !> \param orbrot ...
135 : !> \param dftb_parameter ...
136 : ! **************************************************************************************************
137 192 : SUBROUTINE set_rotmat_dftb(rmat, orbrot, dftb_parameter)
138 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: rmat
139 : TYPE(orbrotmat_type), DIMENSION(:), POINTER :: orbrot
140 : TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter
141 :
142 : INTEGER :: first, i, j, l, lmax, n, natorb
143 : INTEGER, DIMENSION(5) :: perm
144 : LOGICAL :: defined
145 :
146 192 : CALL get_dftb_atom_param(dftb_parameter, defined=defined, lmax=lmax, natorb=natorb)
147 192 : CPASSERT(defined)
148 :
149 768 : ALLOCATE (rmat(natorb, natorb))
150 9344 : rmat = 0.0_dp
151 :
152 192 : first = 1
153 640 : DO l = 0, lmax
154 448 : n = nso(l)
155 192 : SELECT CASE (l)
156 : CASE (0)
157 192 : perm(1) = 1
158 : CASE (1)
159 704 : perm(1:3) = [3, 1, 2]
160 : CASE (2)
161 80 : perm(1:5) = [1, 2, 4, 5, 3]
162 : CASE DEFAULT
163 : CALL cp_abort(__LOCATION__, &
164 448 : "DFTB k-point symmetry is implemented for basis functions up to d orbitals")
165 : END SELECT
166 1568 : DO i = 1, n
167 5344 : DO j = 1, n
168 4896 : rmat(first + i - 1, first + j - 1) = orbrot(l)%mat(perm(i), perm(j))
169 : END DO
170 : END DO
171 640 : first = first + n
172 : END DO
173 192 : CPASSERT(first == natorb + 1)
174 :
175 192 : END SUBROUTINE set_rotmat_dftb
176 :
177 : ! **************************************************************************************************
178 : !> \brief ...
179 : !> \param rmat ...
180 : !> \param orbrot ...
181 : !> \param basis ...
182 : ! **************************************************************************************************
183 396 : SUBROUTINE set_rotmat_basis(rmat, orbrot, basis)
184 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: rmat
185 : TYPE(orbrotmat_type), DIMENSION(:), POINTER :: orbrot
186 : TYPE(gto_basis_set_type), POINTER :: basis
187 :
188 : INTEGER :: fs1, fs2, iset, ishell, l, nset, nsgf
189 396 : INTEGER, DIMENSION(:), POINTER :: nshell
190 396 : INTEGER, DIMENSION(:, :), POINTER :: first_sgf, lshell
191 :
192 396 : CALL get_gto_basis_set(gto_basis_set=basis, nsgf=nsgf)
193 1584 : ALLOCATE (rmat(nsgf, nsgf))
194 29944 : rmat = 0.0_dp
195 :
196 : CALL get_gto_basis_set(gto_basis_set=basis, nset=nset, nshell=nshell, l=lshell, &
197 396 : first_sgf=first_sgf)
198 1392 : DO iset = 1, nset
199 2462 : DO ishell = 1, nshell(iset)
200 1070 : l = lshell(ishell, iset)
201 1070 : fs1 = first_sgf(ishell, iset)
202 1070 : fs2 = fs1 + nso(l) - 1
203 15202 : rmat(fs1:fs2, fs1:fs2) = orbrot(l)%mat(1:nso(l), 1:nso(l))
204 : END DO
205 : END DO
206 :
207 792 : END SUBROUTINE set_rotmat_basis
208 :
209 568 : END MODULE qs_basis_rotation_methods
|
