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 2580 : 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 2580 : TYPE(orbrotmat_type), DIMENSION(:), POINTER :: orbrot
66 : TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter
67 2580 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
68 :
69 0 : CPASSERT(ASSOCIATED(qs_env))
70 2580 : CPASSERT(ASSOCIATED(kpoints))
71 2580 : IF (PRESENT(basis_type)) THEN
72 12 : my_basis = basis_type
73 : ELSE
74 2568 : my_basis = "ORB"
75 : END IF
76 2580 : IF (ASSOCIATED(kpoints%kind_rotmat)) THEN
77 2428 : CALL get_qs_env(qs_env, cell=cell)
78 2428 : CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set)
79 2428 : CALL get_qs_kind_set(qs_kind_set, maxlgto=lval)
80 2428 : nrot = SIZE(kpoints%kind_rotmat, 1)
81 2428 : nkind = SIZE(kpoints%kind_rotmat, 2)
82 : ! remove possible old rotation matrices
83 24192 : DO irot = 1, nrot
84 46030 : DO ikind = 1, nkind
85 43602 : 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 2428 : NULLIFY (orbrot)
92 2428 : CALL get_qs_env(qs_env, dft_control=dft_control)
93 10714 : DO ik = 1, kpoints%nkp
94 8286 : kpsym => kpoints%kp_sym(ik)%kpoint_sym
95 10714 : IF (kpsym%apply_symmetry) THEN
96 95074 : DO irot = 1, SIZE(kpsym%rotp)
97 94408 : ir = ABS(kpsym%rotp(irot))
98 94408 : ira = 0
99 17506620 : DO jr = 1, SIZE(kpoints%ibrot)
100 17506620 : IF (ir == kpoints%ibrot(jr)) ira = jr
101 : END DO
102 95074 : IF (ira > 0) THEN
103 94408 : IF (.NOT. ASSOCIATED(kpoints%kind_rotmat(ira, 1)%rmat)) THEN
104 275366 : rotmat(1:3, 1:3) = kpsym%rot(1:3, 1:3, irot)
105 21182 : CALL calculate_rotmat(orbrot, rotmat, lval)
106 21182 : IF (dft_control%qs_control%method_id == do_method_dftb) THEN
107 4776 : DO ikind = 1, nkind
108 2416 : CALL get_qs_kind(qs_kind_set(ikind), dftb_parameter=dftb_parameter)
109 2416 : NULLIFY (kpoints%kind_rotmat(ira, ikind)%rmat)
110 : CALL set_rotmat_dftb(kpoints%kind_rotmat(ira, ikind)%rmat, &
111 4776 : orbrot, dftb_parameter)
112 : END DO
113 : ELSE
114 37662 : DO ikind = 1, nkind
115 18840 : CALL get_qs_kind(qs_kind_set(ikind), basis_set=orb_basis, basis_type=my_basis)
116 18840 : NULLIFY (kpoints%kind_rotmat(ira, ikind)%rmat)
117 37662 : CALL set_rotmat_basis(kpoints%kind_rotmat(ira, ikind)%rmat, orbrot, orb_basis)
118 : END DO
119 : END IF
120 : END IF
121 : END IF
122 : END DO
123 : END IF
124 : END DO
125 2428 : CALL release_rotmat(orbrot)
126 : END IF
127 :
128 2580 : END SUBROUTINE qs_basis_rotation
129 :
130 : ! **************************************************************************************************
131 : !> \brief Construct DFTB basis-set rotation matrices
132 : !> \param rmat ...
133 : !> \param orbrot ...
134 : !> \param dftb_parameter ...
135 : ! **************************************************************************************************
136 2416 : SUBROUTINE set_rotmat_dftb(rmat, orbrot, dftb_parameter)
137 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: rmat
138 : TYPE(orbrotmat_type), DIMENSION(:), POINTER :: orbrot
139 : TYPE(qs_dftb_atom_type), POINTER :: dftb_parameter
140 :
141 : INTEGER :: first, i, j, l, lmax, n, natorb
142 : INTEGER, DIMENSION(5) :: perm
143 : LOGICAL :: defined
144 :
145 2416 : CALL get_dftb_atom_param(dftb_parameter, defined=defined, lmax=lmax, natorb=natorb)
146 2416 : CPASSERT(defined)
147 :
148 9664 : ALLOCATE (rmat(natorb, natorb))
149 131072 : rmat = 0.0_dp
150 :
151 2416 : first = 1
152 8360 : DO l = 0, lmax
153 5944 : n = nso(l)
154 2416 : SELECT CASE (l)
155 : CASE (0)
156 2416 : perm(1) = 1
157 : CASE (1)
158 9472 : perm(1:3) = [3, 1, 2]
159 : CASE (2)
160 1160 : perm(1:5) = [1, 2, 4, 5, 3]
161 : CASE DEFAULT
162 : CALL cp_abort(__LOCATION__, &
163 5944 : "DFTB k-point symmetry is implemented for basis functions up to d orbitals")
164 : END SELECT
165 21264 : DO i = 1, n
166 73992 : DO j = 1, n
167 68048 : rmat(first + i - 1, first + j - 1) = orbrot(l)%mat(perm(i), perm(j))
168 : END DO
169 : END DO
170 8360 : first = first + n
171 : END DO
172 2416 : CPASSERT(first == natorb + 1)
173 :
174 2416 : END SUBROUTINE set_rotmat_dftb
175 :
176 : ! **************************************************************************************************
177 : !> \brief ...
178 : !> \param rmat ...
179 : !> \param orbrot ...
180 : !> \param basis ...
181 : ! **************************************************************************************************
182 18840 : SUBROUTINE set_rotmat_basis(rmat, orbrot, basis)
183 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: rmat
184 : TYPE(orbrotmat_type), DIMENSION(:), POINTER :: orbrot
185 : TYPE(gto_basis_set_type), POINTER :: basis
186 :
187 : INTEGER :: fs1, fs2, iset, ishell, l, nset, nsgf
188 18840 : INTEGER, DIMENSION(:), POINTER :: nshell
189 18840 : INTEGER, DIMENSION(:, :), POINTER :: first_sgf, lshell
190 :
191 18840 : CALL get_gto_basis_set(gto_basis_set=basis, nsgf=nsgf)
192 75360 : ALLOCATE (rmat(nsgf, nsgf))
193 1617112 : rmat = 0.0_dp
194 :
195 : CALL get_gto_basis_set(gto_basis_set=basis, nset=nset, nshell=nshell, l=lshell, &
196 18840 : first_sgf=first_sgf)
197 55632 : DO iset = 1, nset
198 118050 : DO ishell = 1, nshell(iset)
199 62418 : l = lshell(ishell, iset)
200 62418 : fs1 = first_sgf(ishell, iset)
201 62418 : fs2 = fs1 + nso(l) - 1
202 735386 : rmat(fs1:fs2, fs1:fs2) = orbrot(l)%mat(1:nso(l), 1:nso(l))
203 : END DO
204 : END DO
205 :
206 37680 : END SUBROUTINE set_rotmat_basis
207 :
208 : END MODULE qs_basis_rotation_methods
|
