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 : !> \brief AO-based conjugate-gradient response solver routines
10 : !>
11 : !>
12 : !> \date 09.2019
13 : !> \author Fabian Belleflamme
14 : ! **************************************************************************************************
15 : MODULE ec_orth_solver
16 : USE admm_types, ONLY: admm_type,&
17 : get_admm_env
18 : USE cp_control_types, ONLY: dft_control_type
19 : USE cp_dbcsr_api, ONLY: &
20 : dbcsr_add, dbcsr_copy, dbcsr_create, dbcsr_desymmetrize, dbcsr_filter, dbcsr_finalize, &
21 : dbcsr_get_info, dbcsr_multiply, dbcsr_p_type, dbcsr_release, dbcsr_scale, dbcsr_set, &
22 : dbcsr_transposed, dbcsr_type, dbcsr_type_no_symmetry
23 : USE cp_dbcsr_contrib, ONLY: dbcsr_add_on_diag,&
24 : dbcsr_checksum,&
25 : dbcsr_dot
26 : USE cp_dbcsr_operations, ONLY: dbcsr_allocate_matrix_set,&
27 : dbcsr_deallocate_matrix_set
28 : USE cp_external_control, ONLY: external_control
29 : USE ec_methods, ONLY: create_kernel
30 : USE input_constants, ONLY: do_admm_aux_exch_func_none,&
31 : kg_tnadd_embed,&
32 : kg_tnadd_embed_ri,&
33 : ls_s_sqrt_ns,&
34 : ls_s_sqrt_proot,&
35 : precond_mlp
36 : USE input_section_types, ONLY: section_vals_get_subs_vals,&
37 : section_vals_type,&
38 : section_vals_val_get
39 : USE iterate_matrix, ONLY: matrix_sqrt_Newton_Schulz,&
40 : matrix_sqrt_proot
41 : USE kg_correction, ONLY: kg_ekin_subset
42 : USE kinds, ONLY: dp
43 : USE machine, ONLY: m_flush,&
44 : m_walltime
45 : USE mathlib, ONLY: abnormal_value
46 : USE message_passing, ONLY: mp_para_env_type
47 : USE pw_env_types, ONLY: pw_env_get,&
48 : pw_env_type
49 : USE pw_methods, ONLY: pw_axpy,&
50 : pw_scale,&
51 : pw_transfer,&
52 : pw_zero
53 : USE pw_poisson_methods, ONLY: pw_poisson_solve
54 : USE pw_poisson_types, ONLY: pw_poisson_type
55 : USE pw_pool_types, ONLY: pw_pool_p_type,&
56 : pw_pool_type
57 : USE pw_types, ONLY: pw_c1d_gs_type,&
58 : pw_r3d_rs_type
59 : USE qs_environment_types, ONLY: get_qs_env,&
60 : qs_environment_type
61 : USE qs_integrate_potential, ONLY: integrate_v_rspace
62 : USE qs_kpp1_env_types, ONLY: qs_kpp1_env_type
63 : USE qs_linres_kernel, ONLY: apply_hfx,&
64 : apply_xc_admm
65 : USE qs_linres_types, ONLY: linres_control_type
66 : USE qs_p_env_methods, ONLY: p_env_check_i_alloc,&
67 : p_env_finish_kpp1,&
68 : p_env_update_rho
69 : USE qs_p_env_types, ONLY: qs_p_env_type
70 : USE qs_rho_types, ONLY: qs_rho_get,&
71 : qs_rho_type
72 : USE xc, ONLY: xc_prep_2nd_deriv
73 : #include "./base/base_uses.f90"
74 :
75 : IMPLICIT NONE
76 :
77 : PRIVATE
78 :
79 : ! Global parameters
80 :
81 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'ec_orth_solver'
82 :
83 : ! Public subroutines
84 :
85 : PUBLIC :: ec_response_ao
86 :
87 : CONTAINS
88 :
89 : ! **************************************************************************************************
90 : !> \brief Preconditioning of the AO-based CG linear response solver
91 : !> M * z_0 = r_0
92 : !> M(X) = [F,B], with B = [X,P]
93 : !> for M we need F and P in ortho basis
94 : !> Returns z_0, the preconditioned residual in orthonormal basis
95 : !>
96 : !> All matrices are in orthonormal Lowdin basis
97 : !>
98 : !> \param qs_env ...
99 : !> \param matrix_ks Ground-state Kohn-Sham matrix
100 : !> \param matrix_p Ground-state Density matrix
101 : !> \param matrix_rhs Unpreconditioned residual of linear response CG
102 : !> \param matrix_cg_z Preconditioned residual
103 : !> \param eps_filter ...
104 : !> \param iounit ...
105 : !>
106 : !> \param silent ...
107 : !> \date 01.2020
108 : !> \author Fabian Belleflamme
109 : ! **************************************************************************************************
110 572 : SUBROUTINE ec_preconditioner(qs_env, matrix_ks, matrix_p, matrix_rhs, &
111 : matrix_cg_z, eps_filter, iounit, silent)
112 :
113 : TYPE(qs_environment_type), POINTER :: qs_env
114 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
115 : POINTER :: matrix_ks, matrix_p, matrix_rhs
116 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(INOUT), &
117 : POINTER :: matrix_cg_z
118 : REAL(KIND=dp), INTENT(IN) :: eps_filter
119 : INTEGER, INTENT(IN) :: iounit
120 : LOGICAL, INTENT(IN), OPTIONAL :: silent
121 :
122 : CHARACTER(len=*), PARAMETER :: routineN = 'ec_preconditioner'
123 :
124 : INTEGER :: handle, i, ispin, max_iter, nao, nspins
125 : LOGICAL :: converged, my_silent
126 : REAL(KIND=dp) :: norm_res, t1, t2
127 572 : REAL(KIND=dp), DIMENSION(:), POINTER :: alpha, beta, new_norm, norm_cA, norm_rr
128 572 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_Ax, matrix_b, matrix_cg, &
129 572 : matrix_res
130 : TYPE(dft_control_type), POINTER :: dft_control
131 : TYPE(linres_control_type), POINTER :: linres_control
132 :
133 572 : CALL timeset(routineN, handle)
134 :
135 572 : my_silent = .FALSE.
136 572 : IF (PRESENT(silent)) my_silent = silent
137 :
138 572 : CPASSERT(ASSOCIATED(qs_env))
139 572 : CPASSERT(ASSOCIATED(matrix_ks))
140 572 : CPASSERT(ASSOCIATED(matrix_p))
141 572 : CPASSERT(ASSOCIATED(matrix_rhs))
142 572 : CPASSERT(ASSOCIATED(matrix_cg_z))
143 :
144 572 : NULLIFY (dft_control, linres_control)
145 :
146 572 : t1 = m_walltime()
147 :
148 : CALL get_qs_env(qs_env=qs_env, &
149 : dft_control=dft_control, &
150 572 : linres_control=linres_control)
151 572 : nspins = dft_control%nspins
152 572 : CALL dbcsr_get_info(matrix_ks(1)%matrix, nfullrows_total=nao)
153 :
154 4004 : ALLOCATE (alpha(nspins), beta(nspins), new_norm(nspins), norm_cA(nspins), norm_rr(nspins))
155 :
156 : !----------------------------------------
157 : ! Create non-symmetric matrices: Ax, B, cg, res
158 : !----------------------------------------
159 :
160 572 : NULLIFY (matrix_Ax, matrix_b, matrix_cg, matrix_res)
161 572 : CALL dbcsr_allocate_matrix_set(matrix_Ax, nspins)
162 572 : CALL dbcsr_allocate_matrix_set(matrix_b, nspins)
163 572 : CALL dbcsr_allocate_matrix_set(matrix_cg, nspins)
164 572 : CALL dbcsr_allocate_matrix_set(matrix_res, nspins)
165 :
166 1144 : DO ispin = 1, nspins
167 572 : ALLOCATE (matrix_Ax(ispin)%matrix)
168 572 : ALLOCATE (matrix_b(ispin)%matrix)
169 572 : ALLOCATE (matrix_cg(ispin)%matrix)
170 572 : ALLOCATE (matrix_res(ispin)%matrix)
171 : CALL dbcsr_create(matrix_Ax(ispin)%matrix, name="linop MATRIX", &
172 : template=matrix_ks(1)%matrix, &
173 572 : matrix_type=dbcsr_type_no_symmetry)
174 : CALL dbcsr_create(matrix_b(ispin)%matrix, name="MATRIX B", &
175 : template=matrix_ks(1)%matrix, &
176 572 : matrix_type=dbcsr_type_no_symmetry)
177 : CALL dbcsr_create(matrix_cg(ispin)%matrix, name="TRIAL MATRIX", &
178 : template=matrix_ks(1)%matrix, &
179 572 : matrix_type=dbcsr_type_no_symmetry)
180 : CALL dbcsr_create(matrix_res(ispin)%matrix, name="RESIDUE", &
181 : template=matrix_ks(1)%matrix, &
182 1144 : matrix_type=dbcsr_type_no_symmetry)
183 : END DO
184 :
185 : !----------------------------------------
186 : ! Get righ-hand-side operators
187 : !----------------------------------------
188 :
189 : ! Initial guess z_0
190 1144 : DO ispin = 1, nspins
191 572 : CALL dbcsr_copy(matrix_cg_z(ispin)%matrix, matrix_rhs(ispin)%matrix)
192 :
193 : ! r_0 = b
194 1144 : CALL dbcsr_copy(matrix_res(ispin)%matrix, matrix_rhs(ispin)%matrix)
195 : END DO
196 :
197 : ! Projector on trial matrix
198 : ! Projector does not need to be applied here,
199 : ! as matrix_rhs already had this done before entering preconditioner
200 : !CALL projector(qs_env, matrix_p, matrix_cg_z, eps_filter)
201 :
202 : ! Mz_0
203 572 : CALL hessian_op1(matrix_ks, matrix_p, matrix_cg_z, matrix_b, matrix_Ax, eps_filter)
204 :
205 : ! r_0 = b - Ax_0
206 1144 : DO ispin = 1, nspins
207 1144 : CALL dbcsr_add(matrix_res(ispin)%matrix, matrix_Ax(ispin)%matrix, 1.0_dp, -1.0_dp)
208 : END DO
209 :
210 : ! Matrix projector T
211 572 : CALL projector(qs_env, matrix_p, matrix_res, eps_filter)
212 :
213 1144 : DO ispin = 1, nspins
214 : ! cg = p_0 = z_0
215 1144 : CALL dbcsr_copy(matrix_cg(ispin)%matrix, matrix_res(ispin)%matrix)
216 : END DO
217 :
218 : ! header
219 572 : IF (iounit > 0 .AND. .NOT. my_silent) THEN
220 286 : WRITE (iounit, "(/,T10,A)") "Preconditioning of search direction"
221 : WRITE (iounit, "(/,T10,A,T25,A,T42,A,T62,A,/,T10,A)") &
222 286 : "Iteration", "Stepsize", "Convergence", "Time", &
223 572 : REPEAT("-", 58)
224 : END IF
225 :
226 1144 : alpha(:) = 0.0_dp
227 572 : max_iter = 200
228 572 : converged = .FALSE.
229 572 : norm_res = 0.0_dp
230 :
231 : ! start iteration
232 3062 : iteration: DO i = 1, max_iter
233 :
234 : ! Hessian Ax = [F,B] is updated preconditioner
235 3062 : CALL hessian_op1(matrix_ks, matrix_p, matrix_cg, matrix_b, matrix_Ax, eps_filter)
236 :
237 : ! Matrix projector
238 3062 : CALL projector(qs_env, matrix_p, matrix_Ax, eps_filter)
239 :
240 6124 : DO ispin = 1, nspins
241 :
242 : ! Tr(r_0 * r_0)
243 3062 : CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, norm_rr(ispin))
244 3062 : IF (abnormal_value(norm_rr(ispin))) &
245 0 : CPABORT("Preconditioner: Tr[r_j*r_j] is an abnormal value (NaN/Inf)")
246 :
247 3062 : IF (norm_rr(ispin) < 0.0_dp) CPABORT("norm_rr < 0")
248 3062 : norm_res = MAX(norm_res, ABS(norm_rr(ispin)/REAL(nao, dp)))
249 :
250 : ! norm_cA = tr(Ap_j * p_j)
251 3062 : CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin))
252 :
253 : ! Determine step-size
254 3062 : IF (norm_cA(ispin) < linres_control%eps) THEN
255 30 : alpha(ispin) = 1.0_dp
256 : ELSE
257 3032 : alpha(ispin) = norm_rr(ispin)/norm_cA(ispin)
258 : END IF
259 :
260 : ! x_j+1 = x_j + alpha*p_j
261 : ! save contribution of this iteration
262 3062 : CALL dbcsr_add(matrix_cg_z(ispin)%matrix, matrix_cg(ispin)%matrix, 1.0_dp, alpha(ispin))
263 :
264 : ! r_j+1 = r_j - alpha * Ap_j
265 6124 : CALL dbcsr_add(matrix_res(ispin)%matrix, matrix_Ax(ispin)%matrix, 1.0_dp, -alpha(ispin))
266 :
267 : END DO
268 :
269 3062 : norm_res = 0.0_dp
270 :
271 6124 : DO ispin = 1, nspins
272 : ! Tr[r_j+1*z_j+1]
273 3062 : CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, new_norm(ispin))
274 3062 : IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0")
275 3062 : IF (abnormal_value(new_norm(ispin))) &
276 0 : CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)")
277 3062 : norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp))
278 :
279 : IF (norm_rr(ispin) < linres_control%eps*0.001_dp &
280 3062 : .OR. new_norm(ispin) < linres_control%eps*0.001_dp) THEN
281 36 : beta(ispin) = 0.0_dp
282 36 : converged = .TRUE.
283 : ELSE
284 3026 : beta(ispin) = new_norm(ispin)/norm_rr(ispin)
285 : END IF
286 :
287 : ! update new search vector (matrix cg)
288 : ! cg_j+1 = z_j+1 + beta*cg_j
289 3062 : CALL dbcsr_add(matrix_cg(ispin)%matrix, matrix_res(ispin)%matrix, beta(ispin), 1.0_dp)
290 3062 : CALL dbcsr_filter(matrix_cg(ispin)%matrix, eps_filter)
291 :
292 6124 : norm_rr(ispin) = new_norm(ispin)
293 : END DO
294 :
295 : ! Convergence criteria
296 3062 : IF (norm_res < linres_control%eps) THEN
297 572 : converged = .TRUE.
298 : END IF
299 :
300 3062 : t2 = m_walltime()
301 : IF (i == 1 .OR. MOD(i, 1) == 0 .OR. converged) THEN
302 3062 : IF (iounit > 0 .AND. .NOT. my_silent) THEN
303 : WRITE (iounit, "(T10,I5,T25,1E8.2,T33,F25.14,T58,F8.2)") &
304 4593 : i, MAXVAL(alpha), norm_res, t2 - t1
305 : ! Convergence in scientific notation
306 : !WRITE (iounit, "(T10,I5,T25,1E8.2,T42,1E14.8,T58,F8.2)") &
307 : ! i, MAXVAL(alpha), norm_res, t2 - t1
308 1531 : CALL m_flush(iounit)
309 : END IF
310 : END IF
311 3062 : IF (converged) THEN
312 572 : IF (iounit > 0 .AND. .NOT. my_silent) THEN
313 286 : WRITE (iounit, "(/,T10,A,I4,A,/)") "The precon solver converged in ", i, " iterations."
314 286 : CALL m_flush(iounit)
315 : END IF
316 : EXIT iteration
317 : END IF
318 :
319 : ! Max number of iteration reached
320 2490 : IF (i == max_iter) THEN
321 0 : IF (iounit > 0) THEN
322 : WRITE (iounit, "(/,T10,A/)") &
323 0 : "The precon solver didnt converge! Maximum number of iterations reached."
324 0 : CALL m_flush(iounit)
325 : END IF
326 : converged = .FALSE.
327 : END IF
328 :
329 : END DO iteration
330 :
331 : ! Matrix projector
332 572 : CALL projector(qs_env, matrix_p, matrix_cg_z, eps_filter)
333 :
334 : ! Release matrices
335 572 : CALL dbcsr_deallocate_matrix_set(matrix_Ax)
336 572 : CALL dbcsr_deallocate_matrix_set(matrix_b)
337 572 : CALL dbcsr_deallocate_matrix_set(matrix_res)
338 572 : CALL dbcsr_deallocate_matrix_set(matrix_cg)
339 :
340 572 : DEALLOCATE (alpha, beta, new_norm, norm_cA, norm_rr)
341 :
342 572 : CALL timestop(handle)
343 :
344 1144 : END SUBROUTINE ec_preconditioner
345 :
346 : ! **************************************************************************************************
347 : !> \brief AO-based conjugate gradient linear response solver.
348 : !> In goes the right hand side B of the equation AZ=B, and the linear transformation of the
349 : !> Hessian matrix A on trial matrices is iteratively solved. Result are
350 : !> the response density matrix_pz, and the energy-weighted response density matrix_wz.
351 : !>
352 : !> \param qs_env ...
353 : !> \param p_env ...
354 : !> \param matrix_hz Right hand-side of linear response equation
355 : !> \param matrix_pz Response density
356 : !> \param matrix_wz Energy-weighted response density matrix
357 : !> \param iounit ...
358 : !> \param should_stop ...
359 : !>
360 : !> \param silent ...
361 : !> \date 01.2020
362 : !> \author Fabian Belleflamme
363 : ! **************************************************************************************************
364 132 : SUBROUTINE ec_response_ao(qs_env, p_env, matrix_hz, matrix_pz, matrix_wz, iounit, &
365 : should_stop, silent)
366 :
367 : TYPE(qs_environment_type), POINTER :: qs_env
368 : TYPE(qs_p_env_type), POINTER :: p_env
369 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
370 : POINTER :: matrix_hz
371 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(INOUT), &
372 : POINTER :: matrix_pz, matrix_wz
373 : INTEGER, INTENT(IN) :: iounit
374 : LOGICAL, INTENT(OUT) :: should_stop
375 : LOGICAL, INTENT(IN), OPTIONAL :: silent
376 :
377 : CHARACTER(len=*), PARAMETER :: routineN = 'ec_response_ao'
378 :
379 : INTEGER :: handle, i, ispin, max_iter_lanczos, nao, &
380 : nspins, s_sqrt_method, s_sqrt_order
381 : LOGICAL :: my_silent, restart
382 : REAL(KIND=dp) :: eps_filter, eps_lanczos, focc, &
383 : min_shift, norm_res, old_conv, shift, &
384 : t1, t2
385 132 : REAL(KIND=dp), DIMENSION(:), POINTER :: alpha, beta, new_norm, norm_cA, norm_rr, &
386 132 : tr_rz00
387 132 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: ksmat, matrix_Ax, matrix_cg, matrix_cg_z, &
388 132 : matrix_ks, matrix_nsc, matrix_p, matrix_res, matrix_s, matrix_z, matrix_z0, rho_ao
389 : TYPE(dbcsr_type) :: matrix_s_sqrt, matrix_s_sqrt_inv, &
390 : matrix_tmp
391 : TYPE(dft_control_type), POINTER :: dft_control
392 : TYPE(linres_control_type), POINTER :: linres_control
393 : TYPE(qs_rho_type), POINTER :: rho
394 : TYPE(section_vals_type), POINTER :: solver_section
395 :
396 132 : CALL timeset(routineN, handle)
397 :
398 132 : my_silent = .FALSE.
399 132 : IF (PRESENT(silent)) my_silent = silent
400 :
401 132 : CPASSERT(ASSOCIATED(qs_env))
402 132 : CPASSERT(ASSOCIATED(matrix_hz))
403 132 : CPASSERT(ASSOCIATED(matrix_pz))
404 132 : CPASSERT(ASSOCIATED(matrix_wz))
405 :
406 132 : NULLIFY (dft_control, ksmat, matrix_s, linres_control, rho)
407 :
408 132 : t1 = m_walltime()
409 :
410 : CALL get_qs_env(qs_env=qs_env, &
411 : dft_control=dft_control, &
412 : linres_control=linres_control, &
413 : matrix_ks=ksmat, &
414 : matrix_s=matrix_s, &
415 132 : rho=rho)
416 132 : nspins = dft_control%nspins
417 :
418 132 : CALL dbcsr_get_info(matrix_s(1)%matrix, nfullrows_total=nao)
419 :
420 132 : solver_section => section_vals_get_subs_vals(qs_env%input, "DFT%ENERGY_CORRECTION%RESPONSE_SOLVER")
421 132 : CALL section_vals_val_get(solver_section, "S_SQRT_METHOD", i_val=s_sqrt_method)
422 132 : CALL section_vals_val_get(solver_section, "S_SQRT_ORDER", i_val=s_sqrt_order)
423 132 : CALL section_vals_val_get(solver_section, "EPS_LANCZOS", r_val=eps_lanczos)
424 132 : CALL section_vals_val_get(solver_section, "MAX_ITER_LANCZOS", i_val=max_iter_lanczos)
425 :
426 132 : eps_filter = linres_control%eps_filter
427 :
428 132 : CALL qs_rho_get(rho, rho_ao=rho_ao)
429 :
430 924 : ALLOCATE (alpha(nspins), beta(nspins), new_norm(nspins), norm_cA(nspins), norm_rr(nspins))
431 264 : ALLOCATE (tr_rz00(nspins))
432 :
433 : ! local matrix P, KS, and NSC
434 : ! to bring into orthogonal basis
435 132 : NULLIFY (matrix_p, matrix_ks, matrix_nsc)
436 132 : CALL dbcsr_allocate_matrix_set(matrix_p, nspins)
437 132 : CALL dbcsr_allocate_matrix_set(matrix_ks, nspins)
438 132 : CALL dbcsr_allocate_matrix_set(matrix_nsc, nspins)
439 264 : DO ispin = 1, nspins
440 132 : ALLOCATE (matrix_p(ispin)%matrix)
441 132 : ALLOCATE (matrix_ks(ispin)%matrix)
442 132 : ALLOCATE (matrix_nsc(ispin)%matrix)
443 : CALL dbcsr_create(matrix_p(ispin)%matrix, name="P_IN ORTHO", &
444 : template=ksmat(1)%matrix, &
445 132 : matrix_type=dbcsr_type_no_symmetry)
446 : CALL dbcsr_create(matrix_ks(ispin)%matrix, name="KS_IN ORTHO", &
447 : template=ksmat(1)%matrix, &
448 132 : matrix_type=dbcsr_type_no_symmetry)
449 : CALL dbcsr_create(matrix_nsc(ispin)%matrix, name="NSC IN ORTHO", &
450 : template=ksmat(1)%matrix, &
451 132 : matrix_type=dbcsr_type_no_symmetry)
452 :
453 132 : CALL dbcsr_desymmetrize(rho_ao(ispin)%matrix, matrix_p(ispin)%matrix)
454 132 : CALL dbcsr_desymmetrize(ksmat(ispin)%matrix, matrix_ks(ispin)%matrix)
455 264 : CALL dbcsr_desymmetrize(matrix_hz(ispin)%matrix, matrix_nsc(ispin)%matrix)
456 : END DO
457 :
458 : ! Scale matrix_p by factor 1/2 in closed-shell
459 132 : IF (nspins == 1) CALL dbcsr_scale(matrix_p(1)%matrix, 0.5_dp)
460 :
461 : ! Transform P, KS, and Harris kernel matrix into Orthonormal basis
462 : CALL dbcsr_create(matrix_s_sqrt, template=matrix_s(1)%matrix, &
463 132 : matrix_type=dbcsr_type_no_symmetry)
464 : CALL dbcsr_create(matrix_s_sqrt_inv, template=matrix_s(1)%matrix, &
465 132 : matrix_type=dbcsr_type_no_symmetry)
466 :
467 0 : SELECT CASE (s_sqrt_method)
468 : CASE (ls_s_sqrt_proot)
469 : CALL matrix_sqrt_proot(matrix_s_sqrt, matrix_s_sqrt_inv, &
470 : matrix_s(1)%matrix, eps_filter, &
471 0 : s_sqrt_order, eps_lanczos, max_iter_lanczos, symmetrize=.TRUE.)
472 : CASE (ls_s_sqrt_ns)
473 : CALL matrix_sqrt_Newton_Schulz(matrix_s_sqrt, matrix_s_sqrt_inv, &
474 : matrix_s(1)%matrix, eps_filter, &
475 132 : s_sqrt_order, eps_lanczos, max_iter_lanczos)
476 : CASE DEFAULT
477 132 : CPABORT("Unknown sqrt method.")
478 : END SELECT
479 :
480 : ! Transform into orthonormal Lowdin basis
481 264 : DO ispin = 1, nspins
482 132 : CALL transform_m_orth(matrix_p(ispin)%matrix, matrix_s_sqrt, eps_filter)
483 132 : CALL transform_m_orth(matrix_ks(ispin)%matrix, matrix_s_sqrt_inv, eps_filter)
484 264 : CALL transform_m_orth(matrix_nsc(ispin)%matrix, matrix_s_sqrt_inv, eps_filter)
485 : END DO
486 :
487 : !----------------------------------------
488 : ! Create non-symmetric work matrices: Ax, cg, res
489 : ! Content of Ax, cg, cg_z, res, z0 anti-symmetric
490 : ! Content of z symmetric
491 : !----------------------------------------
492 :
493 132 : CALL dbcsr_create(matrix_tmp, template=matrix_s(1)%matrix, matrix_type=dbcsr_type_no_symmetry)
494 :
495 132 : NULLIFY (matrix_Ax, matrix_cg, matrix_cg_z, matrix_res, matrix_z, matrix_z0)
496 132 : CALL dbcsr_allocate_matrix_set(matrix_Ax, nspins)
497 132 : CALL dbcsr_allocate_matrix_set(matrix_cg, nspins)
498 132 : CALL dbcsr_allocate_matrix_set(matrix_cg_z, nspins)
499 132 : CALL dbcsr_allocate_matrix_set(matrix_res, nspins)
500 132 : CALL dbcsr_allocate_matrix_set(matrix_z, nspins)
501 132 : CALL dbcsr_allocate_matrix_set(matrix_z0, nspins)
502 :
503 264 : DO ispin = 1, nspins
504 132 : ALLOCATE (matrix_Ax(ispin)%matrix)
505 132 : ALLOCATE (matrix_cg(ispin)%matrix)
506 132 : ALLOCATE (matrix_cg_z(ispin)%matrix)
507 132 : ALLOCATE (matrix_res(ispin)%matrix)
508 132 : ALLOCATE (matrix_z(ispin)%matrix)
509 132 : ALLOCATE (matrix_z0(ispin)%matrix)
510 : CALL dbcsr_create(matrix_Ax(ispin)%matrix, name="linop MATRIX", &
511 : template=matrix_s(1)%matrix, &
512 132 : matrix_type=dbcsr_type_no_symmetry)
513 : CALL dbcsr_create(matrix_cg(ispin)%matrix, name="TRIAL MATRIX", &
514 : template=matrix_s(1)%matrix, &
515 132 : matrix_type=dbcsr_type_no_symmetry)
516 : CALL dbcsr_create(matrix_cg_z(ispin)%matrix, name="MATRIX CG-Z", &
517 : template=matrix_s(1)%matrix, &
518 132 : matrix_type=dbcsr_type_no_symmetry)
519 : CALL dbcsr_create(matrix_res(ispin)%matrix, name="RESIDUE", &
520 : template=matrix_s(1)%matrix, &
521 132 : matrix_type=dbcsr_type_no_symmetry)
522 : CALL dbcsr_create(matrix_z(ispin)%matrix, name="Z-Matrix", &
523 : template=matrix_s(1)%matrix, &
524 132 : matrix_type=dbcsr_type_no_symmetry)
525 : CALL dbcsr_create(matrix_z0(ispin)%matrix, name="p after precondi-Matrix", &
526 : template=matrix_s(1)%matrix, &
527 264 : matrix_type=dbcsr_type_no_symmetry)
528 : END DO
529 :
530 : !----------------------------------------
531 : ! Get righ-hand-side operators
532 : !----------------------------------------
533 :
534 : ! Spin factor
535 132 : focc = -2.0_dp
536 132 : IF (nspins == 1) focc = -4.0_dp
537 :
538 : ! E^[1]_Harris = -4*G[\delta P]*Pin - Pin*G[\delta P] = -4*[G[\delta P], Pin]
539 132 : CALL commutator(matrix_nsc, matrix_p, matrix_res, eps_filter, .FALSE., alpha=focc)
540 :
541 : ! Initial guess cg_Z
542 264 : DO ispin = 1, nspins
543 264 : CALL dbcsr_copy(matrix_cg_z(ispin)%matrix, matrix_res(ispin)%matrix)
544 : END DO
545 :
546 : ! Projector on trial matrix
547 132 : CALL projector(qs_env, matrix_p, matrix_cg_z, eps_filter)
548 :
549 : ! Ax0
550 : CALL build_hessian_op(qs_env=qs_env, &
551 : p_env=p_env, &
552 : matrix_ks=matrix_ks, &
553 : matrix_p=matrix_p, & ! p
554 : matrix_s_sqrt_inv=matrix_s_sqrt_inv, &
555 : matrix_cg=matrix_cg_z, & ! cg
556 : matrix_Ax=matrix_Ax, &
557 132 : eps_filter=eps_filter)
558 :
559 : ! r_0 = b - Ax0
560 264 : DO ispin = 1, nspins
561 264 : CALL dbcsr_add(matrix_res(ispin)%matrix, matrix_Ax(ispin)%matrix, 1.0_dp, -1.0_dp)
562 : END DO
563 :
564 : ! Matrix projector T
565 132 : CALL projector(qs_env, matrix_p, matrix_res, eps_filter)
566 :
567 : ! Preconditioner
568 132 : linres_control%flag = ""
569 132 : IF (linres_control%preconditioner_type == precond_mlp) THEN
570 : ! M * z_0 = r_0
571 : ! Conjugate gradient returns z_0
572 : CALL ec_preconditioner(qs_env=qs_env, &
573 : matrix_ks=matrix_ks, &
574 : matrix_p=matrix_p, &
575 : matrix_rhs=matrix_res, &
576 : matrix_cg_z=matrix_z0, &
577 : eps_filter=eps_filter, &
578 130 : iounit=iounit, silent=silent)
579 130 : linres_control%flag = "PCG-AO"
580 : ELSE
581 : ! z_0 = r_0
582 4 : DO ispin = 1, nspins
583 2 : CALL dbcsr_copy(matrix_z0(ispin)%matrix, matrix_res(ispin)%matrix)
584 4 : linres_control%flag = "CG-AO"
585 : END DO
586 : END IF
587 :
588 132 : norm_res = 0.0_dp
589 :
590 264 : DO ispin = 1, nspins
591 : ! cg = p_0 = z_0
592 132 : CALL dbcsr_copy(matrix_cg(ispin)%matrix, matrix_z0(ispin)%matrix)
593 :
594 : ! Tr(r_0 * z_0)
595 132 : CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_cg(ispin)%matrix, norm_rr(ispin))
596 :
597 132 : IF (norm_rr(ispin) < 0.0_dp) CPABORT("norm_rr < 0")
598 264 : norm_res = MAX(norm_res, ABS(norm_rr(ispin)/REAL(nao, dp)))
599 : END DO
600 :
601 : ! eigenvalue shifting
602 132 : min_shift = 0.0_dp
603 132 : old_conv = norm_rr(1)
604 132 : shift = MIN(10.0_dp, MAX(min_shift, 0.05_dp*old_conv))
605 132 : old_conv = 100.0_dp
606 :
607 : ! header
608 132 : IF (iounit > 0 .AND. .NOT. my_silent) THEN
609 : WRITE (iounit, "(/,T3,A,T16,A,T25,A,T38,A,T52,A,/,T3,A)") &
610 66 : "Iteration", "Method", "Stepsize", "Convergence", "Time", &
611 132 : REPEAT("-", 80)
612 : END IF
613 :
614 264 : alpha(:) = 0.0_dp
615 132 : restart = .FALSE.
616 132 : should_stop = .FALSE.
617 132 : linres_control%converged = .FALSE.
618 :
619 : ! start iteration
620 580 : iteration: DO i = 1, linres_control%max_iter
621 :
622 : ! Convergence criteria
623 : ! default for eps 10E-6 in MO_linres
624 534 : IF (norm_res < linres_control%eps) THEN
625 86 : linres_control%converged = .TRUE.
626 : END IF
627 :
628 534 : t2 = m_walltime()
629 : IF (i == 1 .OR. MOD(i, 1) == 0 .OR. linres_control%converged &
630 : .OR. restart .OR. should_stop) THEN
631 534 : IF (iounit > 0 .AND. .NOT. my_silent) THEN
632 : WRITE (iounit, "(T5,I5,T18,A3,T28,L1,T38,1E8.2,T48,F16.10,T68,F8.2)") &
633 801 : i, linres_control%flag, restart, MAXVAL(alpha), norm_res, t2 - t1
634 267 : CALL m_flush(iounit)
635 : END IF
636 : END IF
637 534 : IF (linres_control%converged) THEN
638 86 : IF (iounit > 0) THEN
639 43 : WRITE (iounit, "(/,T2,A,I4,A,T73,F8.2,/)") "The linear solver converged in ", &
640 86 : i, " iterations.", t2 - t1
641 43 : CALL m_flush(iounit)
642 : END IF
643 : EXIT iteration
644 448 : ELSE IF (should_stop) THEN
645 0 : IF (iounit > 0) THEN
646 0 : WRITE (iounit, "(/,T2,A,I4,A,/)") "The linear solver did NOT converge! External stop"
647 0 : CALL m_flush(iounit)
648 : END IF
649 : EXIT iteration
650 : END IF
651 :
652 : ! Max number of iteration reached
653 448 : IF (i == linres_control%max_iter) THEN
654 46 : IF (iounit > 0) THEN
655 : WRITE (iounit, "(/,T2,A/)") &
656 23 : "The linear solver didnt converge! Maximum number of iterations reached."
657 23 : CALL m_flush(iounit)
658 : END IF
659 46 : linres_control%converged = .FALSE.
660 : END IF
661 :
662 : ! Hessian Ax = [F,B] + [G(B),P]
663 : CALL build_hessian_op(qs_env=qs_env, &
664 : p_env=p_env, &
665 : matrix_ks=matrix_ks, &
666 : matrix_p=matrix_p, & ! p
667 : matrix_s_sqrt_inv=matrix_s_sqrt_inv, &
668 : matrix_cg=matrix_cg, & ! cg
669 : matrix_Ax=matrix_Ax, &
670 448 : eps_filter=eps_filter)
671 :
672 : ! Matrix projector T
673 448 : CALL projector(qs_env, matrix_p, matrix_Ax, eps_filter)
674 :
675 896 : DO ispin = 1, nspins
676 :
677 448 : CALL dbcsr_filter(matrix_Ax(ispin)%matrix, eps_filter)
678 : ! norm_cA = tr(Ap_j * p_j)
679 448 : CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin))
680 :
681 896 : IF (norm_cA(ispin) < 0.0_dp) THEN
682 :
683 : ! Recalculate w/o preconditioner
684 0 : IF (i > 1) THEN
685 : ! p = -z + beta*p
686 : CALL dbcsr_add(matrix_cg(ispin)%matrix, matrix_z0(ispin)%matrix, &
687 0 : beta(ispin), -1.0_dp)
688 0 : CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, new_norm(ispin))
689 0 : beta(ispin) = new_norm(ispin)/tr_rz00(ispin)
690 : CALL dbcsr_add(matrix_cg(ispin)%matrix, matrix_res(ispin)%matrix, &
691 0 : beta(ispin), 1.0_dp)
692 0 : norm_rr(ispin) = new_norm(ispin)
693 : ELSE
694 0 : CALL dbcsr_copy(matrix_res(ispin)%matrix, matrix_cg(ispin)%matrix)
695 0 : CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_res(ispin)%matrix, norm_rr(ispin))
696 : END IF
697 :
698 : CALL build_hessian_op(qs_env=qs_env, &
699 : p_env=p_env, &
700 : matrix_ks=matrix_ks, &
701 : matrix_p=matrix_p, & ! p
702 : matrix_s_sqrt_inv=matrix_s_sqrt_inv, &
703 : matrix_cg=matrix_cg, & ! cg
704 : matrix_Ax=matrix_Ax, &
705 0 : eps_filter=eps_filter)
706 :
707 : ! Matrix projector T
708 0 : CALL projector(qs_env, matrix_p, matrix_Ax, eps_filter)
709 :
710 0 : CALL dbcsr_dot(matrix_cg(ispin)%matrix, matrix_Ax(ispin)%matrix, norm_cA(ispin))
711 :
712 0 : CPABORT("tr(Ap_j*p_j) < 0")
713 0 : IF (abnormal_value(norm_cA(ispin))) &
714 0 : CPABORT("Preconditioner: Tr[Ap_j*p_j] is an abnormal value (NaN/Inf)")
715 :
716 : END IF
717 :
718 : END DO
719 :
720 896 : DO ispin = 1, nspins
721 : ! Determine step-size
722 448 : IF (norm_cA(ispin) < linres_control%eps) THEN
723 0 : alpha(ispin) = 1.0_dp
724 : ELSE
725 448 : alpha(ispin) = norm_rr(ispin)/norm_cA(ispin)
726 : END IF
727 :
728 : ! x_j+1 = x_j + alpha*p_j
729 : ! save response-denisty of this iteration
730 896 : CALL dbcsr_add(matrix_cg_z(ispin)%matrix, matrix_cg(ispin)%matrix, 1.0_dp, alpha(ispin))
731 : END DO
732 :
733 : ! need to recompute the residue
734 448 : restart = .FALSE.
735 448 : IF (MOD(i, linres_control%restart_every) == 0) THEN
736 : !
737 : ! r_j+1 = b - A * x_j+1
738 : CALL build_hessian_op(qs_env=qs_env, &
739 : p_env=p_env, &
740 : matrix_ks=matrix_ks, &
741 : matrix_p=matrix_p, &
742 : matrix_s_sqrt_inv=matrix_s_sqrt_inv, &
743 : matrix_cg=matrix_cg_z, & ! cg
744 : matrix_Ax=matrix_Ax, &
745 0 : eps_filter=eps_filter)
746 : ! b
747 0 : CALL commutator(matrix_nsc, matrix_p, matrix_res, eps_filter, .FALSE., alpha=focc)
748 :
749 0 : DO ispin = 1, nspins
750 0 : CALL dbcsr_add(matrix_res(ispin)%matrix, matrix_Ax(ispin)%matrix, 1.0_dp, -1.0_dp)
751 : END DO
752 :
753 0 : CALL projector(qs_env, matrix_p, matrix_res, eps_filter)
754 : !
755 0 : restart = .TRUE.
756 : ELSE
757 : ! proj Ap onto the virtual subspace
758 448 : CALL projector(qs_env, matrix_p, matrix_Ax, eps_filter)
759 : !
760 : ! r_j+1 = r_j - alpha * Ap_j
761 896 : DO ispin = 1, nspins
762 896 : CALL dbcsr_add(matrix_res(ispin)%matrix, matrix_Ax(ispin)%matrix, 1.0_dp, -alpha(ispin))
763 : END DO
764 448 : restart = .FALSE.
765 : END IF
766 :
767 : ! Preconditioner
768 448 : linres_control%flag = ""
769 448 : IF (linres_control%preconditioner_type == precond_mlp) THEN
770 : ! M * z_j+1 = r_j+1
771 : ! Conjugate gradient returns z_j+1
772 : CALL ec_preconditioner(qs_env=qs_env, &
773 : matrix_ks=matrix_ks, &
774 : matrix_p=matrix_p, &
775 : matrix_rhs=matrix_res, &
776 : matrix_cg_z=matrix_z0, &
777 : eps_filter=eps_filter, &
778 442 : iounit=iounit, silent=silent)
779 442 : linres_control%flag = "PCG-AO"
780 : ELSE
781 12 : DO ispin = 1, nspins
782 12 : CALL dbcsr_copy(matrix_z0(ispin)%matrix, matrix_res(ispin)%matrix)
783 : END DO
784 6 : linres_control%flag = "CG-AO"
785 : END IF
786 :
787 448 : norm_res = 0.0_dp
788 :
789 896 : DO ispin = 1, nspins
790 : ! Tr[r_j+1*z_j+1]
791 448 : CALL dbcsr_dot(matrix_res(ispin)%matrix, matrix_z0(ispin)%matrix, new_norm(ispin))
792 448 : IF (new_norm(ispin) < 0.0_dp) CPABORT("tr(r_j+1*z_j+1) < 0")
793 448 : IF (abnormal_value(new_norm(ispin))) &
794 0 : CPABORT("Preconditioner: Tr[r_j+1*z_j+1] is an abnormal value (NaN/Inf)")
795 448 : norm_res = MAX(norm_res, new_norm(ispin)/REAL(nao, dp))
796 :
797 448 : IF (norm_rr(ispin) < linres_control%eps .OR. new_norm(ispin) < linres_control%eps) THEN
798 16 : beta(ispin) = 0.0_dp
799 16 : linres_control%converged = .TRUE.
800 : ELSE
801 432 : beta(ispin) = new_norm(ispin)/norm_rr(ispin)
802 : END IF
803 :
804 : ! update new search vector (matrix cg)
805 : ! Here: cg_j+1 = z_j+1 + beta*cg_j
806 448 : CALL dbcsr_add(matrix_cg(ispin)%matrix, matrix_z0(ispin)%matrix, beta(ispin), 1.0_dp)
807 448 : CALL dbcsr_filter(matrix_cg(ispin)%matrix, eps_filter)
808 :
809 448 : tr_rz00(ispin) = norm_rr(ispin)
810 896 : norm_rr(ispin) = new_norm(ispin)
811 : END DO
812 :
813 : ! Can we exit the loop?
814 : CALL external_control(should_stop, "LS_SOLVER", target_time=qs_env%target_time, &
815 494 : start_time=qs_env%start_time)
816 :
817 : END DO iteration
818 :
819 : ! Matrix projector
820 132 : CALL projector(qs_env, matrix_p, matrix_cg_z, eps_filter)
821 :
822 : ! Z = [cg_z,P]
823 132 : CALL commutator(matrix_cg_z, matrix_p, matrix_z, eps_filter, .TRUE., alpha=0.5_dp)
824 :
825 264 : DO ispin = 1, nspins
826 : ! Transform Z-matrix back into non-orthogonal basis
827 132 : CALL transform_m_orth(matrix_z(ispin)%matrix, matrix_s_sqrt_inv, eps_filter)
828 :
829 : ! Export Z-Matrix
830 264 : CALL dbcsr_copy(matrix_pz(ispin)%matrix, matrix_z(ispin)%matrix, keep_sparsity=.TRUE.)
831 : END DO
832 :
833 : ! Calculate energy-weighted response density matrix
834 : ! AO: Wz = 0.5*(Z*KS*P + P*KS*Z)
835 132 : CALL ec_wz_matrix(qs_env, matrix_pz, matrix_wz, eps_filter)
836 :
837 : ! Release matrices
838 132 : CALL dbcsr_release(matrix_tmp)
839 :
840 132 : CALL dbcsr_release(matrix_s_sqrt)
841 132 : CALL dbcsr_release(matrix_s_sqrt_inv)
842 :
843 132 : CALL dbcsr_deallocate_matrix_set(matrix_p)
844 132 : CALL dbcsr_deallocate_matrix_set(matrix_ks)
845 132 : CALL dbcsr_deallocate_matrix_set(matrix_nsc)
846 132 : CALL dbcsr_deallocate_matrix_set(matrix_z)
847 132 : CALL dbcsr_deallocate_matrix_set(matrix_Ax)
848 132 : CALL dbcsr_deallocate_matrix_set(matrix_res)
849 132 : CALL dbcsr_deallocate_matrix_set(matrix_cg)
850 132 : CALL dbcsr_deallocate_matrix_set(matrix_cg_z)
851 132 : CALL dbcsr_deallocate_matrix_set(matrix_z0)
852 :
853 132 : DEALLOCATE (alpha, beta, new_norm, norm_cA, norm_rr)
854 132 : DEALLOCATE (tr_rz00)
855 :
856 132 : CALL timestop(handle)
857 :
858 396 : END SUBROUTINE ec_response_ao
859 :
860 : ! **************************************************************************************************
861 : !> \brief Compute matrix_wz as needed for the forces
862 : !> Wz = 0.5*(Z*KS*P + P*KS*Z) (closed-shell)
863 : !> \param qs_env ...
864 : !> \param matrix_z The response density we just calculated
865 : !> \param matrix_wz The energy weighted response-density matrix
866 : !> \param eps_filter ...
867 : !> \par History
868 : !> 2020.2 created [Fabian Belleflamme]
869 : !> \author Fabian Belleflamme
870 : ! **************************************************************************************************
871 132 : SUBROUTINE ec_wz_matrix(qs_env, matrix_z, matrix_wz, eps_filter)
872 :
873 : TYPE(qs_environment_type), POINTER :: qs_env
874 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
875 : POINTER :: matrix_z
876 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(INOUT), &
877 : POINTER :: matrix_wz
878 : REAL(KIND=dp), INTENT(IN) :: eps_filter
879 :
880 : CHARACTER(len=*), PARAMETER :: routineN = 'ec_wz_matrix'
881 :
882 : INTEGER :: handle, ispin, nspins
883 : REAL(KIND=dp) :: scaling
884 132 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_ks, matrix_p, matrix_s
885 : TYPE(dbcsr_type) :: matrix_tmp, matrix_tmp2
886 : TYPE(dft_control_type), POINTER :: dft_control
887 : TYPE(qs_rho_type), POINTER :: rho
888 :
889 132 : CALL timeset(routineN, handle)
890 :
891 132 : CPASSERT(ASSOCIATED(qs_env))
892 132 : CPASSERT(ASSOCIATED(matrix_z))
893 132 : CPASSERT(ASSOCIATED(matrix_wz))
894 :
895 : CALL get_qs_env(qs_env=qs_env, &
896 : dft_control=dft_control, &
897 : matrix_ks=matrix_ks, &
898 : matrix_s=matrix_s, &
899 132 : rho=rho)
900 132 : nspins = dft_control%nspins
901 :
902 132 : CALL qs_rho_get(rho, rho_ao=matrix_p)
903 :
904 : ! Init temp matrices
905 : CALL dbcsr_create(matrix_tmp, template=matrix_z(1)%matrix, &
906 132 : matrix_type=dbcsr_type_no_symmetry)
907 : CALL dbcsr_create(matrix_tmp2, template=matrix_z(1)%matrix, &
908 132 : matrix_type=dbcsr_type_no_symmetry)
909 :
910 : ! Scale matrix_p by factor 1/2 in closed-shell
911 132 : scaling = 1.0_dp
912 132 : IF (nspins == 1) scaling = 0.5_dp
913 :
914 : ! Whz = ZFP + PFZ = Z(FP) + (Z(FP))^T
915 264 : DO ispin = 1, nspins
916 :
917 : ! tmp = FP
918 : CALL dbcsr_multiply("N", "N", scaling, matrix_ks(ispin)%matrix, matrix_p(ispin)%matrix, &
919 132 : 0.0_dp, matrix_tmp, filter_eps=eps_filter, retain_sparsity=.FALSE.)
920 :
921 : ! tmp2 = ZFP
922 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_z(ispin)%matrix, matrix_tmp, &
923 132 : 0.0_dp, matrix_tmp2, filter_eps=eps_filter, retain_sparsity=.FALSE.)
924 :
925 : ! tmp = (ZFP)^T
926 132 : CALL dbcsr_transposed(matrix_tmp, matrix_tmp2)
927 :
928 : ! tmp = ZFP + (ZFP)^T
929 132 : CALL dbcsr_add(matrix_tmp, matrix_tmp2, 1.0_dp, 1.0_dp)
930 :
931 132 : CALL dbcsr_filter(matrix_tmp, eps_filter)
932 :
933 : ! Whz = ZFP + PFZ
934 264 : CALL dbcsr_copy(matrix_wz(ispin)%matrix, matrix_tmp, keep_sparsity=.TRUE.)
935 :
936 : END DO
937 :
938 : ! Release matrices
939 132 : CALL dbcsr_release(matrix_tmp)
940 132 : CALL dbcsr_release(matrix_tmp2)
941 :
942 132 : CALL timestop(handle)
943 :
944 132 : END SUBROUTINE ec_wz_matrix
945 :
946 : ! **************************************************************************************************
947 : !> \brief Calculate first term of electronic Hessian M = [F, B]
948 : !> acting as liner transformation on trial matrix (matrix_cg)
949 : !> with intermediate response density B = [cg,P] = cg*P - P*cg = cg*P + (cg*P)^T
950 : !>
951 : !> All matrices are in orthonormal basis
952 : !>
953 : !> \param matrix_ks Ground-state Kohn-Sham matrix
954 : !> \param matrix_p Ground-state Density matrix
955 : !> \param matrix_cg Trial matrix
956 : !> \param matrix_b Intermediate response density
957 : !> \param matrix_Ax First term of electronic Hessian applied on trial matrix (matrix_cg)
958 : !>
959 : !> \param eps_filter ...
960 : !> \date 12.2019
961 : !> \author Fabian Belleflamme
962 : ! **************************************************************************************************
963 4214 : SUBROUTINE hessian_op1(matrix_ks, matrix_p, matrix_cg, matrix_b, matrix_Ax, eps_filter)
964 :
965 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
966 : POINTER :: matrix_ks, matrix_p, matrix_cg
967 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(INOUT), &
968 : POINTER :: matrix_b, matrix_Ax
969 : REAL(KIND=dp), INTENT(IN) :: eps_filter
970 :
971 : CHARACTER(len=*), PARAMETER :: routineN = 'hessian_op1'
972 :
973 : INTEGER :: handle
974 :
975 4214 : CALL timeset(routineN, handle)
976 :
977 4214 : CPASSERT(ASSOCIATED(matrix_ks))
978 4214 : CPASSERT(ASSOCIATED(matrix_p))
979 4214 : CPASSERT(ASSOCIATED(matrix_cg))
980 4214 : CPASSERT(ASSOCIATED(matrix_b))
981 4214 : CPASSERT(ASSOCIATED(matrix_Ax))
982 :
983 : ! Build intermediate density matrix
984 : ! B = [cg, P] = cg*P - P*cg = cg*P + (cg*P)^T
985 4214 : CALL commutator(matrix_cg, matrix_p, matrix_b, eps_filter, .TRUE.)
986 :
987 : ! Build first part of operator
988 : ! Ax = [F,[cg,P]] = [F,B]
989 4214 : CALL commutator(matrix_ks, matrix_b, matrix_Ax, eps_filter, .FALSE.)
990 :
991 4214 : CALL timestop(handle)
992 :
993 4214 : END SUBROUTINE hessian_op1
994 :
995 : ! **************************************************************************************************
996 : !> \brief calculate linear transformation of Hessian matrix on a trial matrix matrix_cg
997 : !> which is stored in response density B = [cg,P] = cg*P - P*cg = cg*P + (cg*P)^T
998 : !> Ax = [F, B] + [G(B), Pin] in orthonormal basis
999 : !>
1000 : !> \param qs_env ...
1001 : !> \param p_env ...
1002 : !> \param matrix_ks Ground-state Kohn-Sham matrix
1003 : !> \param matrix_p Ground-state Density matrix
1004 : !> \param matrix_s_sqrt_inv S^(-1/2) needed for transformation to/from orthonormal basis
1005 : !> \param matrix_cg Trial matrix
1006 : !> \param matrix_Ax Electronic Hessian applied on trial matrix (matrix_cg)
1007 : !> \param eps_filter ...
1008 : !>
1009 : !> \date 12.2019
1010 : !> \author Fabian Belleflamme
1011 : ! **************************************************************************************************
1012 580 : SUBROUTINE build_hessian_op(qs_env, p_env, matrix_ks, matrix_p, matrix_s_sqrt_inv, &
1013 : matrix_cg, matrix_Ax, eps_filter)
1014 :
1015 : TYPE(qs_environment_type), POINTER :: qs_env
1016 : TYPE(qs_p_env_type), POINTER :: p_env
1017 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
1018 : POINTER :: matrix_ks, matrix_p
1019 : TYPE(dbcsr_type), INTENT(IN) :: matrix_s_sqrt_inv
1020 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
1021 : POINTER :: matrix_cg
1022 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(INOUT), &
1023 : POINTER :: matrix_Ax
1024 : REAL(KIND=dp), INTENT(IN) :: eps_filter
1025 :
1026 : CHARACTER(len=*), PARAMETER :: routineN = 'build_hessian_op'
1027 :
1028 : INTEGER :: handle, ispin, nspins
1029 : REAL(KIND=dp) :: chksum
1030 580 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_b, rho1_ao
1031 : TYPE(dft_control_type), POINTER :: dft_control
1032 : TYPE(mp_para_env_type), POINTER :: para_env
1033 : TYPE(qs_rho_type), POINTER :: rho
1034 :
1035 580 : CALL timeset(routineN, handle)
1036 :
1037 580 : CPASSERT(ASSOCIATED(qs_env))
1038 580 : CPASSERT(ASSOCIATED(matrix_ks))
1039 580 : CPASSERT(ASSOCIATED(matrix_p))
1040 580 : CPASSERT(ASSOCIATED(matrix_cg))
1041 580 : CPASSERT(ASSOCIATED(matrix_Ax))
1042 :
1043 : CALL get_qs_env(qs_env=qs_env, &
1044 : dft_control=dft_control, &
1045 : para_env=para_env, &
1046 580 : rho=rho)
1047 580 : nspins = dft_control%nspins
1048 :
1049 580 : NULLIFY (matrix_b)
1050 580 : CALL dbcsr_allocate_matrix_set(matrix_b, nspins)
1051 1160 : DO ispin = 1, nspins
1052 580 : ALLOCATE (matrix_b(ispin)%matrix)
1053 : CALL dbcsr_create(matrix_b(ispin)%matrix, name="[X,P] RSP DNSTY", &
1054 : template=matrix_p(1)%matrix, &
1055 1160 : matrix_type=dbcsr_type_no_symmetry)
1056 : END DO
1057 :
1058 : ! Build uncoupled term of Hessian linear transformation
1059 580 : CALL hessian_op1(matrix_ks, matrix_p, matrix_cg, matrix_b, matrix_Ax, eps_filter)
1060 :
1061 : ! Avoid the buildup of noisy blocks
1062 1160 : DO ispin = 1, nspins
1063 1160 : CALL dbcsr_filter(matrix_b(ispin)%matrix, eps_filter)
1064 : END DO
1065 :
1066 : chksum = 0.0_dp
1067 1160 : DO ispin = 1, nspins
1068 1160 : chksum = chksum + dbcsr_checksum(matrix_b(ispin)%matrix)
1069 : END DO
1070 :
1071 : ! skip the kernel if the DM is very small
1072 580 : IF (chksum > 1.0E-14_dp) THEN
1073 :
1074 : ! Bring matrix B as density on grid
1075 :
1076 : ! prepare perturbation environment
1077 576 : CALL p_env_check_i_alloc(p_env, qs_env)
1078 :
1079 : ! Get response density matrix
1080 576 : CALL qs_rho_get(p_env%rho1, rho_ao=rho1_ao)
1081 :
1082 1152 : DO ispin = 1, nspins
1083 : ! Transform B into NON-ortho basis for collocation
1084 576 : CALL transform_m_orth(matrix_b(ispin)%matrix, matrix_s_sqrt_inv, eps_filter)
1085 : ! Filter
1086 576 : CALL dbcsr_filter(matrix_b(ispin)%matrix, eps_filter)
1087 : ! Keep symmetry of density matrix
1088 576 : CALL dbcsr_copy(rho1_ao(ispin)%matrix, matrix_b(ispin)%matrix, keep_sparsity=.TRUE.)
1089 1152 : CALL dbcsr_copy(p_env%p1(ispin)%matrix, matrix_b(ispin)%matrix, keep_sparsity=.TRUE.)
1090 : END DO
1091 :
1092 : ! Updates densities on grid wrt density matrix
1093 576 : CALL p_env_update_rho(p_env, qs_env)
1094 :
1095 1152 : DO ispin = 1, nspins
1096 576 : CALL dbcsr_set(p_env%kpp1(ispin)%matrix, 0.0_dp)
1097 1152 : IF (ASSOCIATED(p_env%kpp1_admm)) CALL dbcsr_set(p_env%kpp1_admm(ispin)%matrix, 0.0_dp)
1098 : END DO
1099 :
1100 : ! Calculate kernel
1101 : ! Ax = F*B - B*F + G(B)*P - P*G(B)
1102 : ! IN/OUT IN IN IN
1103 576 : CALL hessian_op2(qs_env, p_env, matrix_Ax, matrix_p, matrix_s_sqrt_inv, eps_filter)
1104 :
1105 : END IF
1106 :
1107 580 : CALL dbcsr_deallocate_matrix_set(matrix_b)
1108 :
1109 580 : CALL timestop(handle)
1110 :
1111 580 : END SUBROUTINE build_hessian_op
1112 :
1113 : ! **************************************************************************************************
1114 : !> \brief Calculate lin transformation of Hessian matrix on a trial matrix matrix_cg
1115 : !> which is stored in response density B = [cg,P] = cg*P - P*cg = cg*P + (cg*P)^T
1116 : !> Ax = [F, B] + [G(B), Pin] in orthonormal basis
1117 : !>
1118 : !> \param qs_env ...
1119 : !> \param p_env p-environment with trial density environment
1120 : !> \param matrix_Ax contains first part of Hessian linear transformation, kernel contribution
1121 : !> is calculated and added in this routine
1122 : !> \param matrix_p Density matrix in orthogonal basis
1123 : !> \param matrix_s_sqrt_inv contains matrix S^(-1/2) for switching to orthonormal Lowdin basis
1124 : !> \param eps_filter ...
1125 : !>
1126 : !> \date 12.2019
1127 : !> \author Fabian Belleflamme
1128 : ! **************************************************************************************************
1129 576 : SUBROUTINE hessian_op2(qs_env, p_env, matrix_Ax, matrix_p, matrix_s_sqrt_inv, eps_filter)
1130 :
1131 : TYPE(qs_environment_type), POINTER :: qs_env
1132 : TYPE(qs_p_env_type), POINTER :: p_env
1133 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(INOUT), &
1134 : POINTER :: matrix_Ax
1135 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
1136 : POINTER :: matrix_p
1137 : TYPE(dbcsr_type), INTENT(IN) :: matrix_s_sqrt_inv
1138 : REAL(KIND=dp), INTENT(IN) :: eps_filter
1139 :
1140 : CHARACTER(len=*), PARAMETER :: routineN = 'hessian_op2'
1141 :
1142 : INTEGER :: handle, ispin, nspins
1143 : REAL(KIND=dp) :: ekin_mol
1144 : TYPE(admm_type), POINTER :: admm_env
1145 576 : TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_G, matrix_s, rho1_ao, rho_ao
1146 : TYPE(dft_control_type), POINTER :: dft_control
1147 : TYPE(mp_para_env_type), POINTER :: para_env
1148 : TYPE(pw_c1d_gs_type) :: rho_tot_gspace, v_hartree_gspace
1149 576 : TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho1_g
1150 : TYPE(pw_env_type), POINTER :: pw_env
1151 : TYPE(pw_poisson_type), POINTER :: poisson_env
1152 576 : TYPE(pw_pool_p_type), DIMENSION(:), POINTER :: pw_pools
1153 : TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
1154 : TYPE(pw_r3d_rs_type) :: v_hartree_rspace
1155 576 : TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho1_r, rho_r, tau1_r, v_xc, v_xc_tau
1156 : TYPE(qs_kpp1_env_type), POINTER :: kpp1_env
1157 : TYPE(qs_rho_type), POINTER :: rho, rho_aux
1158 : TYPE(section_vals_type), POINTER :: input, xc_section, xc_section_aux
1159 :
1160 576 : CALL timeset(routineN, handle)
1161 :
1162 576 : NULLIFY (admm_env, dft_control, input, matrix_s, para_env, rho, rho_r, rho1_g, rho1_r)
1163 :
1164 : CALL get_qs_env(qs_env=qs_env, &
1165 : admm_env=admm_env, &
1166 : dft_control=dft_control, &
1167 : input=input, &
1168 : matrix_s=matrix_s, &
1169 : para_env=para_env, &
1170 576 : rho=rho)
1171 576 : nspins = dft_control%nspins
1172 :
1173 576 : CPASSERT(ASSOCIATED(p_env%kpp1))
1174 576 : CPASSERT(ASSOCIATED(p_env%kpp1_env))
1175 576 : kpp1_env => p_env%kpp1_env
1176 :
1177 : ! Get non-ortho input density matrix on grid
1178 576 : CALL qs_rho_get(rho, rho_ao=rho_ao)
1179 : ! Get non-ortho trial density stored in p_env
1180 576 : CALL qs_rho_get(p_env%rho1, rho_g=rho1_g, rho_r=rho1_r, tau_r=tau1_r)
1181 :
1182 576 : NULLIFY (pw_env)
1183 576 : CALL get_qs_env(qs_env, pw_env=pw_env)
1184 576 : CPASSERT(ASSOCIATED(pw_env))
1185 :
1186 576 : NULLIFY (auxbas_pw_pool, poisson_env, pw_pools)
1187 : ! gets the tmp grids
1188 : CALL pw_env_get(pw_env=pw_env, &
1189 : auxbas_pw_pool=auxbas_pw_pool, &
1190 : pw_pools=pw_pools, &
1191 576 : poisson_env=poisson_env)
1192 :
1193 : ! Calculate the NSC Hartree potential
1194 576 : CALL auxbas_pw_pool%create_pw(pw=v_hartree_gspace)
1195 576 : CALL auxbas_pw_pool%create_pw(pw=rho_tot_gspace)
1196 576 : CALL auxbas_pw_pool%create_pw(pw=v_hartree_rspace)
1197 :
1198 : ! XC-Kernel
1199 576 : NULLIFY (v_xc, v_xc_tau, xc_section)
1200 :
1201 576 : IF (dft_control%do_admm) THEN
1202 132 : xc_section => admm_env%xc_section_primary
1203 : ELSE
1204 444 : xc_section => section_vals_get_subs_vals(input, "DFT%XC")
1205 : END IF
1206 :
1207 : ! add xc-kernel
1208 : CALL create_kernel(qs_env, &
1209 : vxc=v_xc, &
1210 : vxc_tau=v_xc_tau, &
1211 : rho=rho, &
1212 : rho1_r=rho1_r, &
1213 : rho1_g=rho1_g, &
1214 : tau1_r=tau1_r, &
1215 576 : xc_section=xc_section)
1216 :
1217 1152 : DO ispin = 1, nspins
1218 576 : CALL pw_scale(v_xc(ispin), v_xc(ispin)%pw_grid%dvol)
1219 1152 : IF (ASSOCIATED(v_xc_tau)) THEN
1220 24 : CALL pw_scale(v_xc_tau(ispin), v_xc_tau(ispin)%pw_grid%dvol)
1221 : END IF
1222 : END DO
1223 :
1224 : ! ADMM Correction
1225 576 : IF (dft_control%do_admm) THEN
1226 132 : IF (admm_env%aux_exch_func /= do_admm_aux_exch_func_none) THEN
1227 70 : IF (.NOT. ASSOCIATED(kpp1_env%deriv_set_admm)) THEN
1228 16 : xc_section_aux => admm_env%xc_section_aux
1229 16 : CALL get_admm_env(qs_env%admm_env, rho_aux_fit=rho_aux)
1230 16 : CALL qs_rho_get(rho_aux, rho_r=rho_r)
1231 368 : ALLOCATE (kpp1_env%deriv_set_admm, kpp1_env%rho_set_admm)
1232 : CALL xc_prep_2nd_deriv(kpp1_env%deriv_set_admm, kpp1_env%rho_set_admm, &
1233 : rho_r, auxbas_pw_pool, &
1234 16 : xc_section=xc_section_aux)
1235 : END IF
1236 : END IF
1237 : END IF
1238 :
1239 : ! take trial density to build G^{H}[B]
1240 576 : CALL pw_zero(rho_tot_gspace)
1241 1152 : DO ispin = 1, nspins
1242 1152 : CALL pw_axpy(rho1_g(ispin), rho_tot_gspace)
1243 : END DO
1244 :
1245 : ! get Hartree potential from rho_tot_gspace
1246 : CALL pw_poisson_solve(poisson_env, rho_tot_gspace, &
1247 576 : vhartree=v_hartree_gspace)
1248 576 : CALL pw_transfer(v_hartree_gspace, v_hartree_rspace)
1249 576 : CALL pw_scale(v_hartree_rspace, v_hartree_rspace%pw_grid%dvol)
1250 :
1251 : ! Add v_xc + v_H
1252 1152 : DO ispin = 1, nspins
1253 1152 : CALL pw_axpy(v_hartree_rspace, v_xc(ispin))
1254 : END DO
1255 576 : IF (nspins == 1) THEN
1256 576 : CALL pw_scale(v_xc(1), 2.0_dp)
1257 576 : IF (ASSOCIATED(v_xc_tau)) CALL pw_scale(v_xc_tau(1), 2.0_dp)
1258 : END IF
1259 :
1260 1152 : DO ispin = 1, nspins
1261 : ! Integrate with ground-state density matrix, in non-orthogonal basis
1262 : CALL integrate_v_rspace(v_rspace=v_xc(ispin), &
1263 : pmat=rho_ao(ispin), &
1264 : hmat=p_env%kpp1(ispin), &
1265 : qs_env=qs_env, &
1266 : calculate_forces=.FALSE., &
1267 576 : basis_type="ORB")
1268 1152 : IF (ASSOCIATED(v_xc_tau)) THEN
1269 : CALL integrate_v_rspace(v_rspace=v_xc_tau(ispin), &
1270 : pmat=rho_ao(ispin), &
1271 : hmat=p_env%kpp1(ispin), &
1272 : qs_env=qs_env, &
1273 : compute_tau=.TRUE., &
1274 : calculate_forces=.FALSE., &
1275 24 : basis_type="ORB")
1276 : END IF
1277 : END DO
1278 :
1279 : ! Hartree-Fock contribution
1280 576 : CALL apply_hfx(qs_env, p_env)
1281 : ! Calculate ADMM exchange correction to kernel
1282 576 : CALL apply_xc_admm(qs_env, p_env)
1283 : ! Add contribution from ADMM exchange correction to kernel
1284 576 : CALL p_env_finish_kpp1(qs_env, p_env)
1285 :
1286 : ! Calculate KG correction to kernel
1287 576 : IF (dft_control%qs_control%do_kg) THEN
1288 50 : IF (qs_env%kg_env%tnadd_method == kg_tnadd_embed .OR. &
1289 : qs_env%kg_env%tnadd_method == kg_tnadd_embed_ri) THEN
1290 :
1291 24 : CPASSERT(dft_control%nimages == 1)
1292 : ekin_mol = 0.0_dp
1293 24 : CALL qs_rho_get(p_env%rho1, rho_ao=rho1_ao)
1294 : CALL kg_ekin_subset(qs_env=qs_env, &
1295 : ks_matrix=p_env%kpp1, &
1296 : ekin_mol=ekin_mol, &
1297 : calc_force=.FALSE., &
1298 : do_kernel=.TRUE., &
1299 24 : pmat_ext=rho1_ao)
1300 : END IF
1301 : END IF
1302 :
1303 : ! Init response kernel matrix
1304 : ! matrix G(B)
1305 576 : NULLIFY (matrix_G)
1306 576 : CALL dbcsr_allocate_matrix_set(matrix_G, nspins)
1307 1152 : DO ispin = 1, nspins
1308 576 : ALLOCATE (matrix_G(ispin)%matrix)
1309 : CALL dbcsr_copy(matrix_G(ispin)%matrix, p_env%kpp1(ispin)%matrix, &
1310 1152 : name="MATRIX Kernel")
1311 : END DO
1312 :
1313 : ! Transforming G(B) into orthonormal basis
1314 : ! Careful, this de-symmetrizes matrix_G
1315 1152 : DO ispin = 1, nspins
1316 576 : CALL transform_m_orth(matrix_G(ispin)%matrix, matrix_s_sqrt_inv, eps_filter)
1317 1152 : CALL dbcsr_filter(matrix_G(ispin)%matrix, eps_filter)
1318 : END DO
1319 :
1320 : ! Hessian already contains Ax = [F,B] (ORTHO), now adding
1321 : ! Ax = Ax + G(B)P - (G(B)P)^T
1322 576 : CALL commutator(matrix_G, matrix_p, matrix_Ax, eps_filter, .FALSE., 1.0_dp, 1.0_dp)
1323 :
1324 : ! release pw grids
1325 576 : CALL auxbas_pw_pool%give_back_pw(v_hartree_gspace)
1326 576 : CALL auxbas_pw_pool%give_back_pw(v_hartree_rspace)
1327 576 : CALL auxbas_pw_pool%give_back_pw(rho_tot_gspace)
1328 1152 : DO ispin = 1, nspins
1329 1152 : CALL auxbas_pw_pool%give_back_pw(v_xc(ispin))
1330 : END DO
1331 576 : DEALLOCATE (v_xc)
1332 576 : IF (ASSOCIATED(v_xc_tau)) THEN
1333 48 : DO ispin = 1, nspins
1334 48 : CALL auxbas_pw_pool%give_back_pw(v_xc_tau(ispin))
1335 : END DO
1336 24 : DEALLOCATE (v_xc_tau)
1337 : END IF
1338 :
1339 576 : CALL dbcsr_deallocate_matrix_set(matrix_G)
1340 :
1341 576 : CALL timestop(handle)
1342 :
1343 576 : END SUBROUTINE hessian_op2
1344 :
1345 : ! **************************************************************************************************
1346 : !> \brief computes (anti-)commutator exploiting (anti-)symmetry:
1347 : !> A symmetric : RES = beta*RES + k*[A,B] = k*(AB-(AB)^T)
1348 : !> A anti-sym : RES = beta*RES + k*{A,B} = k*(AB+(AB)^T)
1349 : !>
1350 : !> \param a Matrix A
1351 : !> \param b Matrix B
1352 : !> \param res Commutator result
1353 : !> \param eps_filter filtering threshold for sparse matrices
1354 : !> \param anticomm Calculate anticommutator
1355 : !> \param alpha Scaling of anti-/commutator
1356 : !> \param beta Scaling of inital content of result matrix
1357 : !>
1358 : !> \par History
1359 : !> 2020.07 Fabian Belleflamme (based on commutator_symm)
1360 : ! **************************************************************************************************
1361 9268 : SUBROUTINE commutator(a, b, res, eps_filter, anticomm, alpha, beta)
1362 :
1363 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
1364 : POINTER :: a, b, res
1365 : REAL(KIND=dp) :: eps_filter
1366 : LOGICAL :: anticomm
1367 : REAL(KIND=dp), OPTIONAL :: alpha, beta
1368 :
1369 : CHARACTER(LEN=*), PARAMETER :: routineN = 'commutator'
1370 :
1371 : INTEGER :: handle, ispin
1372 : REAL(KIND=dp) :: facc, myalpha, mybeta
1373 : TYPE(dbcsr_type) :: work, work2
1374 :
1375 9268 : CALL timeset(routineN, handle)
1376 :
1377 9268 : CPASSERT(ASSOCIATED(a))
1378 9268 : CPASSERT(ASSOCIATED(b))
1379 9268 : CPASSERT(ASSOCIATED(res))
1380 :
1381 9268 : CALL dbcsr_create(work, template=a(1)%matrix, matrix_type=dbcsr_type_no_symmetry)
1382 9268 : CALL dbcsr_create(work2, template=a(1)%matrix, matrix_type=dbcsr_type_no_symmetry)
1383 :
1384 : ! Scaling of anti-/commutator
1385 9268 : myalpha = 1.0_dp
1386 9268 : IF (PRESENT(alpha)) myalpha = alpha
1387 : ! Scaling of result matrix
1388 9268 : mybeta = 0.0_dp
1389 9268 : IF (PRESENT(beta)) mybeta = beta
1390 : ! Add/subtract second term when calculating anti-/commutator
1391 9268 : facc = -1.0_dp
1392 9268 : IF (anticomm) facc = 1.0_dp
1393 :
1394 18536 : DO ispin = 1, SIZE(a)
1395 :
1396 : CALL dbcsr_multiply("N", "N", myalpha, a(ispin)%matrix, b(ispin)%matrix, &
1397 9268 : 0.0_dp, work, filter_eps=eps_filter)
1398 9268 : CALL dbcsr_transposed(work2, work)
1399 :
1400 : ! RES= beta*RES + alpha*{A,B} = beta*RES + alpha*[AB+(AB)T]
1401 : ! RES= beta*RES + alpha*[A,B] = beta*RES + alpha*[AB-(AB)T]
1402 9268 : CALL dbcsr_add(work, work2, 1.0_dp, facc)
1403 :
1404 18536 : CALL dbcsr_add(res(ispin)%matrix, work, mybeta, 1.0_dp)
1405 :
1406 : END DO
1407 :
1408 9268 : CALL dbcsr_release(work)
1409 9268 : CALL dbcsr_release(work2)
1410 :
1411 9268 : CALL timestop(handle)
1412 :
1413 9268 : END SUBROUTINE commutator
1414 :
1415 : ! **************************************************************************************************
1416 : !> \brief Projector P(M) = P*M*Q^T + Q*M*P^T
1417 : !> with P = D
1418 : !> with Q = (1-D)
1419 : !>
1420 : !> \param qs_env ...
1421 : !> \param matrix_p Ground-state density in orthonormal basis
1422 : !> \param matrix_io Matrix to which projector is applied.
1423 : !>
1424 : !> \param eps_filter ...
1425 : !> \date 06.2020
1426 : !> \author Fabian Belleflamme
1427 : ! **************************************************************************************************
1428 5498 : SUBROUTINE projector(qs_env, matrix_p, matrix_io, eps_filter)
1429 :
1430 : TYPE(qs_environment_type), POINTER :: qs_env
1431 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(IN), &
1432 : POINTER :: matrix_p
1433 : TYPE(dbcsr_p_type), DIMENSION(:), INTENT(INOUT), &
1434 : POINTER :: matrix_io
1435 : REAL(KIND=dp), INTENT(IN) :: eps_filter
1436 :
1437 : CHARACTER(len=*), PARAMETER :: routineN = 'projector'
1438 :
1439 : INTEGER :: handle, ispin, nspins
1440 : TYPE(dbcsr_type) :: matrix_q, matrix_tmp
1441 : TYPE(dft_control_type), POINTER :: dft_control
1442 : TYPE(mp_para_env_type), POINTER :: para_env
1443 :
1444 5498 : CALL timeset(routineN, handle)
1445 :
1446 : CALL get_qs_env(qs_env=qs_env, &
1447 : dft_control=dft_control, &
1448 5498 : para_env=para_env)
1449 5498 : nspins = dft_control%nspins
1450 :
1451 : CALL dbcsr_create(matrix_q, template=matrix_p(1)%matrix, &
1452 5498 : matrix_type=dbcsr_type_no_symmetry)
1453 : CALL dbcsr_create(matrix_tmp, template=matrix_p(1)%matrix, &
1454 5498 : matrix_type=dbcsr_type_no_symmetry)
1455 :
1456 : ! Q = (1 - P)
1457 5498 : CALL dbcsr_copy(matrix_q, matrix_p(1)%matrix)
1458 5498 : CALL dbcsr_scale(matrix_q, -1.0_dp)
1459 5498 : CALL dbcsr_add_on_diag(matrix_q, 1.0_dp)
1460 5498 : CALL dbcsr_finalize(matrix_q)
1461 :
1462 : ! Proj(M) = P*M*Q + Q*M*P
1463 : ! with P = D = CC^T
1464 : ! and Q = (1 - P)
1465 10996 : DO ispin = 1, nspins
1466 :
1467 : ! tmp1 = P*M
1468 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_p(ispin)%matrix, matrix_io(ispin)%matrix, &
1469 5498 : 0.0_dp, matrix_tmp, filter_eps=eps_filter)
1470 : ! m_io = P*M*Q
1471 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_tmp, matrix_q, &
1472 5498 : 0.0_dp, matrix_io(ispin)%matrix, filter_eps=eps_filter)
1473 :
1474 : ! tmp = (P^T*M^T*Q^T)^T = -(P*M*Q)^T
1475 5498 : CALL dbcsr_transposed(matrix_tmp, matrix_io(ispin)%matrix)
1476 10996 : CALL dbcsr_add(matrix_io(ispin)%matrix, matrix_tmp, 1.0_dp, -1.0_dp)
1477 :
1478 : END DO
1479 :
1480 5498 : CALL dbcsr_release(matrix_tmp)
1481 5498 : CALL dbcsr_release(matrix_q)
1482 :
1483 5498 : CALL timestop(handle)
1484 :
1485 5498 : END SUBROUTINE projector
1486 :
1487 : ! **************************************************************************************************
1488 : !> \brief performs a tranformation of a matrix back to/into orthonormal basis
1489 : !> in case of P a scaling of 0.5 has to be applied for closed shell case
1490 : !> \param matrix matrix to be transformed
1491 : !> \param matrix_trafo transformation matrix
1492 : !> \param eps_filter filtering threshold for sparse matrices
1493 : !> \par History
1494 : !> 2012.05 created [Florian Schiffmann]
1495 : !> \author Florian Schiffmann
1496 : !>
1497 : ! **************************************************************************************************
1498 :
1499 1680 : SUBROUTINE transform_m_orth(matrix, matrix_trafo, eps_filter)
1500 : TYPE(dbcsr_type) :: matrix, matrix_trafo
1501 : REAL(KIND=dp) :: eps_filter
1502 :
1503 : CHARACTER(LEN=*), PARAMETER :: routineN = 'transform_m_orth'
1504 :
1505 : INTEGER :: handle
1506 : TYPE(dbcsr_type) :: matrix_tmp, matrix_work
1507 :
1508 1680 : CALL timeset(routineN, handle)
1509 :
1510 1680 : CALL dbcsr_create(matrix_work, template=matrix, matrix_type=dbcsr_type_no_symmetry)
1511 1680 : CALL dbcsr_create(matrix_tmp, template=matrix, matrix_type=dbcsr_type_no_symmetry)
1512 :
1513 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix, matrix_trafo, &
1514 1680 : 0.0_dp, matrix_work, filter_eps=eps_filter)
1515 : CALL dbcsr_multiply("N", "N", 1.0_dp, matrix_trafo, matrix_work, &
1516 1680 : 0.0_dp, matrix_tmp, filter_eps=eps_filter)
1517 : ! symmetrize results (this is again needed to make sure everything is stable)
1518 1680 : CALL dbcsr_transposed(matrix_work, matrix_tmp)
1519 1680 : CALL dbcsr_add(matrix_tmp, matrix_work, 0.5_dp, 0.5_dp)
1520 1680 : CALL dbcsr_copy(matrix, matrix_tmp)
1521 :
1522 : ! Avoid the buildup of noisy blocks
1523 1680 : CALL dbcsr_filter(matrix, eps_filter)
1524 :
1525 1680 : CALL dbcsr_release(matrix_tmp)
1526 1680 : CALL dbcsr_release(matrix_work)
1527 1680 : CALL timestop(handle)
1528 :
1529 1680 : END SUBROUTINE transform_m_orth
1530 :
1531 : END MODULE ec_orth_solver
|
