(git:8dd14c0)
Loading...
Searching...
No Matches
qs_tddfpt2_fhxc_forces.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
10 USE admm_types, ONLY: admm_type,&
14 USE cell_types, ONLY: cell_type,&
15 pbc
19 USE cp_dbcsr_api, ONLY: &
24 dbcsr_type_antisymmetric, dbcsr_type_no_symmetry
39 USE cp_fm_types, ONLY: cp_fm_create,&
61 USE hfx_ri, ONLY: hfx_ri_update_forces,&
63 USE hfx_types, ONLY: hfx_type
76 USE kinds, ONLY: default_string_length,&
77 dp
78 USE mathconstants, ONLY: oorootpi
83 USE pw_env_types, ONLY: pw_env_get,&
85 USE pw_methods, ONLY: pw_axpy,&
86 pw_scale,&
92 USE pw_types, ONLY: pw_c1d_gs_type,&
99 USE qs_fxc, ONLY: qs_fgxc_analytic,&
104 USE qs_integrate_potential, ONLY: integrate_v_rspace
106 USE qs_kind_types, ONLY: qs_kind_type
107 USE qs_ks_atom, ONLY: update_ks_atom
108 USE qs_ks_types, ONLY: qs_ks_env_type
114 USE qs_oce_types, ONLY: allocate_oce_set,&
120 USE qs_rho0_methods, ONLY: init_rho0
124 USE qs_rho_types, ONLY: qs_rho_create,&
125 qs_rho_get,&
126 qs_rho_set,&
137 USE util, ONLY: get_limit
138 USE virial_types, ONLY: virial_type
139#include "./base/base_uses.f90"
140
141 IMPLICIT NONE
142
143 PRIVATE
144
145 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_tddfpt2_fhxc_forces'
146
147 PUBLIC :: fhxc_force, stda_force
148
149! **************************************************************************************************
150
151CONTAINS
152
153! **************************************************************************************************
154!> \brief Calculate direct tddft forces. Calculate the three last terms of the response vector
155!> in equation 49 and the first term of \Lambda_munu in equation 51 in
156!> J. Chem. Theory Comput. 2022, 18, 7, 4186–4202 (https://doi.org/10.1021/acs.jctc.2c00144)
157!> \param qs_env Holds all system information relevant for the calculation.
158!> \param ex_env Holds the response vector ex_env%cpmos and Lambda ex_env%matrix_wx1.
159!> \param gs_mos MO coefficients of the ground state.
160!> \param full_kernel ...
161!> \param debug_forces ...
162!> \par History
163!> * 01.2020 screated [JGH]
164! **************************************************************************************************
165 SUBROUTINE fhxc_force(qs_env, ex_env, gs_mos, full_kernel, debug_forces)
166
167 TYPE(qs_environment_type), POINTER :: qs_env
168 TYPE(excited_energy_type), POINTER :: ex_env
169 TYPE(tddfpt_ground_state_mos), DIMENSION(:), &
170 POINTER :: gs_mos
171 TYPE(full_kernel_env_type), INTENT(IN) :: full_kernel
172 LOGICAL, INTENT(IN) :: debug_forces
173
174 CHARACTER(LEN=*), PARAMETER :: routinen = 'fhxc_force'
175
176 CHARACTER(LEN=default_string_length) :: basis_type
177 INTEGER :: handle, iounit, ispin, mspin, myfun, &
178 n_rep_hf, nao, nao_aux, natom, nkind, &
179 norb(2), nspins, order, spin
180 LOGICAL :: distribute_fock_matrix, do_admm, do_analytic, do_hfx, do_hfxlr, do_hfxsr, &
181 do_numeric, do_sf, gapw, gapw_xc, hfx_treat_lsd_in_core, is_rks_triplets, &
182 s_mstruct_changed, use_virial
183 REAL(kind=dp) :: eh1, eh1c, eps_delta, eps_fit, focc, &
184 fscal, fval, kval, xehartree
185 REAL(kind=dp), DIMENSION(3) :: fodeb
186 TYPE(admm_type), POINTER :: admm_env
187 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
188 TYPE(cp_fm_struct_type), POINTER :: fm_struct, fm_struct_mat
189 TYPE(cp_fm_type) :: cvcmat, vcvec
190 TYPE(cp_fm_type), DIMENSION(:), POINTER :: cpmos, evect
191 TYPE(cp_fm_type), POINTER :: mos, mos2
192 TYPE(cp_logger_type), POINTER :: logger
193 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_fx, matrix_gx, matrix_hfx, &
194 matrix_hfx_admm, matrix_hfx_admm_asymm, matrix_hfx_asymm, matrix_hx, matrix_p, &
195 matrix_p_admm, matrix_px1, matrix_px1_admm, matrix_px1_admm_asymm, matrix_px1_asymm, &
196 matrix_s, matrix_s_aux_fit, matrix_wx1, mdum, mfx, mgx
197 TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mhe, mpe, mpga
198 TYPE(dbcsr_type), POINTER :: dbwork, dbwork_asymm
199 TYPE(dft_control_type), POINTER :: dft_control
200 TYPE(hartree_local_type), POINTER :: hartree_local
201 TYPE(hfx_type), DIMENSION(:, :), POINTER :: x_data
202 TYPE(local_rho_type), POINTER :: local_rho_set, local_rho_set_admm, local_rho_set_f, &
203 local_rho_set_f_admm, local_rho_set_g, local_rho_set_g_admm
204 TYPE(mp_para_env_type), POINTER :: para_env
205 TYPE(neighbor_list_set_p_type), DIMENSION(:), &
206 POINTER :: sab, sab_aux_fit, sab_orb, sap_oce
207 TYPE(oce_matrix_type), POINTER :: oce
208 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
209 TYPE(pw_c1d_gs_type) :: rhox_tot_gspace, xv_hartree_gspace
210 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g_aux, rhox_g, rhox_g_aux, rhoxx_g
211 TYPE(pw_env_type), POINTER :: pw_env
212 TYPE(pw_poisson_type), POINTER :: poisson_env
213 TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
214 TYPE(pw_r3d_rs_type) :: xv_hartree_rspace
215 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: fxc_rho, fxc_tau, gxc_rho, gxc_tau, &
216 rho_r_aux, rhox_r, rhox_r_aux, rhoxx_r
217 TYPE(qs_force_type), DIMENSION(:), POINTER :: force
218 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
219 TYPE(qs_ks_env_type), POINTER :: ks_env
220 TYPE(qs_rho_type), POINTER :: rho, rho_aux_fit, rhox, rhox_aux
221 TYPE(rho_atom_type), DIMENSION(:), POINTER :: rho_atom_set, rho_atom_set_f, &
222 rho_atom_set_g
223 TYPE(section_vals_type), POINTER :: hfx_section, xc_section
224 TYPE(task_list_type), POINTER :: task_list
225 TYPE(tddfpt2_control_type), POINTER :: tddfpt_control
226
227 CALL timeset(routinen, handle)
228
229 logger => cp_get_default_logger()
230 IF (logger%para_env%is_source()) THEN
231 iounit = cp_logger_get_default_unit_nr(logger, local=.true.)
232 ELSE
233 iounit = -1
234 END IF
235
236 CALL get_qs_env(qs_env, dft_control=dft_control)
237 tddfpt_control => dft_control%tddfpt2_control
238 nspins = dft_control%nspins
239 is_rks_triplets = tddfpt_control%rks_triplets .AND. (nspins == 1)
240 IF (tddfpt_control%spinflip == no_sf_tddfpt) THEN
241 do_sf = .false.
242 ELSE
243 do_sf = .true.
244 END IF
245 cpassert(tddfpt_control%kernel == tddfpt_kernel_full)
246 do_hfx = tddfpt_control%do_hfx
247 do_hfxsr = tddfpt_control%do_hfxsr
248 do_hfxlr = tddfpt_control%do_hfxlr
249 do_admm = tddfpt_control%do_admm
250 gapw = dft_control%qs_control%gapw
251 gapw_xc = dft_control%qs_control%gapw_xc
252
253 evect => ex_env%evect
254 matrix_px1 => ex_env%matrix_px1
255 matrix_px1_admm => ex_env%matrix_px1_admm
256 matrix_px1_asymm => ex_env%matrix_px1_asymm
257 matrix_px1_admm_asymm => ex_env%matrix_px1_admm_asymm
258
259 focc = 1.0_dp
260 IF (nspins == 2) focc = 0.5_dp
261 DO ispin = 1, SIZE(evect, 1)
262 ! Calculate (C*X^T + X*C^T)/2
263 CALL dbcsr_set(matrix_px1(ispin)%matrix, 0.0_dp)
264 CALL cp_fm_get_info(evect(ispin), ncol_global=norb(ispin))
265 CALL cp_dbcsr_plus_fm_fm_t(matrix_px1(ispin)%matrix, &
266 matrix_v=evect(ispin), &
267 matrix_g=gs_mos(ispin)%mos_occ, &
268 ncol=norb(ispin), alpha=2.0_dp*focc, symmetry_mode=1)
269
270 ! Calculate (C*X^T - X*C^T)/2
271 CALL dbcsr_set(matrix_px1_asymm(ispin)%matrix, 0.0_dp)
272 CALL cp_fm_get_info(evect(ispin), ncol_global=norb(ispin))
273 CALL cp_dbcsr_plus_fm_fm_t(matrix_px1_asymm(ispin)%matrix, &
274 matrix_v=gs_mos(ispin)%mos_occ, &
275 matrix_g=evect(ispin), &
276 ncol=norb(ispin), alpha=2.0_dp*focc, &
277 symmetry_mode=-1)
278 END DO
279 !
280 CALL get_qs_env(qs_env, ks_env=ks_env, pw_env=pw_env, para_env=para_env)
281 !
282 NULLIFY (hartree_local, local_rho_set, local_rho_set_admm)
283 IF (gapw .OR. gapw_xc) THEN
284 IF (nspins == 2) THEN
285 DO ispin = 1, SIZE(evect, 1)
286 CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
287 END DO
288 END IF
289 CALL get_qs_env(qs_env, &
290 atomic_kind_set=atomic_kind_set, &
291 qs_kind_set=qs_kind_set)
292 CALL local_rho_set_create(local_rho_set)
293 CALL allocate_rho_atom_internals(local_rho_set%rho_atom_set, atomic_kind_set, &
294 qs_kind_set, dft_control, para_env)
295 IF (gapw) THEN
296 CALL get_qs_env(qs_env, natom=natom)
297 CALL init_rho0(local_rho_set, qs_env, dft_control%qs_control%gapw_control, &
298 zcore=0.0_dp)
299 CALL rho0_s_grid_create(pw_env, local_rho_set%rho0_mpole)
300 CALL hartree_local_create(hartree_local)
301 CALL init_coulomb_local(hartree_local, natom)
302 END IF
303
304 CALL get_qs_env(qs_env=qs_env, oce=oce, sap_oce=sap_oce, sab_orb=sab)
305 CALL create_oce_set(oce)
306 CALL get_qs_env(qs_env=qs_env, nkind=nkind, particle_set=particle_set)
307 CALL allocate_oce_set(oce, nkind)
308 eps_fit = dft_control%qs_control%gapw_control%eps_fit
309 CALL build_oce_matrices(oce%intac, .true., 1, qs_kind_set, particle_set, &
310 sap_oce, eps_fit)
311 CALL set_qs_env(qs_env, oce=oce)
312
313 mpga(1:SIZE(evect, 1), 1:1) => matrix_px1(1:SIZE(evect, 1))
314 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set%rho_atom_set, &
315 qs_kind_set, oce, sab, para_env)
316 CALL prepare_gapw_den(qs_env, local_rho_set, do_rho0=gapw)
317 !
318 CALL local_rho_set_create(local_rho_set_f)
319 CALL allocate_rho_atom_internals(local_rho_set_f%rho_atom_set, atomic_kind_set, &
320 qs_kind_set, dft_control, para_env)
321 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_f%rho_atom_set, &
322 qs_kind_set, oce, sab, para_env)
323 CALL prepare_gapw_den(qs_env, local_rho_set_f, do_rho0=.false.)
324 !
325 CALL local_rho_set_create(local_rho_set_g)
326 CALL allocate_rho_atom_internals(local_rho_set_g%rho_atom_set, atomic_kind_set, &
327 qs_kind_set, dft_control, para_env)
328 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_g%rho_atom_set, &
329 qs_kind_set, oce, sab, para_env)
330 CALL prepare_gapw_den(qs_env, local_rho_set_g, do_rho0=.false.)
331 IF (nspins == 2) THEN
332 DO ispin = 1, SIZE(evect, 1)
333 CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
334 END DO
335 END IF
336 END IF
337 !
338 IF (do_admm) THEN
339 CALL get_qs_env(qs_env, admm_env=admm_env)
340 nao_aux = admm_env%nao_aux_fit
341 nao = admm_env%nao_orb
342 ! Fit the symmetrized and antisymmetrized matrices
343 DO ispin = 1, SIZE(evect, 1)
344
345 CALL copy_dbcsr_to_fm(matrix_px1(ispin)%matrix, admm_env%work_orb_orb)
346 CALL parallel_gemm('N', 'N', nao_aux, nao, nao, &
347 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
348 admm_env%work_aux_orb)
349 CALL parallel_gemm('N', 'T', nao_aux, nao_aux, nao, &
350 1.0_dp, admm_env%work_aux_orb, admm_env%A, 0.0_dp, &
351 admm_env%work_aux_aux)
352 CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_px1_admm(ispin)%matrix, &
353 keep_sparsity=.true.)
354
355 CALL copy_dbcsr_to_fm(matrix_px1_asymm(ispin)%matrix, admm_env%work_orb_orb)
356 CALL parallel_gemm('N', 'N', nao_aux, nao, nao, &
357 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
358 admm_env%work_aux_orb)
359 CALL parallel_gemm('N', 'T', nao_aux, nao_aux, nao, &
360 1.0_dp, admm_env%work_aux_orb, admm_env%A, 0.0_dp, &
361 admm_env%work_aux_aux)
362 CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_px1_admm_asymm(ispin)%matrix, &
363 keep_sparsity=.true.)
364 END DO
365 !
366 IF (admm_env%do_gapw) THEN
367 IF (do_admm .AND. tddfpt_control%admm_xc_correction) THEN
368 IF (admm_env%aux_exch_func == do_admm_aux_exch_func_none) THEN
369 ! nothing to do
370 ELSE
371 CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set)
372 CALL local_rho_set_create(local_rho_set_admm)
373 CALL allocate_rho_atom_internals(local_rho_set_admm%rho_atom_set, atomic_kind_set, &
374 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
375 mpga(1:SIZE(evect, 1), 1:1) => matrix_px1_admm(1:SIZE(evect, 1))
376 CALL get_admm_env(admm_env, sab_aux_fit=sab_aux_fit)
377 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_admm%rho_atom_set, &
378 admm_env%admm_gapw_env%admm_kind_set, &
379 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
380 CALL prepare_gapw_den(qs_env, local_rho_set_admm, do_rho0=.false., &
381 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
382 !
383 CALL local_rho_set_create(local_rho_set_f_admm)
384 CALL allocate_rho_atom_internals(local_rho_set_f_admm%rho_atom_set, atomic_kind_set, &
385 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
386 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_f_admm%rho_atom_set, &
387 admm_env%admm_gapw_env%admm_kind_set, &
388 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
389 CALL prepare_gapw_den(qs_env, local_rho_set_f_admm, do_rho0=.false., &
390 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
391 !
392 CALL local_rho_set_create(local_rho_set_g_admm)
393 CALL allocate_rho_atom_internals(local_rho_set_g_admm%rho_atom_set, atomic_kind_set, &
394 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
395 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_g_admm%rho_atom_set, &
396 admm_env%admm_gapw_env%admm_kind_set, &
397 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
398 CALL prepare_gapw_den(qs_env, local_rho_set_g_admm, do_rho0=.false., &
399 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
400 END IF
401 END IF
402 END IF
403 END IF
404 !
405 CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, &
406 poisson_env=poisson_env)
407
408 ALLOCATE (rhox_r(SIZE(evect, 1)), rhox_g(SIZE(evect, 1)))
409 DO ispin = 1, SIZE(evect, 1)
410 CALL auxbas_pw_pool%create_pw(rhox_r(ispin))
411 CALL auxbas_pw_pool%create_pw(rhox_g(ispin))
412 END DO
413 CALL auxbas_pw_pool%create_pw(rhox_tot_gspace)
414
415 CALL pw_zero(rhox_tot_gspace)
416 DO ispin = 1, SIZE(evect, 1)
417 ! Calculate gridpoint values of the density associated to 2*matrix_px1 = C*X^T + X*C^T
418 IF (nspins == 2) CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
419 CALL calculate_rho_elec(ks_env=ks_env, matrix_p=matrix_px1(ispin)%matrix, &
420 rho=rhox_r(ispin), rho_gspace=rhox_g(ispin), &
421 soft_valid=gapw)
422 ! rhox_tot_gspace contains the values on the grid points of rhox = sum_munu 4D^X_munu*mu(r)*nu(r)
423 CALL pw_axpy(rhox_g(ispin), rhox_tot_gspace)
424 ! Recover matrix_px1 = (C*X^T + X*C^T)/2
425 IF (nspins == 2) CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
426 END DO
427
428 IF (gapw_xc) THEN
429 ALLOCATE (rhoxx_r(SIZE(evect, 1)), rhoxx_g(SIZE(evect, 1)))
430 DO ispin = 1, SIZE(evect, 1)
431 CALL auxbas_pw_pool%create_pw(rhoxx_r(ispin))
432 CALL auxbas_pw_pool%create_pw(rhoxx_g(ispin))
433 END DO
434 DO ispin = 1, SIZE(evect, 1)
435 IF (nspins == 2) CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
436 CALL calculate_rho_elec(ks_env=ks_env, matrix_p=matrix_px1(ispin)%matrix, &
437 rho=rhoxx_r(ispin), rho_gspace=rhoxx_g(ispin), &
438 soft_valid=gapw_xc)
439 IF (nspins == 2) CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
440 END DO
441 END IF
442
443 CALL get_qs_env(qs_env, matrix_s=matrix_s, force=force)
444
445 IF (.NOT. (is_rks_triplets .OR. do_sf)) THEN
446 CALL auxbas_pw_pool%create_pw(xv_hartree_rspace)
447 CALL auxbas_pw_pool%create_pw(xv_hartree_gspace)
448 ! calculate associated hartree potential
449 IF (gapw) THEN
450 CALL pw_axpy(local_rho_set%rho0_mpole%rho0_s_gs, rhox_tot_gspace)
451 IF (ASSOCIATED(local_rho_set%rho0_mpole%rhoz_cneo_s_gs)) THEN
452 CALL pw_axpy(local_rho_set%rho0_mpole%rhoz_cneo_s_gs, rhox_tot_gspace)
453 END IF
454 END IF
455 CALL pw_poisson_solve(poisson_env, rhox_tot_gspace, xehartree, &
456 xv_hartree_gspace)
457 CALL pw_transfer(xv_hartree_gspace, xv_hartree_rspace)
458 CALL pw_scale(xv_hartree_rspace, xv_hartree_rspace%pw_grid%dvol)
459 !
460 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
461 NULLIFY (matrix_hx)
462 CALL dbcsr_allocate_matrix_set(matrix_hx, nspins)
463 DO ispin = 1, nspins
464 ALLOCATE (matrix_hx(ispin)%matrix)
465 CALL dbcsr_create(matrix_hx(ispin)%matrix, template=matrix_s(1)%matrix)
466 CALL dbcsr_copy(matrix_hx(ispin)%matrix, matrix_s(1)%matrix)
467 CALL dbcsr_set(matrix_hx(ispin)%matrix, 0.0_dp)
468 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=xv_hartree_rspace, &
469 pmat=matrix_px1(ispin), hmat=matrix_hx(ispin), &
470 gapw=gapw, calculate_forces=.true.)
471 END DO
472 IF (debug_forces) THEN
473 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
474 CALL para_env%sum(fodeb)
475 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dKh[Dx] ", fodeb
476 END IF
477 IF (gapw) THEN
478 IF (debug_forces) fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1)
479 CALL vh_1c_gg_integrals(qs_env, eh1c, hartree_local%ecoul_1c, local_rho_set, para_env, tddft=.true., &
480 core_2nd=.true.)
481 IF (nspins == 1) THEN
482 kval = 1.0_dp
483 ELSE
484 kval = 0.5_dp
485 END IF
486 CALL integrate_vhg0_rspace(qs_env, xv_hartree_rspace, para_env, calculate_forces=.true., &
487 local_rho_set=local_rho_set, kforce=kval)
488 IF (debug_forces) THEN
489 fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1) - fodeb(1:3)
490 CALL para_env%sum(fodeb)
491 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dKh[Dx]PAWg0", fodeb
492 END IF
493 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
494 CALL update_ks_atom(qs_env, matrix_hx, matrix_px1, forces=.true., &
495 rho_atom_external=local_rho_set%rho_atom_set)
496 IF (debug_forces) THEN
497 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
498 CALL para_env%sum(fodeb)
499 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dKh[Dx]PAW", fodeb
500 END IF
501 END IF
502 END IF
503
504 ! XC
505 IF (full_kernel%do_exck) THEN
506 cpabort("NYA")
507 END IF
508 NULLIFY (fxc_rho, fxc_tau, gxc_rho, gxc_tau)
509 xc_section => full_kernel%xc_section
510 CALL section_vals_val_get(xc_section, "XC_FUNCTIONAL%_SECTION_PARAMETERS_", &
511 i_val=myfun)
512 IF (.NOT. ((myfun == xc_none) .OR. (tddfpt_control%spinflip == tddfpt_sf_col))) THEN
513 SELECT CASE (ex_env%xc_kernel_method)
515 do_analytic = .true.
516 do_numeric = .true.
518 do_analytic = .true.
519 do_numeric = .false.
521 do_analytic = .false.
522 do_numeric = .true.
523 CASE DEFAULT
524 cpabort("invalid xc_kernel_method")
525 END SELECT
526 order = ex_env%diff_order
527 eps_delta = ex_env%eps_delta_rho
528
529 IF (gapw_xc) THEN
530 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho_xc=rho)
531 ELSE
532 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho=rho)
533 END IF
534 CALL qs_rho_get(rho, rho_ao=matrix_p)
535 NULLIFY (rhox)
536 ALLOCATE (rhox)
537 ! Create rhox object to collect all information on matrix_px1, including its values on the
538 ! grid points
539 CALL qs_rho_create(rhox)
540 IF (gapw_xc) THEN
541 CALL qs_rho_set(rho_struct=rhox, rho_ao=matrix_px1, rho_r=rhoxx_r, rho_g=rhoxx_g, &
542 rho_r_valid=.true., rho_g_valid=.true.)
543 ELSE
544 CALL qs_rho_set(rho_struct=rhox, rho_ao=matrix_px1, rho_r=rhox_r, rho_g=rhox_g, &
545 rho_r_valid=.true., rho_g_valid=.true.)
546 END IF
547 ! Calculate the exchange-correlation kernel derivative contribution, notice that for open-shell
548 ! rhox_r contains a factor of 2!
549 IF (do_analytic .AND. .NOT. do_numeric) THEN
550 IF (.NOT. do_sf) THEN
551 cpabort("Analytic 3rd EXC derivatives not available")
552 ELSE !TODO
553 CALL qs_fgxc_analytic(rho, rhox, xc_section, auxbas_pw_pool, &
554 fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
555 END IF
556 ELSEIF (do_numeric) THEN
557 IF (do_analytic) THEN
558 CALL qs_fgxc_gdiff(ks_env, rho, rhox, xc_section, order, eps_delta, is_rks_triplets, &
559 fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
560 ELSE
561 CALL qs_fgxc_create(ks_env, rho, rhox, xc_section, order, is_rks_triplets, &
562 fxc_rho, fxc_tau, gxc_rho, gxc_tau)
563 END IF
564 ELSE
565 cpabort("FHXC forces analytic/numeric")
566 END IF
567
568 ! Well, this is a hack :-(
569 ! When qs_rho_set() was called on rhox it assumed ownership of the passed arrays.
570 ! However, these arrays actually belong to ex_env. Hence, we can not call qs_rho_release()
571 ! because this would release the arrays. Instead we're simply going to deallocate rhox.
572 DEALLOCATE (rhox)
573
574 IF (nspins == 2) THEN
575 DO ispin = 1, nspins
576 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
577 IF (ASSOCIATED(gxc_tau)) CALL pw_scale(gxc_tau(ispin), 0.5_dp)
578 END DO
579 END IF
580 IF (gapw .OR. gapw_xc) THEN
581 IF (do_analytic .AND. .NOT. do_numeric) THEN
582 cpabort("Analytic 3rd EXC derivatives not available")
583 ELSEIF (do_numeric) THEN
584 IF (do_analytic) THEN
585 CALL gfxc_atom_diff(qs_env, ex_env%local_rho_set%rho_atom_set, &
586 local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, &
587 qs_kind_set, xc_section, is_rks_triplets, order, eps_delta)
588 ELSE
589 CALL calculate_gfxc_atom(qs_env, ex_env%local_rho_set%rho_atom_set, &
590 local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, &
591 qs_kind_set, xc_section, is_rks_triplets, order)
592 END IF
593 ELSE
594 cpabort("FHXC forces analytic/numeric")
595 END IF
596 END IF
597
598 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
599 NULLIFY (matrix_fx)
600 CALL dbcsr_allocate_matrix_set(matrix_fx, SIZE(fxc_rho))
601 DO ispin = 1, SIZE(fxc_rho, 1)
602 ALLOCATE (matrix_fx(ispin)%matrix)
603 CALL dbcsr_create(matrix_fx(ispin)%matrix, template=matrix_s(1)%matrix)
604 CALL dbcsr_copy(matrix_fx(ispin)%matrix, matrix_s(1)%matrix)
605 CALL dbcsr_set(matrix_fx(ispin)%matrix, 0.0_dp)
606 CALL pw_scale(fxc_rho(ispin), fxc_rho(ispin)%pw_grid%dvol)
607 ! Calculate 2sum_sigmatau<munu|fxc|sigmatau>D^X_sigmatau
608 ! fxc_rho here containes a factor of 2
609 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=fxc_rho(ispin), &
610 pmat=matrix_px1(ispin), hmat=matrix_fx(ispin), &
611 gapw=(gapw .OR. gapw_xc), calculate_forces=.true.)
612 END DO
613 IF (debug_forces) THEN
614 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
615 CALL para_env%sum(fodeb)
616 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dfxc[Dx] ", fodeb
617 END IF
618
619 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
620 NULLIFY (matrix_gx)
621 CALL dbcsr_allocate_matrix_set(matrix_gx, nspins)
622 ! Calculate exchange-correlation kernel derivative 2<D^X D^X|gxc|mu nu>
623 ! gxc comes with a factor of 4, so a factor of 1/2 is introduced
624 DO ispin = 1, nspins
625 ALLOCATE (matrix_gx(ispin)%matrix)
626 CALL dbcsr_create(matrix_gx(ispin)%matrix, template=matrix_s(1)%matrix)
627 CALL dbcsr_copy(matrix_gx(ispin)%matrix, matrix_s(1)%matrix)
628 CALL dbcsr_set(matrix_gx(ispin)%matrix, 0.0_dp)
629 CALL pw_scale(gxc_rho(ispin), gxc_rho(ispin)%pw_grid%dvol)
630 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
631 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=gxc_rho(ispin), &
632 pmat=matrix_p(ispin), hmat=matrix_gx(ispin), &
633 gapw=(gapw .OR. gapw_xc), calculate_forces=.true.)
634 CALL dbcsr_scale(matrix_gx(ispin)%matrix, 2.0_dp)
635 END DO
636 IF (debug_forces) THEN
637 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
638 CALL para_env%sum(fodeb)
639 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dgxc[Dx]", fodeb
640 END IF
641 CALL qs_fgxc_release(ks_env, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
642
643 IF (gapw .OR. gapw_xc) THEN
644 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
645 CALL update_ks_atom(qs_env, matrix_fx, matrix_px1, forces=.true., tddft=.true., &
646 rho_atom_external=local_rho_set_f%rho_atom_set, &
647 kintegral=1.0_dp, kforce=1.0_dp)
648 IF (debug_forces) THEN
649 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
650 CALL para_env%sum(fodeb)
651 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dfxc[Dx]PAW ", fodeb
652 END IF
653 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
654 IF (nspins == 1) THEN
655 CALL update_ks_atom(qs_env, matrix_gx, matrix_p, forces=.true., tddft=.true., &
656 rho_atom_external=local_rho_set_g%rho_atom_set, &
657 kscale=0.5_dp)
658 ELSE
659 CALL update_ks_atom(qs_env, matrix_gx, matrix_p, forces=.true., &
660 rho_atom_external=local_rho_set_g%rho_atom_set, &
661 kintegral=0.5_dp, kforce=0.25_dp)
662 END IF
663 IF (debug_forces) THEN
664 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
665 CALL para_env%sum(fodeb)
666 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dgxc[Dx]PAW ", fodeb
667 END IF
668 END IF
669 END IF
670
671 ! ADMM XC correction Exc[rho_admm]
672 IF (do_admm .AND. tddfpt_control%admm_xc_correction .AND. (tddfpt_control%spinflip .NE. tddfpt_sf_col)) THEN
673 IF (admm_env%aux_exch_func == do_admm_aux_exch_func_none) THEN
674 ! nothing to do
675 ELSE
676 IF (.NOT. tddfpt_control%admm_symm) THEN
677 CALL cp_warn(__location__, "Forces need symmetric ADMM kernel corrections")
678 cpabort("ADMM KERNEL CORRECTION")
679 END IF
680 xc_section => admm_env%xc_section_aux
681 CALL get_admm_env(admm_env, rho_aux_fit=rho_aux_fit, matrix_s_aux_fit=matrix_s_aux_fit, &
682 task_list_aux_fit=task_list)
683 basis_type = "AUX_FIT"
684 IF (admm_env%do_gapw) THEN
685 basis_type = "AUX_FIT_SOFT"
686 task_list => admm_env%admm_gapw_env%task_list
687 END IF
688 !
689 NULLIFY (mfx, mgx)
690 CALL dbcsr_allocate_matrix_set(mfx, SIZE(evect, 1))
691 CALL dbcsr_allocate_matrix_set(mgx, nspins)
692 DO ispin = 1, SIZE(evect, 1)
693 ALLOCATE (mfx(ispin)%matrix)
694 CALL dbcsr_create(mfx(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
695 CALL dbcsr_copy(mfx(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
696 CALL dbcsr_set(mfx(ispin)%matrix, 0.0_dp)
697 END DO
698 DO ispin = 1, nspins
699 ALLOCATE (mgx(ispin)%matrix)
700 CALL dbcsr_create(mgx(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
701 CALL dbcsr_copy(mgx(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
702 CALL dbcsr_set(mgx(ispin)%matrix, 0.0_dp)
703 END DO
704
705 ! ADMM density and response density
706 NULLIFY (rho_g_aux, rho_r_aux, rhox_g_aux, rhox_r_aux)
707 CALL qs_rho_get(rho_aux_fit, rho_r=rho_r_aux, rho_g=rho_g_aux)
708 CALL qs_rho_get(rho_aux_fit, rho_ao=matrix_p_admm)
709 ! rhox_aux
710 ALLOCATE (rhox_r_aux(SIZE(evect, 1)), rhox_g_aux(SIZE(evect, 1)))
711 DO ispin = 1, SIZE(evect, 1)
712 CALL auxbas_pw_pool%create_pw(rhox_r_aux(ispin))
713 CALL auxbas_pw_pool%create_pw(rhox_g_aux(ispin))
714 END DO
715 DO ispin = 1, SIZE(evect, 1)
716 CALL calculate_rho_elec(ks_env=ks_env, matrix_p=matrix_px1_admm(ispin)%matrix, &
717 rho=rhox_r_aux(ispin), rho_gspace=rhox_g_aux(ispin), &
718 basis_type=basis_type, &
719 task_list_external=task_list)
720 END DO
721 !
722 NULLIFY (rhox_aux)
723 ALLOCATE (rhox_aux)
724 CALL qs_rho_create(rhox_aux)
725 CALL qs_rho_set(rho_struct=rhox_aux, rho_ao=matrix_px1_admm, &
726 rho_r=rhox_r_aux, rho_g=rhox_g_aux, &
727 rho_r_valid=.true., rho_g_valid=.true.)
728 IF (do_analytic .AND. .NOT. do_numeric) THEN
729 cpabort("Analytic 3rd derivatives of EXC not available")
730 ELSEIF (do_numeric) THEN
731 IF (do_analytic) THEN
732 CALL qs_fgxc_gdiff(ks_env, rho_aux_fit, rhox_aux, xc_section, order, eps_delta, &
733 is_rks_triplets, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
734 ELSE
735 CALL qs_fgxc_create(ks_env, rho_aux_fit, rhox_aux, xc_section, &
736 order, is_rks_triplets, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
737 END IF
738 ELSE
739 cpabort("FHXC forces analytic/numeric")
740 END IF
741
742 ! Well, this is a hack :-(
743 ! When qs_rho_set() was called on rhox_aux it assumed ownership of the passed arrays.
744 ! However, these arrays actually belong to ex_env. Hence, we can not call qs_rho_release()
745 ! because this would release the arrays. Instead we're simply going to deallocate rhox_aux.
746 DEALLOCATE (rhox_aux)
747
748 DO ispin = 1, SIZE(evect, 1)
749 CALL auxbas_pw_pool%give_back_pw(rhox_r_aux(ispin))
750 CALL auxbas_pw_pool%give_back_pw(rhox_g_aux(ispin))
751 END DO
752 DEALLOCATE (rhox_r_aux, rhox_g_aux)
753 fscal = 1.0_dp
754 IF (nspins == 2) fscal = 2.0_dp
755 !
756 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
757 DO ispin = 1, SIZE(evect, 1)
758 CALL pw_scale(fxc_rho(ispin), fxc_rho(ispin)%pw_grid%dvol)
759 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=fxc_rho(ispin), &
760 hmat=mfx(ispin), &
761 pmat=matrix_px1_admm(ispin), &
762 basis_type=basis_type, &
763 calculate_forces=.true., &
764 force_adm=fscal, &
765 task_list_external=task_list)
766 END DO
767 IF (debug_forces) THEN
768 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
769 CALL para_env%sum(fodeb)
770 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dfxc[Dx]ADMM", fodeb
771 END IF
772
773 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
774 DO ispin = 1, SIZE(evect, 1)
775 CALL pw_scale(gxc_rho(ispin), gxc_rho(ispin)%pw_grid%dvol)
776 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
777 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=gxc_rho(ispin), &
778 hmat=mgx(ispin), &
779 pmat=matrix_p_admm(ispin), &
780 basis_type=basis_type, &
781 calculate_forces=.true., &
782 force_adm=fscal, &
783 task_list_external=task_list)
784 CALL dbcsr_scale(mgx(ispin)%matrix, 2.0_dp)
785 END DO
786 IF (debug_forces) THEN
787 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
788 CALL para_env%sum(fodeb)
789 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dgxc[Dx]ADMM", fodeb
790 END IF
791 CALL qs_fgxc_release(ks_env, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
792 !
793 IF (admm_env%do_gapw) THEN
794 CALL get_admm_env(admm_env, sab_aux_fit=sab_aux_fit)
795 rho_atom_set => admm_env%admm_gapw_env%local_rho_set%rho_atom_set
796 rho_atom_set_f => local_rho_set_f_admm%rho_atom_set
797 rho_atom_set_g => local_rho_set_g_admm%rho_atom_set
798
799 IF (do_analytic .AND. .NOT. do_numeric) THEN
800 cpabort("Analytic 3rd EXC derivatives not available")
801 ELSEIF (do_numeric) THEN
802 IF (do_analytic) THEN
803 CALL gfxc_atom_diff(qs_env, rho_atom_set, &
804 rho_atom_set_f, rho_atom_set_g, &
805 admm_env%admm_gapw_env%admm_kind_set, xc_section, &
806 is_rks_triplets, order, eps_delta)
807 ELSE
808 CALL calculate_gfxc_atom(qs_env, rho_atom_set, &
809 rho_atom_set_f, rho_atom_set_g, &
810 admm_env%admm_gapw_env%admm_kind_set, xc_section, &
811 is_rks_triplets, order)
812 END IF
813 ELSE
814 cpabort("FHXC forces analytic/numeric")
815 END IF
816
817 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
818 IF (nspins == 1) THEN
819 CALL update_ks_atom(qs_env, mfx, matrix_px1_admm, forces=.true., &
820 rho_atom_external=rho_atom_set_f, &
821 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
822 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
823 kintegral=2.0_dp, kforce=0.5_dp)
824 ELSE
825 CALL update_ks_atom(qs_env, mfx, matrix_px1_admm, forces=.true., &
826 rho_atom_external=rho_atom_set_f, &
827 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
828 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
829 kintegral=2.0_dp, kforce=1.0_dp)
830 END IF
831 IF (debug_forces) THEN
832 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
833 CALL para_env%sum(fodeb)
834 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dfxc[Dx]ADMM-PAW ", fodeb
835 END IF
836 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
837 IF (nspins == 1) THEN
838 CALL update_ks_atom(qs_env, mgx, matrix_p, forces=.true., &
839 rho_atom_external=rho_atom_set_g, &
840 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
841 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
842 kintegral=1.0_dp, kforce=0.5_dp)
843 ELSE
844 CALL update_ks_atom(qs_env, mgx, matrix_p, forces=.true., &
845 rho_atom_external=rho_atom_set_g, &
846 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
847 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
848 kintegral=1.0_dp, kforce=1.0_dp)
849 END IF
850 IF (debug_forces) THEN
851 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
852 CALL para_env%sum(fodeb)
853 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dgxc[Dx]ADMM-PAW ", fodeb
854 END IF
855 END IF
856 !
857 ! A' fx A - Forces
858 !
859 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
860 fval = 2.0_dp*real(nspins, kind=dp)
861 CALL admm_projection_derivative(qs_env, mfx, matrix_px1, fval)
862 IF (debug_forces) THEN
863 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
864 CALL para_env%sum(fodeb)
865 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*dfXC(P)*S' ", fodeb
866 END IF
867 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
868 fval = 2.0_dp*real(nspins, kind=dp)
869 CALL admm_projection_derivative(qs_env, mgx, matrix_p, fval)
870 IF (debug_forces) THEN
871 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
872 CALL para_env%sum(fodeb)
873 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*dgXC(P)*S' ", fodeb
874 END IF
875 !
876 ! Add ADMM fx/gx to the full basis fx/gx
877 fscal = 1.0_dp
878 IF (nspins == 2) fscal = 2.0_dp
879 nao = admm_env%nao_orb
880 nao_aux = admm_env%nao_aux_fit
881 ALLOCATE (dbwork)
882 CALL dbcsr_create(dbwork, template=matrix_fx(1)%matrix)
883 DO ispin = 1, SIZE(evect, 1)
884 ! fx
885 CALL cp_dbcsr_sm_fm_multiply(mfx(ispin)%matrix, admm_env%A, &
886 admm_env%work_aux_orb, nao)
887 CALL parallel_gemm('T', 'N', nao, nao, nao_aux, &
888 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
889 admm_env%work_orb_orb)
890 CALL dbcsr_copy(dbwork, matrix_fx(1)%matrix)
891 CALL dbcsr_set(dbwork, 0.0_dp)
892 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork, keep_sparsity=.true.)
893 CALL dbcsr_add(matrix_fx(ispin)%matrix, dbwork, 1.0_dp, fscal)
894 ! gx
895 CALL cp_dbcsr_sm_fm_multiply(mgx(ispin)%matrix, admm_env%A, &
896 admm_env%work_aux_orb, nao)
897 CALL parallel_gemm('T', 'N', nao, nao, nao_aux, &
898 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
899 admm_env%work_orb_orb)
900 CALL dbcsr_set(dbwork, 0.0_dp)
901 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork, keep_sparsity=.true.)
902 CALL dbcsr_add(matrix_gx(ispin)%matrix, dbwork, 1.0_dp, fscal)
903 END DO
904 CALL dbcsr_release(dbwork)
905 DEALLOCATE (dbwork)
908
909 END IF
910 END IF
911
912 DO ispin = 1, SIZE(evect, 1)
913 CALL auxbas_pw_pool%give_back_pw(rhox_r(ispin))
914 CALL auxbas_pw_pool%give_back_pw(rhox_g(ispin))
915 END DO
916 DEALLOCATE (rhox_r, rhox_g)
917 CALL auxbas_pw_pool%give_back_pw(rhox_tot_gspace)
918 IF (gapw_xc) THEN
919 DO ispin = 1, SIZE(evect, 1)
920 CALL auxbas_pw_pool%give_back_pw(rhoxx_r(ispin))
921 CALL auxbas_pw_pool%give_back_pw(rhoxx_g(ispin))
922 END DO
923 DEALLOCATE (rhoxx_r, rhoxx_g)
924 END IF
925 IF (.NOT. (is_rks_triplets .OR. do_sf)) THEN
926 CALL auxbas_pw_pool%give_back_pw(xv_hartree_rspace)
927 CALL auxbas_pw_pool%give_back_pw(xv_hartree_gspace)
928 END IF
929
930 ! HFX
931 IF (do_hfx) THEN
932 NULLIFY (matrix_hfx, matrix_hfx_asymm)
933 CALL dbcsr_allocate_matrix_set(matrix_hfx, SIZE(evect, 1))
934 CALL dbcsr_allocate_matrix_set(matrix_hfx_asymm, SIZE(evect, 1))
935 DO ispin = 1, SIZE(evect, 1)
936 ALLOCATE (matrix_hfx(ispin)%matrix)
937 CALL dbcsr_create(matrix_hfx(ispin)%matrix, template=matrix_s(1)%matrix)
938 CALL dbcsr_copy(matrix_hfx(ispin)%matrix, matrix_s(1)%matrix)
939 CALL dbcsr_set(matrix_hfx(ispin)%matrix, 0.0_dp)
940
941 ALLOCATE (matrix_hfx_asymm(ispin)%matrix)
942 CALL dbcsr_create(matrix_hfx_asymm(ispin)%matrix, template=matrix_s(1)%matrix, &
943 matrix_type=dbcsr_type_antisymmetric)
944 CALL dbcsr_complete_redistribute(matrix_hfx(ispin)%matrix, matrix_hfx_asymm(ispin)%matrix)
945 END DO
946 !
947 xc_section => full_kernel%xc_section
948 hfx_section => section_vals_get_subs_vals(xc_section, "HF")
949 CALL section_vals_get(hfx_section, n_repetition=n_rep_hf)
950 cpassert(n_rep_hf == 1)
951 CALL section_vals_val_get(hfx_section, "TREAT_LSD_IN_CORE", l_val=hfx_treat_lsd_in_core, &
952 i_rep_section=1)
953 mspin = 1
954 IF (hfx_treat_lsd_in_core) mspin = SIZE(evect, 1)
955 !
956 CALL get_qs_env(qs_env=qs_env, x_data=x_data, s_mstruct_changed=s_mstruct_changed)
957 distribute_fock_matrix = .true.
958 !
959 IF (do_admm) THEN
960 CALL get_admm_env(qs_env%admm_env, matrix_s_aux_fit=matrix_s_aux_fit)
961 NULLIFY (matrix_hfx_admm, matrix_hfx_admm_asymm)
962 CALL dbcsr_allocate_matrix_set(matrix_hfx_admm, SIZE(evect, 1))
963 CALL dbcsr_allocate_matrix_set(matrix_hfx_admm_asymm, SIZE(evect, 1))
964 DO ispin = 1, SIZE(evect, 1)
965 ALLOCATE (matrix_hfx_admm(ispin)%matrix)
966 CALL dbcsr_create(matrix_hfx_admm(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
967 CALL dbcsr_copy(matrix_hfx_admm(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
968 CALL dbcsr_set(matrix_hfx_admm(ispin)%matrix, 0.0_dp)
969
970 ALLOCATE (matrix_hfx_admm_asymm(ispin)%matrix)
971 CALL dbcsr_create(matrix_hfx_admm_asymm(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix, &
972 matrix_type=dbcsr_type_antisymmetric)
973 CALL dbcsr_complete_redistribute(matrix_hfx_admm(ispin)%matrix, matrix_hfx_admm_asymm(ispin)%matrix)
974 END DO
975 !
976 NULLIFY (mpe, mhe)
977 ALLOCATE (mpe(SIZE(evect, 1), 1), mhe(SIZE(evect, 1), 1))
978 DO ispin = 1, SIZE(evect)
979 mhe(ispin, 1)%matrix => matrix_hfx_admm(ispin)%matrix
980 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
981 END DO
982 IF (x_data(1, 1)%do_hfx_ri) THEN
983 eh1 = 0.0_dp
984 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
985 geometry_did_change=s_mstruct_changed, nspins=nspins, &
986 hf_fraction=x_data(1, 1)%general_parameter%fraction)
987 ELSE
988 DO ispin = 1, mspin
989 eh1 = 0.0
990 CALL integrate_four_center(qs_env, x_data, mhe, eh1, mpe, hfx_section, &
991 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
992 ispin=ispin, nspins=SIZE(evect, 1))
993 END DO
994 END IF
995 !anti-symmetric density
996 DO ispin = 1, SIZE(evect, 1)
997 mhe(ispin, 1)%matrix => matrix_hfx_admm_asymm(ispin)%matrix
998 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
999 END DO
1000 IF (x_data(1, 1)%do_hfx_ri) THEN
1001 eh1 = 0.0_dp
1002 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1003 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1004 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1005 ELSE
1006 DO ispin = 1, mspin
1007 eh1 = 0.0
1008 CALL integrate_four_center(qs_env, x_data, mhe, eh1, mpe, hfx_section, &
1009 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1010 ispin=ispin, nspins=SIZE(evect, 1))
1011 END DO
1012 END IF
1013 !
1014 nao = admm_env%nao_orb
1015 nao_aux = admm_env%nao_aux_fit
1016 ALLOCATE (dbwork, dbwork_asymm)
1017 CALL dbcsr_create(dbwork, template=matrix_hfx(1)%matrix)
1018 CALL dbcsr_create(dbwork_asymm, template=matrix_hfx(1)%matrix, matrix_type=dbcsr_type_antisymmetric)
1019 DO ispin = 1, SIZE(evect, 1)
1020 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx_admm(ispin)%matrix, admm_env%A, &
1021 admm_env%work_aux_orb, nao)
1022 CALL parallel_gemm('T', 'N', nao, nao, nao_aux, &
1023 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
1024 admm_env%work_orb_orb)
1025 CALL dbcsr_copy(dbwork, matrix_hfx(1)%matrix)
1026 CALL dbcsr_set(dbwork, 0.0_dp)
1027 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork, keep_sparsity=.true.)
1028 CALL dbcsr_add(matrix_hfx(ispin)%matrix, dbwork, 1.0_dp, 1.0_dp)
1029 !anti-symmetric case
1030 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx_admm_asymm(ispin)%matrix, admm_env%A, &
1031 admm_env%work_aux_orb, nao)
1032 CALL parallel_gemm('T', 'N', nao, nao, nao_aux, &
1033 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
1034 admm_env%work_orb_orb)
1035 CALL dbcsr_copy(dbwork_asymm, matrix_hfx_asymm(1)%matrix)
1036 CALL dbcsr_set(dbwork_asymm, 0.0_dp)
1037 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork_asymm, keep_sparsity=.true.)
1038 CALL dbcsr_add(matrix_hfx_asymm(ispin)%matrix, dbwork_asymm, 1.0_dp, 1.0_dp)
1039 END DO
1040 CALL dbcsr_release(dbwork)
1041 CALL dbcsr_release(dbwork_asymm)
1042 DEALLOCATE (dbwork, dbwork_asymm)
1043 ! forces
1044 ! ADMM Projection force
1045 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
1046 fval = 4.0_dp*real(nspins, kind=dp)*0.5_dp !0.5 for symm/anti-symm
1047 CALL admm_projection_derivative(qs_env, matrix_hfx_admm, matrix_px1, fval)
1048 CALL admm_projection_derivative(qs_env, matrix_hfx_admm_asymm, matrix_px1_asymm, fval)
1049 IF (debug_forces) THEN
1050 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
1051 CALL para_env%sum(fodeb)
1052 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*Hx(P)*S' ", fodeb
1053 END IF
1054 !
1055 use_virial = .false.
1056 NULLIFY (mdum)
1057 fval = 2.0_dp*real(nspins, kind=dp)*0.5_dp !0.5 factor because of symemtry/anti-symmetry
1058 ! For SF TDDFT integrate_four_center and derivatives_four_center routines introduce a factor of 1/2
1059 IF (do_sf) fval = fval*2.0_dp
1060 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1061 DO ispin = 1, SIZE(evect, 1)
1062 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
1063 END DO
1064 IF (x_data(1, 1)%do_hfx_ri) THEN
1065 CALL hfx_ri_update_forces(qs_env, x_data(1, 1)%ri_data, nspins, &
1066 x_data(1, 1)%general_parameter%fraction, &
1067 rho_ao=mpe, rho_ao_resp=mdum, &
1068 use_virial=use_virial, rescale_factor=fval)
1069 ELSE
1070 CALL derivatives_four_center(qs_env, mpe, mdum, hfx_section, para_env, 1, use_virial, &
1071 adiabatic_rescale_factor=fval, nspins=SIZE(mpe, 1))
1072 END IF
1073 DO ispin = 1, SIZE(evect, 1)
1074 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1075 END DO
1076 IF (x_data(1, 1)%do_hfx_ri) THEN
1077 CALL hfx_ri_update_forces(qs_env, x_data(1, 1)%ri_data, nspins, &
1078 x_data(1, 1)%general_parameter%fraction, &
1079 rho_ao=mpe, rho_ao_resp=mdum, &
1080 use_virial=use_virial, rescale_factor=fval)
1081 ELSE
1082 CALL derivatives_four_center(qs_env, mpe, mdum, hfx_section, para_env, 1, use_virial, &
1083 adiabatic_rescale_factor=fval, nspins=SIZE(mpe, 1))
1084 END IF
1085 IF (debug_forces) THEN
1086 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
1087 CALL para_env%sum(fodeb)
1088 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dhfx'*Dx ", fodeb
1089 END IF
1090 !
1091 DEALLOCATE (mpe, mhe)
1092 !
1093 CALL dbcsr_deallocate_matrix_set(matrix_hfx_admm)
1094 CALL dbcsr_deallocate_matrix_set(matrix_hfx_admm_asymm)
1095 ELSE
1096 NULLIFY (mpe, mhe)
1097 ALLOCATE (mpe(SIZE(evect, 1), 1), mhe(SIZE(evect, 1), 1))
1098 DO ispin = 1, SIZE(evect, 1)
1099 mhe(ispin, 1)%matrix => matrix_hfx(ispin)%matrix
1100 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1101 END DO
1102 IF (x_data(1, 1)%do_hfx_ri) THEN
1103 eh1 = 0.0_dp
1104 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1105 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1106 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1107 ELSE
1108 DO ispin = 1, mspin
1109 eh1 = 0.0
1110 CALL integrate_four_center(qs_env, x_data, mhe, eh1, mpe, hfx_section, &
1111 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1112 ispin=ispin, nspins=SIZE(mpe, 1))
1113 END DO
1114 END IF
1115
1116 !anti-symmetric density matrix
1117 DO ispin = 1, SIZE(evect, 1)
1118 mhe(ispin, 1)%matrix => matrix_hfx_asymm(ispin)%matrix
1119 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1120 END DO
1121 IF (x_data(1, 1)%do_hfx_ri) THEN
1122 eh1 = 0.0_dp
1123 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1124 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1125 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1126 ELSE
1127 DO ispin = 1, mspin
1128 eh1 = 0.0
1129 CALL integrate_four_center(qs_env, x_data, mhe, eh1, mpe, hfx_section, &
1130 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1131 ispin=ispin, nspins=SIZE(mpe, 1))
1132 END DO
1133 END IF
1134 ! forces
1135 use_virial = .false.
1136 NULLIFY (mdum)
1137 fval = 2.0_dp*real(nspins, kind=dp)*0.5_dp !extra 0.5 factor because of symmetry/antisymemtry
1138 ! For SF TDDFT integrate_four_center and derivatives_four_center routines introduce a factor of 1/2
1139 IF (do_sf) fval = fval*2.0_dp
1140 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1141 DO ispin = 1, SIZE(evect, 1)
1142 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1143 END DO
1144 IF (x_data(1, 1)%do_hfx_ri) THEN
1145 CALL hfx_ri_update_forces(qs_env, x_data(1, 1)%ri_data, nspins, &
1146 x_data(1, 1)%general_parameter%fraction, &
1147 rho_ao=mpe, rho_ao_resp=mdum, &
1148 use_virial=use_virial, rescale_factor=fval)
1149 ELSE
1150 CALL derivatives_four_center(qs_env, mpe, mdum, hfx_section, para_env, 1, use_virial, &
1151 adiabatic_rescale_factor=fval, nspins=SIZE(mpe, 1))
1152 END IF
1153 DO ispin = 1, SIZE(evect, 1)
1154 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1155 END DO
1156 IF (x_data(1, 1)%do_hfx_ri) THEN
1157 CALL hfx_ri_update_forces(qs_env, x_data(1, 1)%ri_data, nspins, &
1158 x_data(1, 1)%general_parameter%fraction, &
1159 rho_ao=mpe, rho_ao_resp=mdum, &
1160 use_virial=use_virial, rescale_factor=fval)
1161 ELSE
1162 CALL derivatives_four_center(qs_env, mpe, mdum, hfx_section, para_env, 1, use_virial, &
1163 adiabatic_rescale_factor=fval, nspins=SIZE(mpe, 1))
1164 END IF
1165 IF (debug_forces) THEN
1166 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
1167 CALL para_env%sum(fodeb)
1168 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dhfx*Dx ", fodeb
1169 END IF
1170 !
1171 DEALLOCATE (mpe, mhe)
1172 END IF
1173 fval = 2.0_dp*real(nspins, kind=dp)*0.5_dp !extra 0.5 because of symm/antisymm
1174 ! For SF TDDFT integrate_four_center and derivatives_four_center routines introduce a factor of 1/2
1175 IF (do_sf) fval = fval*2.0_dp
1176 DO ispin = 1, SIZE(evect, 1)
1177 CALL dbcsr_scale(matrix_hfx(ispin)%matrix, fval)
1178 CALL dbcsr_scale(matrix_hfx_asymm(ispin)%matrix, fval)
1179 END DO
1180 END IF
1181
1182 IF (gapw .OR. gapw_xc) THEN
1183 CALL local_rho_set_release(local_rho_set)
1184 CALL local_rho_set_release(local_rho_set_f)
1185 CALL local_rho_set_release(local_rho_set_g)
1186 IF (gapw) THEN
1187 CALL hartree_local_release(hartree_local)
1188 END IF
1189 END IF
1190 IF (do_admm) THEN
1191 IF (admm_env%do_gapw) THEN
1192 IF (tddfpt_control%admm_xc_correction) THEN
1193 IF (qs_env%admm_env%aux_exch_func /= do_admm_aux_exch_func_none) THEN
1194 CALL local_rho_set_release(local_rho_set_admm)
1195 CALL local_rho_set_release(local_rho_set_f_admm)
1196 CALL local_rho_set_release(local_rho_set_g_admm)
1197 END IF
1198 END IF
1199 END IF
1200 END IF
1201
1202 ! HFX short range
1203 IF (do_hfxsr) THEN
1204 cpabort("HFXSR not implemented")
1205 END IF
1206 ! HFX long range
1207 IF (do_hfxlr) THEN
1208 cpabort("HFXLR not implemented")
1209 END IF
1210
1211 CALL get_qs_env(qs_env, sab_orb=sab_orb)
1212 NULLIFY (matrix_wx1)
1213 CALL dbcsr_allocate_matrix_set(matrix_wx1, nspins)
1214 cpmos => ex_env%cpmos
1215 focc = 2.0_dp
1216 IF (nspins == 2) focc = 1.0_dp
1217
1218 ! Initialize mos and dimensions of occupied space
1219 ! In the following comments mos is referred to as Ca and mos2 as Cb
1220 spin = 1
1221 mos => gs_mos(1)%mos_occ
1222 CALL cp_fm_get_info(mos, ncol_global=norb(1))
1223 IF (nspins == 2) THEN
1224 mos2 => gs_mos(2)%mos_occ
1225 CALL cp_fm_get_info(mos2, ncol_global=norb(2))
1226 END IF
1227 ! Build response vector, Eq. 49, and the third term of \Lamda_munu, Eq. 51
1228 DO ispin = 1, nspins
1229
1230 ! Initialize mos and dimensions of occupied space
1231 IF (.NOT. do_sf) THEN
1232 spin = ispin
1233 mos => gs_mos(ispin)%mos_occ
1234 mos2 => gs_mos(ispin)%mos_occ
1235 END IF
1236
1237 ! Create working fields for the response vector
1238 CALL cp_fm_create(vcvec, gs_mos(ispin)%mos_occ%matrix_struct, "vcvec")
1239 CALL cp_fm_get_info(vcvec, matrix_struct=fm_struct, nrow_global=nao)
1240 CALL cp_fm_struct_create(fm_struct_mat, context=fm_struct%context, nrow_global=norb(spin), &
1241 ncol_global=norb(ispin), para_env=fm_struct%para_env)
1242 CALL cp_fm_create(cvcmat, fm_struct_mat)
1243 CALL cp_fm_struct_release(fm_struct_mat)
1244 ! Allocate and initialize the Lambda matrix
1245 ALLOCATE (matrix_wx1(ispin)%matrix)
1246 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1247 CALL cp_dbcsr_alloc_block_from_nbl(matrix_wx1(ispin)%matrix, sab_orb)
1248 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1249
1250 ! Add Hartree contributions to the perturbation vector
1251 IF (.NOT. (is_rks_triplets .OR. do_sf)) THEN
1252 CALL cp_dbcsr_sm_fm_multiply(matrix_hx(ispin)%matrix, evect(ispin), &
1253 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1254 CALL cp_dbcsr_sm_fm_multiply(matrix_hx(ispin)%matrix, mos, vcvec, norb(ispin), alpha=1.0_dp, beta=0.0_dp)
1255 CALL parallel_gemm("T", "N", norb(ispin), norb(ispin), nao, 1.0_dp, mos, vcvec, 0.0_dp, cvcmat)
1256 CALL parallel_gemm("N", "N", nao, norb(ispin), norb(ispin), 1.0_dp, evect(ispin), cvcmat, 0.0_dp, vcvec)
1257 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1258 norb(ispin), alpha=-focc, beta=1.0_dp)
1259 !
1260 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=mos, matrix_g=vcvec, &
1261 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1262 END IF
1263 ! Add exchange-correlation kernel and exchange-correlation kernel derivative contributions to the response vector
1264 IF ((myfun /= xc_none) .AND. (tddfpt_control%spinflip /= tddfpt_sf_col)) THEN
1265
1266 ! XC Kernel contributions
1267 ! For spin-flip excitations this is the only contribution to the alpha response vector
1268 IF (.NOT. (do_sf .AND. (ispin .EQ. 2))) THEN
1269 ! F*X
1270 CALL cp_dbcsr_sm_fm_multiply(matrix_fx(spin)%matrix, evect(spin), &
1271 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1272 END IF
1273 ! For spin-flip excitations this is the only contribution to the beta response vector
1274 IF (.NOT. (do_sf .AND. (ispin .EQ. 1))) THEN
1275 ! F*Cb
1276 CALL cp_dbcsr_sm_fm_multiply(matrix_fx(spin)%matrix, mos2, vcvec, norb(ispin), alpha=1.0_dp, beta=0.0_dp)
1277 ! Ca^T*F*Cb
1278 CALL parallel_gemm("T", "N", norb(spin), norb(ispin), nao, 1.0_dp, mos, vcvec, 0.0_dp, cvcmat)
1279 ! X*Ca^T*F*Cb
1280 CALL parallel_gemm("N", "N", nao, norb(ispin), norb(spin), 1.0_dp, evect(spin), cvcmat, 0.0_dp, vcvec)
1281 ! -S*X*Ca^T*F*Cb
1282 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1283 norb(ispin), alpha=-focc, beta=1.0_dp)
1284 ! Add contributions to the \Lambda_munu for the perturbed overlap matrix term, third term of Eq. 51
1285 ! 2X*Ca^T*F*Cb*Cb^T
1286 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=gs_mos(ispin)%mos_occ, &
1287 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1288 END IF
1289 !
1290
1291 ! XC g (third functional derivative) contributions
1292 ! g*Ca*focc
1293 CALL cp_dbcsr_sm_fm_multiply(matrix_gx(ispin)%matrix, gs_mos(ispin)%mos_occ, &
1294 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1295 ! Add contributions to the \Lambda_munu for the perturbed overlap matrix term, third term of Eq. 51
1296 ! g*Ca
1297 CALL cp_dbcsr_sm_fm_multiply(matrix_gx(ispin)%matrix, gs_mos(ispin)%mos_occ, vcvec, norb(ispin), &
1298 alpha=1.0_dp, beta=0.0_dp)
1299 ! Ca^T*g*Ca
1300 CALL parallel_gemm("T", "N", norb(ispin), norb(ispin), nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1301 ! Ca*Ca^T*g*Ca
1302 CALL parallel_gemm("N", "N", nao, norb(ispin), norb(ispin), 1.0_dp, gs_mos(ispin)%mos_occ, cvcmat, 0.0_dp, vcvec)
1303 ! Ca*Ca^T*g*Ca*Ca^T
1304 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=gs_mos(ispin)%mos_occ, &
1305 ncol=norb(ispin), alpha=1.0_dp, symmetry_mode=1)
1306 !
1307 END IF
1308 ! Add Fock contributions to the response vector
1309 IF (do_hfx) THEN
1310 ! For spin-flip excitations this is the only contribution to the alpha response vector
1311 IF (.NOT. (do_sf .AND. (ispin .EQ. 2))) THEN
1312 ! F^sym*X
1313 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx(spin)%matrix, evect(spin), &
1314 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1315 ! F^asym*X
1316 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx_asymm(spin)%matrix, evect(spin), &
1317 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1318 END IF
1319
1320 ! For spin-flip excitations this is the only contribution to the beta response vector
1321 IF (.NOT. (do_sf .AND. (ispin .EQ. 1))) THEN
1322 ! F^sym*Cb
1323 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx(spin)%matrix, mos2, vcvec, norb(ispin), alpha=1.0_dp, beta=0.0_dp)
1324 ! -F^asym*Cb
1325 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx_asymm(spin)%matrix, mos2, vcvec, norb(ispin), &
1326 alpha=1.0_dp, beta=1.0_dp)
1327 ! Ca^T*F*Cb
1328 CALL parallel_gemm("T", "N", norb(spin), norb(ispin), nao, 1.0_dp, mos, vcvec, 0.0_dp, cvcmat)
1329 ! X*Ca^T*F*Cb
1330 CALL parallel_gemm("N", "N", nao, norb(ispin), norb(spin), 1.0_dp, evect(spin), cvcmat, 0.0_dp, vcvec)
1331 ! -S*X*Ca^T*F*Cb
1332 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1333 norb(ispin), alpha=-focc, beta=1.0_dp)
1334 ! Add contributions to the \Lambda_munu for the perturbed overlap matrix term, third term of Eq. 51
1335 ! 2X*Ca^T*F*Cb*Cb^T
1336 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=mos2, &
1337 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1338 END IF
1339 END IF
1340 !
1341 CALL cp_fm_release(vcvec)
1342 CALL cp_fm_release(cvcmat)
1343 END DO
1344
1345 IF (.NOT. (is_rks_triplets .OR. do_sf)) THEN
1346 CALL dbcsr_deallocate_matrix_set(matrix_hx)
1347 END IF
1348 IF (ASSOCIATED(ex_env%matrix_wx1)) CALL dbcsr_deallocate_matrix_set(ex_env%matrix_wx1)
1349 ex_env%matrix_wx1 => matrix_wx1
1350 IF (.NOT. ((myfun == xc_none) .OR. (tddfpt_control%spinflip == tddfpt_sf_col))) THEN
1351 CALL dbcsr_deallocate_matrix_set(matrix_fx)
1352 CALL dbcsr_deallocate_matrix_set(matrix_gx)
1353 END IF
1354 IF (do_hfx) THEN
1355 CALL dbcsr_deallocate_matrix_set(matrix_hfx)
1356 CALL dbcsr_deallocate_matrix_set(matrix_hfx_asymm)
1357 END IF
1358
1359 CALL timestop(handle)
1360
1361 END SUBROUTINE fhxc_force
1362
1363! **************************************************************************************************
1364!> \brief Simplified Tamm Dancoff approach (sTDA). Kernel contribution to forces
1365!> \param qs_env ...
1366!> \param ex_env ...
1367!> \param gs_mos ...
1368!> \param stda_env ...
1369!> \param sub_env ...
1370!> \param work ...
1371!> \param debug_forces ...
1372! **************************************************************************************************
1373 SUBROUTINE stda_force(qs_env, ex_env, gs_mos, stda_env, sub_env, work, debug_forces)
1374
1375 TYPE(qs_environment_type), POINTER :: qs_env
1376 TYPE(excited_energy_type), POINTER :: ex_env
1377 TYPE(tddfpt_ground_state_mos), DIMENSION(:), &
1378 POINTER :: gs_mos
1379 TYPE(stda_env_type), POINTER :: stda_env
1380 TYPE(tddfpt_subgroup_env_type) :: sub_env
1381 TYPE(tddfpt_work_matrices) :: work
1382 LOGICAL, INTENT(IN) :: debug_forces
1383
1384 CHARACTER(len=*), PARAMETER :: routinen = 'stda_force'
1385
1386 INTEGER :: atom_i, atom_j, ewald_type, handle, i, &
1387 ia, iatom, idimk, ikind, iounit, is, &
1388 ispin, jatom, jkind, jspin, nao, &
1389 natom, norb, nsgf, nspins
1390 INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, first_sgf, kind_of, &
1391 last_sgf
1392 INTEGER, DIMENSION(2) :: nactive, nlim
1393 LOGICAL :: calculate_forces, do_coulomb, do_ewald, &
1394 found, is_rks_triplets, use_virial
1395 REAL(kind=dp) :: alpha, bp, dgabr, dr, eta, fdim, gabr, &
1396 hfx, rbeta, spinfac, xfac
1397 REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: tcharge, tv
1398 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: gtcharge
1399 REAL(kind=dp), DIMENSION(3) :: fij, fodeb, rij
1400 REAL(kind=dp), DIMENSION(:, :), POINTER :: gab, pblock
1401 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
1402 TYPE(cell_type), POINTER :: cell
1403 TYPE(cp_fm_struct_type), POINTER :: fmstruct, fmstruct_mat, fmstructjspin
1404 TYPE(cp_fm_type) :: cvcmat, cvec, cvecjspin, t0matrix, &
1405 t1matrix, vcvec, xvec
1406 TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: xtransformed
1407 TYPE(cp_fm_type), DIMENSION(:), POINTER :: cpmos, x
1408 TYPE(cp_fm_type), POINTER :: ct, ctjspin, ucmatrix, uxmatrix
1409 TYPE(cp_logger_type), POINTER :: logger
1410 TYPE(dbcsr_iterator_type) :: iter
1411 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: gamma_matrix, matrix_plo, matrix_s, &
1412 matrix_wx1, scrm
1413 TYPE(dbcsr_type) :: pdens, ptrans
1414 TYPE(dbcsr_type), POINTER :: tempmat
1415 TYPE(dft_control_type), POINTER :: dft_control
1416 TYPE(ewald_environment_type), POINTER :: ewald_env
1417 TYPE(ewald_pw_type), POINTER :: ewald_pw
1418 TYPE(mp_para_env_type), POINTER :: para_env
1419 TYPE(neighbor_list_set_p_type), DIMENSION(:), &
1420 POINTER :: n_list, sab_orb
1421 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1422 TYPE(qs_force_type), DIMENSION(:), POINTER :: force
1423 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1424 TYPE(qs_ks_env_type), POINTER :: ks_env
1425 TYPE(stda_control_type), POINTER :: stda_control
1426 TYPE(tddfpt2_control_type), POINTER :: tddfpt_control
1427 TYPE(virial_type), POINTER :: virial
1428
1429 CALL timeset(routinen, handle)
1430
1431 cpassert(ASSOCIATED(ex_env))
1432 cpassert(ASSOCIATED(gs_mos))
1433
1434 logger => cp_get_default_logger()
1435 IF (logger%para_env%is_source()) THEN
1436 iounit = cp_logger_get_default_unit_nr(logger, local=.true.)
1437 ELSE
1438 iounit = -1
1439 END IF
1440
1441 CALL get_qs_env(qs_env, dft_control=dft_control)
1442 tddfpt_control => dft_control%tddfpt2_control
1443 stda_control => tddfpt_control%stda_control
1444 nspins = dft_control%nspins
1445 is_rks_triplets = tddfpt_control%rks_triplets .AND. (nspins == 1)
1446
1447 x => ex_env%evect
1448
1449 nactive(:) = stda_env%nactive(:)
1450 xfac = 2.0_dp
1451 spinfac = 2.0_dp
1452 IF (nspins == 2) spinfac = 1.0_dp
1453 NULLIFY (matrix_wx1)
1454 CALL dbcsr_allocate_matrix_set(matrix_wx1, nspins)
1455 NULLIFY (matrix_plo)
1456 CALL dbcsr_allocate_matrix_set(matrix_plo, nspins)
1457
1458 IF (nspins == 1 .AND. is_rks_triplets) THEN
1459 do_coulomb = .false.
1460 ELSE
1461 do_coulomb = .true.
1462 END IF
1463 do_ewald = stda_control%do_ewald
1464
1465 CALL get_qs_env(qs_env, para_env=para_env, force=force)
1466
1467 CALL get_qs_env(qs_env, natom=natom, cell=cell, &
1468 particle_set=particle_set, qs_kind_set=qs_kind_set)
1469 ALLOCATE (first_sgf(natom))
1470 ALLOCATE (last_sgf(natom))
1471 CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf, last_sgf=last_sgf)
1472
1473 CALL get_qs_env(qs_env, ks_env=ks_env, matrix_s=matrix_s, sab_orb=sab_orb, atomic_kind_set=atomic_kind_set)
1474 CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind)
1475
1476 ! calculate Loewdin transformed Davidson trial vector tilde(X)=S^1/2*X
1477 ! and tilde(tilde(X))=S^1/2_A*tilde(X)_A
1478 ALLOCATE (xtransformed(nspins))
1479 DO ispin = 1, nspins
1480 NULLIFY (fmstruct)
1481 ct => work%ctransformed(ispin)
1482 CALL cp_fm_get_info(ct, matrix_struct=fmstruct)
1483 CALL cp_fm_create(matrix=xtransformed(ispin), matrix_struct=fmstruct, name="XTRANSFORMED")
1484 END DO
1485 CALL get_lowdin_x(work%shalf, x, xtransformed)
1486
1487 ALLOCATE (tcharge(natom), gtcharge(natom, 4))
1488
1489 cpmos => ex_env%cpmos
1490
1491 DO ispin = 1, nspins
1492 ct => work%ctransformed(ispin)
1493 CALL cp_fm_get_info(ct, matrix_struct=fmstruct, nrow_global=nsgf)
1494 ALLOCATE (tv(nsgf))
1495 CALL cp_fm_create(cvec, fmstruct)
1496 CALL cp_fm_create(xvec, fmstruct)
1497 !
1498 ALLOCATE (matrix_wx1(ispin)%matrix)
1499 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1500 CALL cp_dbcsr_alloc_block_from_nbl(matrix_wx1(ispin)%matrix, sab_orb)
1501 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1502 ALLOCATE (matrix_plo(ispin)%matrix)
1503 CALL dbcsr_create(matrix=matrix_plo(ispin)%matrix, template=matrix_s(1)%matrix)
1504 CALL cp_dbcsr_alloc_block_from_nbl(matrix_plo(ispin)%matrix, sab_orb)
1505 CALL dbcsr_set(matrix_plo(ispin)%matrix, 0.0_dp)
1506 !
1507 ! *** Coulomb contribution
1508 !
1509 IF (do_coulomb) THEN
1510 !
1511 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1512 !
1513 tcharge(:) = 0.0_dp
1514 DO jspin = 1, nspins
1515 ctjspin => work%ctransformed(jspin)
1516 CALL cp_fm_get_info(ctjspin, matrix_struct=fmstructjspin)
1517 CALL cp_fm_get_info(ctjspin, matrix_struct=fmstructjspin, nrow_global=nsgf)
1518 CALL cp_fm_create(cvecjspin, fmstructjspin)
1519 ! CV(mu,j) = CT(mu,j)*XT(mu,j)
1520 CALL cp_fm_schur_product(ctjspin, xtransformed(jspin), cvecjspin)
1521 ! TV(mu) = SUM_j CV(mu,j)
1522 CALL cp_fm_vectorssum(cvecjspin, tv, "R")
1523 ! contract charges
1524 ! TC(a) = SUM_(mu of a) TV(mu)
1525 DO ia = 1, natom
1526 DO is = first_sgf(ia), last_sgf(ia)
1527 tcharge(ia) = tcharge(ia) + tv(is)
1528 END DO
1529 END DO
1530 CALL cp_fm_release(cvecjspin)
1531 END DO !jspin
1532 ! Apply tcharge*gab -> gtcharge
1533 ! gT(b) = SUM_a g(a,b)*TC(a)
1534 ! gab = work%gamma_exchange(1)%matrix
1535 gtcharge = 0.0_dp
1536 ! short range contribution
1537 NULLIFY (gamma_matrix)
1538 CALL setup_gamma(qs_env, stda_env, sub_env, gamma_matrix, ndim=4)
1539 tempmat => gamma_matrix(1)%matrix
1540 CALL dbcsr_iterator_start(iter, tempmat)
1541 DO WHILE (dbcsr_iterator_blocks_left(iter))
1542 CALL dbcsr_iterator_next_block(iter, iatom, jatom, gab)
1543 gtcharge(iatom, 1) = gtcharge(iatom, 1) + gab(1, 1)*tcharge(jatom)
1544 IF (iatom /= jatom) THEN
1545 gtcharge(jatom, 1) = gtcharge(jatom, 1) + gab(1, 1)*tcharge(iatom)
1546 END IF
1547 DO idimk = 2, 4
1548 fdim = -1.0_dp
1549 CALL dbcsr_get_block_p(matrix=gamma_matrix(idimk)%matrix, &
1550 row=iatom, col=jatom, block=gab, found=found)
1551 IF (found) THEN
1552 gtcharge(iatom, idimk) = gtcharge(iatom, idimk) + gab(1, 1)*tcharge(jatom)
1553 IF (iatom /= jatom) THEN
1554 gtcharge(jatom, idimk) = gtcharge(jatom, idimk) + fdim*gab(1, 1)*tcharge(iatom)
1555 END IF
1556 END IF
1557 END DO
1558 END DO
1559 CALL dbcsr_iterator_stop(iter)
1560 CALL dbcsr_deallocate_matrix_set(gamma_matrix)
1561 ! Ewald long range contribution
1562 IF (do_ewald) THEN
1563 ewald_env => work%ewald_env
1564 ewald_pw => work%ewald_pw
1565 CALL ewald_env_get(ewald_env, alpha=alpha, ewald_type=ewald_type)
1566 CALL get_qs_env(qs_env=qs_env, sab_orb=n_list, virial=virial)
1567 use_virial = .false.
1568 calculate_forces = .false.
1569 CALL tb_ewald_overlap(gtcharge, tcharge, alpha, n_list, virial, use_virial)
1570 CALL tb_spme_evaluate(ewald_env, ewald_pw, particle_set, cell, &
1571 gtcharge, tcharge, calculate_forces, virial, use_virial)
1572 ! add self charge interaction contribution
1573 IF (para_env%is_source()) THEN
1574 gtcharge(:, 1) = gtcharge(:, 1) - 2._dp*alpha*oorootpi*tcharge(:)
1575 END IF
1576 ELSE
1577 nlim = get_limit(natom, para_env%num_pe, para_env%mepos)
1578 DO iatom = nlim(1), nlim(2)
1579 DO jatom = 1, iatom - 1
1580 rij = particle_set(iatom)%r - particle_set(jatom)%r
1581 rij = pbc(rij, cell)
1582 dr = sqrt(sum(rij(:)**2))
1583 IF (dr > 1.e-6_dp) THEN
1584 gtcharge(iatom, 1) = gtcharge(iatom, 1) + tcharge(jatom)/dr
1585 gtcharge(jatom, 1) = gtcharge(jatom, 1) + tcharge(iatom)/dr
1586 DO idimk = 2, 4
1587 gtcharge(iatom, idimk) = gtcharge(iatom, idimk) + rij(idimk - 1)*tcharge(jatom)/dr**3
1588 gtcharge(jatom, idimk) = gtcharge(jatom, idimk) - rij(idimk - 1)*tcharge(iatom)/dr**3
1589 END DO
1590 END IF
1591 END DO
1592 END DO
1593 END IF
1594 CALL para_env%sum(gtcharge(:, 1))
1595 ! expand charges
1596 ! TV(mu) = TC(a of mu)
1597 tv(1:nsgf) = 0.0_dp
1598 DO ia = 1, natom
1599 DO is = first_sgf(ia), last_sgf(ia)
1600 tv(is) = gtcharge(ia, 1)
1601 END DO
1602 END DO
1603 !
1604 DO iatom = 1, natom
1605 ikind = kind_of(iatom)
1606 atom_i = atom_of_kind(iatom)
1607 DO i = 1, 3
1608 fij(i) = spinfac*spinfac*gtcharge(iatom, i + 1)*tcharge(iatom)
1609 END DO
1610 force(ikind)%rho_elec(1, atom_i) = force(ikind)%rho_elec(1, atom_i) - fij(1)
1611 force(ikind)%rho_elec(2, atom_i) = force(ikind)%rho_elec(2, atom_i) - fij(2)
1612 force(ikind)%rho_elec(3, atom_i) = force(ikind)%rho_elec(3, atom_i) - fij(3)
1613 END DO
1614 !
1615 IF (debug_forces) THEN
1616 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1617 CALL para_env%sum(fodeb)
1618 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Coul[X] ", fodeb
1619 END IF
1620 norb = nactive(ispin)
1621 ! forces from Lowdin charge derivative
1622 CALL cp_fm_get_info(work%S_C0_C0T(ispin), matrix_struct=fmstruct)
1623 CALL cp_fm_create(t0matrix, matrix_struct=fmstruct, name="T0 SCRATCH")
1624 CALL cp_fm_create(t1matrix, matrix_struct=fmstruct, name="T1 SCRATCH")
1625 ALLOCATE (ucmatrix)
1626 CALL fm_pool_create_fm(work%fm_pool_ao_mo_occ(ispin)%pool, ucmatrix)
1627 ALLOCATE (uxmatrix)
1628 CALL fm_pool_create_fm(work%fm_pool_ao_mo_occ(ispin)%pool, uxmatrix)
1629 ct => work%ctransformed(ispin)
1630 CALL cp_fm_to_fm(ct, cvec)
1631 CALL cp_fm_row_scale(cvec, tv)
1632 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1633 cvec, 0.0_dp, ucmatrix)
1634 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1635 x(ispin), 0.0_dp, uxmatrix)
1636 CALL parallel_gemm('N', 'T', nsgf, nsgf, norb, 1.0_dp, uxmatrix, ucmatrix, 0.0_dp, t0matrix)
1637 CALL cp_fm_to_fm(xtransformed(ispin), cvec)
1638 CALL cp_fm_row_scale(cvec, tv)
1639 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1640 cvec, 0.0_dp, uxmatrix)
1641 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1642 gs_mos(ispin)%mos_occ, 0.0_dp, ucmatrix)
1643 CALL parallel_gemm('N', 'T', nsgf, nsgf, norb, 1.0_dp, ucmatrix, uxmatrix, 1.0_dp, t0matrix)
1644 CALL cp_fm_schur_product(work%slambda, t0matrix, t1matrix)
1645 !
1646 CALL parallel_gemm('N', 'N', nsgf, nsgf, nsgf, spinfac, work%S_eigenvectors, t1matrix, &
1647 0.0_dp, t0matrix)
1648 CALL cp_dbcsr_plus_fm_fm_t(matrix_plo(ispin)%matrix, matrix_v=t0matrix, &
1649 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1650 CALL fm_pool_give_back_fm(work%fm_pool_ao_mo_occ(ispin)%pool, ucmatrix)
1651 DEALLOCATE (ucmatrix)
1652 CALL fm_pool_give_back_fm(work%fm_pool_ao_mo_occ(ispin)%pool, uxmatrix)
1653 DEALLOCATE (uxmatrix)
1654 CALL cp_fm_release(t0matrix)
1655 CALL cp_fm_release(t1matrix)
1656 !
1657 ! CV(mu,i) = TV(mu)*XT(mu,i)
1658 CALL cp_fm_to_fm(xtransformed(ispin), cvec)
1659 CALL cp_fm_row_scale(cvec, tv)
1660 CALL cp_dbcsr_sm_fm_multiply(work%shalf, cvec, cpmos(ispin), norb, 2.0_dp*spinfac, 1.0_dp)
1661 ! CV(mu,i) = TV(mu)*CT(mu,i)
1662 ct => work%ctransformed(ispin)
1663 CALL cp_fm_to_fm(ct, cvec)
1664 CALL cp_fm_row_scale(cvec, tv)
1665 ! Shalf(nu,mu)*CV(mu,i)
1666 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1667 CALL cp_fm_create(vcvec, fmstruct)
1668 CALL cp_dbcsr_sm_fm_multiply(work%shalf, cvec, vcvec, norb, 1.0_dp, 0.0_dp)
1669 CALL cp_fm_struct_create(fmstruct_mat, context=fmstruct%context, nrow_global=norb, &
1670 ncol_global=norb, para_env=fmstruct%para_env)
1671 CALL cp_fm_create(cvcmat, fmstruct_mat)
1672 CALL cp_fm_struct_release(fmstruct_mat)
1673 CALL parallel_gemm("T", "N", norb, norb, nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1674 CALL parallel_gemm("N", "N", nao, norb, norb, 1.0_dp, x(ispin), cvcmat, 0.0_dp, vcvec)
1675 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1676 nactive(ispin), alpha=-2.0_dp*spinfac, beta=1.0_dp)
1677 ! wx1
1678 alpha = 2.0_dp
1679 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=gs_mos(ispin)%mos_occ, &
1680 matrix_g=vcvec, ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1681 CALL cp_fm_release(vcvec)
1682 CALL cp_fm_release(cvcmat)
1683 END IF
1684 !
1685 ! *** Exchange contribution
1686 !
1687 IF (stda_env%do_exchange) THEN
1688 !
1689 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1690 !
1691 norb = nactive(ispin)
1692 !
1693 tempmat => work%shalf
1694 CALL dbcsr_create(pdens, template=tempmat, matrix_type=dbcsr_type_no_symmetry)
1695 ! P(nu,mu) = SUM_j XT(nu,j)*CT(mu,j)
1696 ct => work%ctransformed(ispin)
1697 CALL dbcsr_set(pdens, 0.0_dp)
1698 CALL cp_dbcsr_plus_fm_fm_t(pdens, xtransformed(ispin), ct, nactive(ispin), &
1699 1.0_dp, keep_sparsity=.false.)
1700 CALL dbcsr_filter(pdens, stda_env%eps_td_filter)
1701 ! Apply PP*gab -> PP; gab = gamma_coulomb
1702 ! P(nu,mu) = P(nu,mu)*g(a of nu,b of mu)
1703 bp = stda_env%beta_param
1704 hfx = stda_env%hfx_fraction
1705 CALL dbcsr_iterator_start(iter, pdens)
1706 DO WHILE (dbcsr_iterator_blocks_left(iter))
1707 CALL dbcsr_iterator_next_block(iter, iatom, jatom, pblock)
1708 rij = particle_set(iatom)%r - particle_set(jatom)%r
1709 rij = pbc(rij, cell)
1710 dr = sqrt(sum(rij(:)**2))
1711 ikind = kind_of(iatom)
1712 jkind = kind_of(jatom)
1713 eta = (stda_env%kind_param_set(ikind)%kind_param%hardness_param + &
1714 stda_env%kind_param_set(jkind)%kind_param%hardness_param)/2.0_dp
1715 rbeta = dr**bp
1716 IF (hfx > 0.0_dp) THEN
1717 gabr = (1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp)
1718 ELSE
1719 IF (dr < 1.0e-6_dp) THEN
1720 gabr = 0.0_dp
1721 ELSE
1722 gabr = 1._dp/dr
1723 END IF
1724 END IF
1725 ! gabr = (1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp)
1726 ! forces
1727 IF (dr > 1.0e-6_dp) THEN
1728 IF (hfx > 0.0_dp) THEN
1729 dgabr = -(1._dp/bp)*(1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp + 1._dp)
1730 dgabr = bp*rbeta/dr**2*dgabr
1731 dgabr = sum(pblock**2)*dgabr
1732 ELSE
1733 dgabr = -1.0_dp/dr**3
1734 dgabr = sum(pblock**2)*dgabr
1735 END IF
1736 atom_i = atom_of_kind(iatom)
1737 atom_j = atom_of_kind(jatom)
1738 DO i = 1, 3
1739 fij(i) = dgabr*rij(i)
1740 END DO
1741 force(ikind)%rho_elec(1, atom_i) = force(ikind)%rho_elec(1, atom_i) - fij(1)
1742 force(ikind)%rho_elec(2, atom_i) = force(ikind)%rho_elec(2, atom_i) - fij(2)
1743 force(ikind)%rho_elec(3, atom_i) = force(ikind)%rho_elec(3, atom_i) - fij(3)
1744 force(jkind)%rho_elec(1, atom_j) = force(jkind)%rho_elec(1, atom_j) + fij(1)
1745 force(jkind)%rho_elec(2, atom_j) = force(jkind)%rho_elec(2, atom_j) + fij(2)
1746 force(jkind)%rho_elec(3, atom_j) = force(jkind)%rho_elec(3, atom_j) + fij(3)
1747 END IF
1748 !
1749 pblock = gabr*pblock
1750 END DO
1751 CALL dbcsr_iterator_stop(iter)
1752 !
1753 ! Transpose pdens matrix
1754 CALL dbcsr_create(ptrans, template=pdens)
1755 CALL dbcsr_transposed(ptrans, pdens)
1756 !
1757 ! forces from Lowdin charge derivative
1758 CALL cp_fm_get_info(work%S_C0_C0T(ispin), matrix_struct=fmstruct)
1759 CALL cp_fm_create(t0matrix, matrix_struct=fmstruct, name="T0 SCRATCH")
1760 CALL cp_fm_create(t1matrix, matrix_struct=fmstruct, name="T1 SCRATCH")
1761 ALLOCATE (ucmatrix)
1762 CALL fm_pool_create_fm(work%fm_pool_ao_mo_occ(ispin)%pool, ucmatrix)
1763 ALLOCATE (uxmatrix)
1764 CALL fm_pool_create_fm(work%fm_pool_ao_mo_occ(ispin)%pool, uxmatrix)
1765 ct => work%ctransformed(ispin)
1766 CALL cp_dbcsr_sm_fm_multiply(pdens, ct, cvec, norb, 1.0_dp, 0.0_dp)
1767 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1768 cvec, 0.0_dp, ucmatrix)
1769 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1770 x(ispin), 0.0_dp, uxmatrix)
1771 CALL parallel_gemm('N', 'T', nsgf, nsgf, norb, 1.0_dp, uxmatrix, ucmatrix, 0.0_dp, t0matrix)
1772 CALL cp_dbcsr_sm_fm_multiply(ptrans, xtransformed(ispin), cvec, norb, 1.0_dp, 0.0_dp)
1773 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1774 cvec, 0.0_dp, uxmatrix)
1775 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1776 gs_mos(ispin)%mos_occ, 0.0_dp, ucmatrix)
1777 CALL parallel_gemm('N', 'T', nsgf, nsgf, norb, 1.0_dp, ucmatrix, uxmatrix, 1.0_dp, t0matrix)
1778 CALL cp_fm_schur_product(work%slambda, t0matrix, t1matrix)
1779 CALL parallel_gemm('N', 'N', nsgf, nsgf, nsgf, -1.0_dp, work%S_eigenvectors, t1matrix, &
1780 0.0_dp, t0matrix)
1781 CALL cp_dbcsr_plus_fm_fm_t(matrix_plo(ispin)%matrix, matrix_v=t0matrix, &
1782 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1783 CALL fm_pool_give_back_fm(work%fm_pool_ao_mo_occ(ispin)%pool, ucmatrix)
1784 DEALLOCATE (ucmatrix)
1785 CALL fm_pool_give_back_fm(work%fm_pool_ao_mo_occ(ispin)%pool, uxmatrix)
1786 DEALLOCATE (uxmatrix)
1787 CALL cp_fm_release(t0matrix)
1788 CALL cp_fm_release(t1matrix)
1789
1790 ! RHS contribution to response matrix
1791 ! CV(nu,i) = P(nu,mu)*XT(mu,i)
1792 CALL cp_dbcsr_sm_fm_multiply(ptrans, xtransformed(ispin), cvec, norb, 1.0_dp, 0.0_dp)
1793 CALL cp_dbcsr_sm_fm_multiply(work%shalf, cvec, cpmos(ispin), norb, &
1794 alpha=-xfac, beta=1.0_dp)
1795 !
1796 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1797 CALL cp_fm_create(vcvec, fmstruct)
1798 ! CV(nu,i) = P(nu,mu)*CT(mu,i)
1799 CALL cp_dbcsr_sm_fm_multiply(ptrans, ct, cvec, norb, 1.0_dp, 0.0_dp)
1800 CALL cp_dbcsr_sm_fm_multiply(work%shalf, cvec, vcvec, norb, 1.0_dp, 0.0_dp)
1801 CALL cp_fm_struct_create(fmstruct_mat, context=fmstruct%context, nrow_global=norb, &
1802 ncol_global=norb, para_env=fmstruct%para_env)
1803 CALL cp_fm_create(cvcmat, fmstruct_mat)
1804 CALL cp_fm_struct_release(fmstruct_mat)
1805 CALL parallel_gemm("T", "N", norb, norb, nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1806 CALL parallel_gemm("N", "N", nao, norb, norb, 1.0_dp, x(ispin), cvcmat, 0.0_dp, vcvec)
1807 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1808 norb, alpha=xfac, beta=1.0_dp)
1809 ! wx1
1810 IF (nspins == 2) THEN
1811 alpha = -2.0_dp
1812 ELSE
1813 alpha = -1.0_dp
1814 END IF
1815 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=gs_mos(ispin)%mos_occ, &
1816 matrix_g=vcvec, &
1817 ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1818 CALL cp_fm_release(vcvec)
1819 CALL cp_fm_release(cvcmat)
1820 !
1821 CALL dbcsr_release(pdens)
1822 CALL dbcsr_release(ptrans)
1823 !
1824 IF (debug_forces) THEN
1825 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1826 CALL para_env%sum(fodeb)
1827 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Exch[X] ", fodeb
1828 END IF
1829 END IF
1830 !
1831 CALL cp_fm_release(cvec)
1832 CALL cp_fm_release(xvec)
1833 DEALLOCATE (tv)
1834 END DO
1835
1836 CALL cp_fm_release(xtransformed)
1837 DEALLOCATE (tcharge, gtcharge)
1838 DEALLOCATE (first_sgf, last_sgf)
1839
1840 ! Lowdin forces
1841 IF (nspins == 2) THEN
1842 CALL dbcsr_add(matrix_plo(1)%matrix, matrix_plo(2)%matrix, &
1843 alpha_scalar=1.0_dp, beta_scalar=1.0_dp)
1844 END IF
1845 CALL dbcsr_scale(matrix_plo(1)%matrix, -1.0_dp)
1846 NULLIFY (scrm)
1847 IF (debug_forces) fodeb(1:3) = force(1)%overlap(1:3, 1)
1848 CALL build_overlap_matrix(ks_env, matrix_s=scrm, &
1849 matrix_name="OVERLAP MATRIX", &
1850 basis_type_a="ORB", basis_type_b="ORB", &
1851 sab_nl=sab_orb, calculate_forces=.true., &
1852 matrix_p=matrix_plo(1)%matrix)
1854 CALL dbcsr_deallocate_matrix_set(matrix_plo)
1855 IF (debug_forces) THEN
1856 fodeb(1:3) = force(1)%overlap(1:3, 1) - fodeb(1:3)
1857 CALL para_env%sum(fodeb)
1858 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Lowdin ", fodeb
1859 END IF
1860
1861 IF (ASSOCIATED(ex_env%matrix_wx1)) CALL dbcsr_deallocate_matrix_set(ex_env%matrix_wx1)
1862 ex_env%matrix_wx1 => matrix_wx1
1863
1864 CALL timestop(handle)
1865
1866 END SUBROUTINE stda_force
1867
1868! **************************************************************************************************
1869
1870END MODULE qs_tddfpt2_fhxc_forces
Contains ADMM methods which require molecular orbitals.
subroutine, public admm_projection_derivative(qs_env, matrix_hz, matrix_pz, fval)
Calculate derivatives terms from overlap matrices.
Types and set/get functions for auxiliary density matrix methods.
Definition admm_types.F:15
subroutine, public get_admm_env(admm_env, mo_derivs_aux_fit, mos_aux_fit, sab_aux_fit, sab_aux_fit_asymm, sab_aux_fit_vs_orb, matrix_s_aux_fit, matrix_s_aux_fit_kp, matrix_s_aux_fit_vs_orb, matrix_s_aux_fit_vs_orb_kp, task_list_aux_fit, matrix_ks_aux_fit, matrix_ks_aux_fit_kp, matrix_ks_aux_fit_im, matrix_ks_aux_fit_dft, matrix_ks_aux_fit_hfx, matrix_ks_aux_fit_dft_kp, matrix_ks_aux_fit_hfx_kp, rho_aux_fit, rho_aux_fit_buffer, admm_dm)
Get routine for the ADMM env.
Definition admm_types.F:593
Define the atomic kind types and their sub types.
subroutine, public get_atomic_kind_set(atomic_kind_set, atom_of_kind, kind_of, natom_of_kind, maxatom, natom, nshell, fist_potential_present, shell_present, shell_adiabatic, shell_check_distance, damping_present)
Get attributes of an atomic kind set.
Handles all functions related to the CELL.
Definition cell_types.F:15
Defines control structures, which contain the parameters and the settings for the DFT-based calculati...
subroutine, public dbcsr_transposed(transposed, normal, shallow_data_copy, transpose_distribution, use_distribution)
...
subroutine, public dbcsr_scale(matrix, alpha_scalar)
...
subroutine, public dbcsr_iterator_next_block(iterator, row, column, block, block_number_argument_has_been_removed, row_size, col_size, row_offset, col_offset)
...
logical function, public dbcsr_iterator_blocks_left(iterator)
...
subroutine, public dbcsr_iterator_stop(iterator)
...
subroutine, public dbcsr_copy(matrix_b, matrix_a, name, keep_sparsity, keep_imaginary)
...
subroutine, public dbcsr_get_block_p(matrix, row, col, block, found, row_size, col_size)
...
subroutine, public dbcsr_filter(matrix, eps)
...
subroutine, public dbcsr_iterator_start(iterator, matrix, shared, dynamic, dynamic_byrows)
...
subroutine, public dbcsr_set(matrix, alpha)
...
subroutine, public dbcsr_release(matrix)
...
subroutine, public dbcsr_complete_redistribute(matrix, redist)
...
subroutine, public dbcsr_add(matrix_a, matrix_b, alpha_scalar, beta_scalar)
...
DBCSR operations in CP2K.
subroutine, public cp_dbcsr_sm_fm_multiply(matrix, fm_in, fm_out, ncol, alpha, beta)
multiply a dbcsr with a fm matrix
subroutine, public copy_dbcsr_to_fm(matrix, fm)
Copy a DBCSR matrix to a BLACS matrix.
subroutine, public cp_dbcsr_plus_fm_fm_t(sparse_matrix, matrix_v, matrix_g, ncol, alpha, keep_sparsity, symmetry_mode)
performs the multiplication sparse_matrix+dense_mat*dens_mat^T if matrix_g is not explicitly given,...
subroutine, public copy_fm_to_dbcsr(fm, matrix, keep_sparsity)
Copy a BLACS matrix to a dbcsr matrix.
Basic linear algebra operations for full matrices.
subroutine, public cp_fm_row_scale(matrixa, scaling)
scales row i of matrix a with scaling(i)
subroutine, public cp_fm_schur_product(matrix_a, matrix_b, matrix_c)
computes the schur product of two matrices c_ij = a_ij * b_ij
pool for for elements that are retained and released
subroutine, public fm_pool_create_fm(pool, element, name)
returns an element, allocating it if none is in the pool
subroutine, public fm_pool_give_back_fm(pool, element)
returns the element to the pool
represent the structure of a full matrix
subroutine, public cp_fm_struct_create(fmstruct, para_env, context, nrow_global, ncol_global, nrow_block, ncol_block, descriptor, first_p_pos, local_leading_dimension, template_fmstruct, square_blocks, force_block)
allocates and initializes a full matrix structure
subroutine, public cp_fm_struct_release(fmstruct)
releases a full matrix structure
represent a full matrix distributed on many processors
Definition cp_fm_types.F:15
subroutine, public cp_fm_get_info(matrix, name, nrow_global, ncol_global, nrow_block, ncol_block, nrow_local, ncol_local, row_indices, col_indices, local_data, context, nrow_locals, ncol_locals, matrix_struct, para_env)
returns all kind of information about the full matrix
subroutine, public cp_fm_vectorssum(matrix, sum_array, dir)
summing up all the elements along the matrix's i-th index or
subroutine, public cp_fm_create(matrix, matrix_struct, name, use_sp)
creates a new full matrix with the given structure
various routines to log and control the output. The idea is that decisions about where to log should ...
recursive integer function, public cp_logger_get_default_unit_nr(logger, local, skip_not_ionode)
asks the default unit number of the given logger. try to use cp_logger_get_unit_nr
type(cp_logger_type) function, pointer, public cp_get_default_logger()
returns the default logger
subroutine, public ewald_env_get(ewald_env, ewald_type, alpha, eps_pol, epsilon, gmax, ns_max, o_spline, group, para_env, poisson_section, precs, rcut, do_multipoles, max_multipole, do_ipol, max_ipol_iter, interaction_cutoffs, cell_hmat)
Purpose: Get the EWALD environment.
Calculation of Ewald contributions in DFTB.
subroutine, public tb_ewald_overlap(gmcharge, mcharge, alpha, n_list, virial, use_virial)
...
subroutine, public tb_spme_evaluate(ewald_env, ewald_pw, particle_set, box, gmcharge, mcharge, calculate_forces, virial, use_virial)
...
Types for excited states potential energies.
subroutine, public init_coulomb_local(hartree_local, natom)
...
subroutine, public vh_1c_gg_integrals(qs_env, energy_hartree_1c, ecoul_1c, local_rho_set, para_env, tddft, local_rho_set_2nd, core_2nd)
Calculates one center GAPW Hartree energies and matrix elements Hartree potentials are input Takes po...
subroutine, public hartree_local_release(hartree_local)
...
subroutine, public hartree_local_create(hartree_local)
...
Routines to calculate derivatives with respect to basis function origin.
subroutine, public derivatives_four_center(qs_env, rho_ao, rho_ao_resp, hfx_section, para_env, irep, use_virial, adiabatic_rescale_factor, resp_only, external_x_data, nspins)
computes four center derivatives for a full basis set and updates the forcesfock_4c arrays....
Routines to calculate HFX energy and potential.
subroutine, public integrate_four_center(qs_env, x_data, ks_matrix, ehfx, rho_ao, hfx_section, para_env, geometry_did_change, irep, distribute_fock_matrix, ispin, nspins)
computes four center integrals for a full basis set and updates the Kohn-Sham-Matrix and energy....
RI-methods for HFX.
Definition hfx_ri.F:12
subroutine, public hfx_ri_update_ks(qs_env, ri_data, ks_matrix, ehfx, mos, rho_ao, geometry_did_change, nspins, hf_fraction)
...
Definition hfx_ri.F:1041
subroutine, public hfx_ri_update_forces(qs_env, ri_data, nspins, hf_fraction, rho_ao, rho_ao_resp, mos, use_virial, resp_only, rescale_factor)
the general routine that calls the relevant force code
Definition hfx_ri.F:3044
Types and set/get functions for HFX.
Definition hfx_types.F:15
collects all constants needed in input so that they can be used without circular dependencies
integer, parameter, public do_analytic
integer, parameter, public tddfpt_sf_col
integer, parameter, public xc_kernel_method_best
integer, parameter, public xc_kernel_method_analytic
integer, parameter, public do_admm_aux_exch_func_none
integer, parameter, public tddfpt_kernel_full
integer, parameter, public xc_kernel_method_numeric
integer, parameter, public do_numeric
integer, parameter, public no_sf_tddfpt
integer, parameter, public xc_none
objects that represent the structure of input sections and the data contained in an input section
recursive type(section_vals_type) function, pointer, public section_vals_get_subs_vals(section_vals, subsection_name, i_rep_section, can_return_null)
returns the values of the requested subsection
subroutine, public section_vals_get(section_vals, ref_count, n_repetition, n_subs_vals_rep, section, explicit)
returns various attributes about the section_vals
subroutine, public section_vals_val_get(section_vals, keyword_name, i_rep_section, i_rep_val, n_rep_val, val, l_val, i_val, r_val, c_val, l_vals, i_vals, r_vals, c_vals, explicit)
returns the requested value
Defines the basic variable types.
Definition kinds.F:23
integer, parameter, public dp
Definition kinds.F:34
integer, parameter, public default_string_length
Definition kinds.F:57
Definition of mathematical constants and functions.
real(kind=dp), parameter, public oorootpi
Interface to the message passing library MPI.
basic linear algebra operations for full matrixes
Define methods related to particle_type.
subroutine, public get_particle_set(particle_set, qs_kind_set, first_sgf, last_sgf, nsgf, nmao, basis)
Get the components of a particle set.
Define the data structure for the particle information.
container for various plainwaves related things
subroutine, public pw_env_get(pw_env, pw_pools, cube_info, gridlevel_info, auxbas_pw_pool, auxbas_grid, auxbas_rs_desc, auxbas_rs_grid, rs_descs, rs_grids, xc_pw_pool, vdw_pw_pool, poisson_env, interp_section)
returns the various attributes of the pw env
functions related to the poisson solver on regular grids
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
Calculate the plane wave density by collocating the primitive Gaussian functions (pgf).
subroutine, public calculate_rho_elec(matrix_p, matrix_p_kp, rho, rho_gspace, total_rho, ks_env, soft_valid, compute_tau, compute_grad, basis_type, der_type, idir, task_list_external, pw_env_external)
computes the density corresponding to a given density matrix on the grid
subroutine, public get_qs_env(qs_env, atomic_kind_set, qs_kind_set, cell, super_cell, cell_ref, use_ref_cell, kpoints, dft_control, mos, sab_orb, sab_all, qmmm, qmmm_periodic, sac_ae, sac_ppl, sac_lri, sap_ppnl, sab_vdw, sab_scp, sap_oce, sab_lrc, sab_se, sab_xtbe, sab_tbe, sab_core, sab_xb, sab_xtb_pp, sab_xtb_nonbond, sab_almo, sab_kp, sab_kp_nosym, sab_cneo, particle_set, energy, force, matrix_h, matrix_h_im, matrix_ks, matrix_ks_im, matrix_vxc, run_rtp, rtp, matrix_h_kp, matrix_h_im_kp, matrix_ks_kp, matrix_ks_im_kp, matrix_vxc_kp, kinetic_kp, matrix_s_kp, matrix_w_kp, matrix_s_ri_aux_kp, matrix_s, matrix_s_ri_aux, matrix_w, matrix_p_mp2, matrix_p_mp2_admm, rho, rho_xc, pw_env, ewald_env, ewald_pw, active_space, mpools, input, para_env, blacs_env, scf_control, rel_control, kinetic, qs_charges, vppl, rho_core, rho_nlcc, rho_nlcc_g, ks_env, ks_qmmm_env, wf_history, scf_env, local_particles, local_molecules, distribution_2d, dbcsr_dist, molecule_kind_set, molecule_set, subsys, cp_subsys, oce, local_rho_set, rho_atom_set, task_list, task_list_soft, rho0_atom_set, rho0_mpole, rhoz_set, rhoz_cneo_set, ecoul_1c, rho0_s_rs, rho0_s_gs, rhoz_cneo_s_rs, rhoz_cneo_s_gs, do_kpoints, has_unit_metric, requires_mo_derivs, mo_derivs, mo_loc_history, nkind, natom, nelectron_total, nelectron_spin, efield, neighbor_list_id, linres_control, xas_env, virial, cp_ddapc_env, cp_ddapc_ewald, outer_scf_history, outer_scf_ihistory, x_data, et_coupling, dftb_potential, results, se_taper, se_store_int_env, se_nddo_mpole, se_nonbond_env, admm_env, lri_env, lri_density, exstate_env, ec_env, harris_env, dispersion_env, gcp_env, vee, rho_external, external_vxc, mask, mp2_env, bs_env, kg_env, wanniercentres, atprop, ls_scf_env, do_transport, transport_env, v_hartree_rspace, s_mstruct_changed, rho_changed, potential_changed, forces_up_to_date, mscfg_env, almo_scf_env, gradient_history, variable_history, embed_pot, spin_embed_pot, polar_env, mos_last_converged, eeq, rhs, do_rixs, tb_tblite)
Get the QUICKSTEP environment.
subroutine, public set_qs_env(qs_env, super_cell, mos, qmmm, qmmm_periodic, ewald_env, ewald_pw, mpools, rho_external, external_vxc, mask, scf_control, rel_control, qs_charges, ks_env, ks_qmmm_env, wf_history, scf_env, active_space, input, oce, rho_atom_set, rho0_atom_set, rho0_mpole, run_rtp, rtp, rhoz_set, rhoz_tot, ecoul_1c, has_unit_metric, requires_mo_derivs, mo_derivs, mo_loc_history, efield, rhoz_cneo_set, linres_control, xas_env, cp_ddapc_env, cp_ddapc_ewald, outer_scf_history, outer_scf_ihistory, x_data, et_coupling, dftb_potential, se_taper, se_store_int_env, se_nddo_mpole, se_nonbond_env, admm_env, ls_scf_env, do_transport, transport_env, lri_env, lri_density, exstate_env, ec_env, dispersion_env, harris_env, gcp_env, mp2_env, bs_env, kg_env, force, kpoints, wanniercentres, almo_scf_env, gradient_history, variable_history, embed_pot, spin_embed_pot, polar_env, mos_last_converged, eeq, rhs, do_rixs, tb_tblite)
Set the QUICKSTEP environment.
https://en.wikipedia.org/wiki/Finite_difference_coefficient
Definition qs_fxc.F:27
subroutine, public qs_fgxc_create(ks_env, rho0_struct, rho1_struct, xc_section, accuracy, is_triplet, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
...
Definition qs_fxc.F:620
subroutine, public qs_fgxc_gdiff(ks_env, rho0_struct, rho1_struct, xc_section, accuracy, epsrho, is_triplet, fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip)
...
Definition qs_fxc.F:455
subroutine, public qs_fgxc_release(ks_env, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
...
Definition qs_fxc.F:749
subroutine, public qs_fgxc_analytic(rho0_struct, rho1_struct, xc_section, pw_pool, fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip)
Calculates the values at the grid points in real space (r_i), of the second and third functional deri...
Definition qs_fxc.F:302
subroutine, public prepare_gapw_den(qs_env, local_rho_set, do_rho0, kind_set_external, pw_env_sub)
...
Integrate single or product functions over a potential on a RS grid.
Define the quickstep kind type and their sub types.
routines that build the Kohn-Sham matrix contributions coming from local atomic densities
Definition qs_ks_atom.F:12
subroutine, public update_ks_atom(qs_env, ksmat, pmat, forces, tddft, rho_atom_external, kind_set_external, oce_external, sab_external, kscale, kintegral, kforce, fscale)
The correction to the KS matrix due to the GAPW local terms to the hartree and XC contributions is he...
Definition qs_ks_atom.F:110
subroutine, public local_rho_set_create(local_rho_set)
...
subroutine, public local_rho_set_release(local_rho_set)
...
Define the neighbor list data types and the corresponding functionality.
Routines for the construction of the coefficients for the expansion of the atomic densities rho1_hard...
subroutine, public build_oce_matrices(intac, calculate_forces, nder, qs_kind_set, particle_set, sap_oce, eps_fit)
Set up the sparse matrix for the coefficients of one center expansions This routine uses the same log...
subroutine, public allocate_oce_set(oce_set, nkind)
Allocate and initialize the matrix set of oce coefficients.
subroutine, public create_oce_set(oce_set)
...
Calculation of overlap matrix, its derivatives and forces.
Definition qs_overlap.F:19
subroutine, public build_overlap_matrix(ks_env, matrix_s, matrixkp_s, matrix_name, nderivative, basis_type_a, basis_type_b, sab_nl, calculate_forces, matrix_p, matrixkp_p)
Calculation of the overlap matrix over Cartesian Gaussian functions.
Definition qs_overlap.F:120
subroutine, public rho0_s_grid_create(pw_env, rho0_mpole)
...
subroutine, public integrate_vhg0_rspace(qs_env, v_rspace, para_env, calculate_forces, local_rho_set, local_rho_set_2nd, atener, kforce, my_pools, my_rs_descs)
...
subroutine, public init_rho0(local_rho_set, qs_env, gapw_control, zcore)
...
subroutine, public allocate_rho_atom_internals(rho_atom_set, atomic_kind_set, qs_kind_set, dft_control, para_env)
...
subroutine, public calculate_rho_atom_coeff(qs_env, rho_ao, rho_atom_set, qs_kind_set, oce, sab, para_env)
...
superstucture that hold various representations of the density and keeps track of which ones are vali...
subroutine, public qs_rho_set(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_ao_im_kp, rho_r, drho_r, rho_g, drho_g, tau_r, tau_g, rho_r_valid, drho_r_valid, rho_g_valid, drho_g_valid, tau_r_valid, tau_g_valid, tot_rho_r, tot_rho_g, rho_r_sccs, soft_valid, complex_rho_ao)
...
subroutine, public qs_rho_get(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_ao_im_kp, rho_r, drho_r, rho_g, drho_g, tau_r, tau_g, rho_r_valid, drho_r_valid, rho_g_valid, drho_g_valid, tau_r_valid, tau_g_valid, tot_rho_r, tot_rho_g, rho_r_sccs, soft_valid, complex_rho_ao)
returns info about the density described by this object. If some representation is not available an e...
subroutine, public qs_rho_create(rho)
Allocates a new instance of rho.
subroutine, public stda_force(qs_env, ex_env, gs_mos, stda_env, sub_env, work, debug_forces)
Simplified Tamm Dancoff approach (sTDA). Kernel contribution to forces.
subroutine, public fhxc_force(qs_env, ex_env, gs_mos, full_kernel, debug_forces)
Calculate direct tddft forces. Calculate the three last terms of the response vector in equation 49 a...
Simplified Tamm Dancoff approach (sTDA).
Simplified Tamm Dancoff approach (sTDA).
subroutine, public get_lowdin_x(shalf, xvec, xt)
Calculate Lowdin transformed Davidson trial vector X shalf (dbcsr), xvec, xt (fm) are defined in the ...
subroutine, public setup_gamma(qs_env, stda_env, sub_env, gamma_matrix, ndim)
Calculate sTDA exchange-type contributions.
routines that build the integrals of the Vxc potential calculated for the atomic density in the basis...
Definition qs_vxc_atom.F:12
subroutine, public calculate_gfxc_atom(qs_env, rho0_atom_set, rho1_atom_set, rho2_atom_set, kind_set, xc_section, is_triplet, accuracy)
...
subroutine, public gfxc_atom_diff(qs_env, rho0_atom_set, rho1_atom_set, rho2_atom_set, kind_set, xc_section, is_triplet, accuracy, epsrho)
...
types for task lists
All kind of helpful little routines.
Definition util.F:14
pure integer function, dimension(2), public get_limit(m, n, me)
divide m entries into n parts, return size of part me
Definition util.F:333
stores some data used in wavefunction fitting
Definition admm_types.F:120
Provides all information about an atomic kind.
Type defining parameters related to the simulation cell.
Definition cell_types.F:55
keeps the information about the structure of a full matrix
represent a full matrix
type of a logger, at the moment it contains just a print level starting at which level it should be l...
Contains information on the excited states energy.
stores some data used in construction of Kohn-Sham matrix
Definition hfx_types.F:510
stores all the informations relevant to an mpi environment
contained for different pw related things
environment for the poisson solver
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
Collection of variables required to evaluate adiabatic TDDFPT kernel.
Provides all information about a quickstep kind.
calculation environment to calculate the ks matrix, holds all the needed vars. assumes that the core ...
keeps the density in various representations, keeping track of which ones are valid.
Ground state molecular orbitals.
Set of temporary ("work") matrices.