(git:ce05c02)
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-2026 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
11 USE admm_types, ONLY: admm_type,&
15 USE cell_types, ONLY: cell_type,&
16 pbc
20 USE cp_dbcsr_api, ONLY: &
25 dbcsr_type_antisymmetric, dbcsr_type_no_symmetry
42 USE cp_fm_types, ONLY: cp_fm_create,&
64 USE hfx_ri, ONLY: hfx_ri_update_forces,&
66 USE hfx_types, ONLY: hfx_type
79 USE kinds, ONLY: default_string_length,&
80 dp
81 USE mathconstants, ONLY: oorootpi
86 USE pw_env_types, ONLY: pw_env_get,&
88 USE pw_methods, ONLY: pw_axpy,&
89 pw_scale,&
95 USE pw_types, ONLY: pw_c1d_gs_type,&
102 USE qs_fxc, ONLY: qs_fgxc_analytic,&
107 USE qs_integrate_potential, ONLY: integrate_v_rspace
109 USE qs_kind_types, ONLY: qs_kind_type
110 USE qs_ks_atom, ONLY: update_ks_atom
111 USE qs_ks_types, ONLY: qs_ks_env_type
117 USE qs_oce_types, ONLY: allocate_oce_set,&
123 USE qs_rho0_methods, ONLY: init_rho0
127 USE qs_rho_types, ONLY: qs_rho_create,&
128 qs_rho_get,&
129 qs_rho_set,&
140 USE util, ONLY: get_limit
141 USE virial_types, ONLY: virial_type
142#include "./base/base_uses.f90"
143
144 IMPLICIT NONE
145
146 PRIVATE
147
148 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_tddfpt2_fhxc_forces'
149
150 PUBLIC :: fhxc_force, stda_force
151
152! **************************************************************************************************
153
154CONTAINS
155
156! **************************************************************************************************
157!> \brief Calculate direct tddft forces. Calculate the three last terms of the response vector
158!> in equation 49 and the first term of \Lambda_munu in equation 51 in
159!> J. Chem. Theory Comput. 2022, 18, 7, 4186–4202 (https://doi.org/10.1021/acs.jctc.2c00144)
160!> \param qs_env Holds all system information relevant for the calculation.
161!> \param ex_env Holds the response vector ex_env%cpmos and Lambda ex_env%matrix_wx1.
162!> \param gs_mos MO coefficients of the ground state.
163!> \param full_kernel ...
164!> \param debug_forces ...
165!> \par History
166!> * 01.2020 screated [JGH]
167! **************************************************************************************************
168 SUBROUTINE fhxc_force(qs_env, ex_env, gs_mos, full_kernel, debug_forces)
169
170 TYPE(qs_environment_type), POINTER :: qs_env
171 TYPE(excited_energy_type), POINTER :: ex_env
172 TYPE(tddfpt_ground_state_mos), DIMENSION(:), &
173 POINTER :: gs_mos
174 TYPE(full_kernel_env_type), INTENT(IN) :: full_kernel
175 LOGICAL, INTENT(IN) :: debug_forces
176
177 CHARACTER(LEN=*), PARAMETER :: routinen = 'fhxc_force'
178
179 CHARACTER(LEN=default_string_length) :: basis_type
180 INTEGER :: handle, ia, ib, iounit, ispin, mspin, &
181 myfun, n_rep_hf, nactive(2), nao, &
182 nao_aux, natom, nkind, norb(2), nsev, &
183 nspins, order, spin
184 LOGICAL :: distribute_fock_matrix, do_admm, do_analytic, do_hfx, do_hfxlr, do_hfxsr, &
185 do_numeric, do_res, do_sf, gapw, gapw_xc, hfx_treat_lsd_in_core, is_rks_triplets, &
186 s_mstruct_changed, use_virial
187 REAL(kind=dp) :: eh1, eh1c, eps_delta, eps_fit, focc, &
188 fscal, fval, kval, xehartree
189 REAL(kind=dp), DIMENSION(3) :: fodeb
190 TYPE(admm_type), POINTER :: admm_env
191 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
192 TYPE(cp_fm_struct_type), POINTER :: fm_struct
193 TYPE(cp_fm_type) :: avamat, avcmat, cpscr, cvcmat, vavec, &
194 vcvec
195 TYPE(cp_fm_type), DIMENSION(:), POINTER :: cpmos, evect
196 TYPE(cp_fm_type), POINTER :: mos, mos2, mosa, mosa2
197 TYPE(cp_logger_type), POINTER :: logger
198 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_fx, matrix_gx, matrix_hfx, &
199 matrix_hfx_admm, matrix_hfx_admm_asymm, matrix_hfx_asymm, matrix_hx, matrix_p, &
200 matrix_p_admm, matrix_px1, matrix_px1_admm, matrix_px1_admm_asymm, matrix_px1_asymm, &
201 matrix_s, matrix_s_aux_fit, matrix_wx1, mdum, mfx, mgx
202 TYPE(dbcsr_p_type), DIMENSION(:, :), POINTER :: mhe, mpe, mpga
203 TYPE(dbcsr_type), POINTER :: dbwork, dbwork_asymm
204 TYPE(dft_control_type), POINTER :: dft_control
205 TYPE(hartree_local_type), POINTER :: hartree_local
206 TYPE(hfx_type), DIMENSION(:, :), POINTER :: x_data
207 TYPE(local_rho_type), POINTER :: local_rho_set, local_rho_set_admm, local_rho_set_f, &
208 local_rho_set_f_admm, local_rho_set_g, local_rho_set_g_admm
209 TYPE(mp_para_env_type), POINTER :: para_env
210 TYPE(neighbor_list_set_p_type), DIMENSION(:), &
211 POINTER :: sab, sab_aux_fit, sab_orb, sap_oce
212 TYPE(oce_matrix_type), POINTER :: oce
213 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
214 TYPE(pw_c1d_gs_type) :: rhox_tot_gspace, xv_hartree_gspace
215 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g_aux, rhox_g, rhox_g_aux, rhoxx_g
216 TYPE(pw_env_type), POINTER :: pw_env
217 TYPE(pw_poisson_type), POINTER :: poisson_env
218 TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
219 TYPE(pw_r3d_rs_type) :: xv_hartree_rspace
220 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: fxc_rho, fxc_tau, gxc_rho, gxc_tau, &
221 rho_r_aux, rhox_r, rhox_r_aux, rhoxx_r
222 TYPE(pw_r3d_rs_type), POINTER :: weights
223 TYPE(qs_force_type), DIMENSION(:), POINTER :: force
224 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
225 TYPE(qs_ks_env_type), POINTER :: ks_env
226 TYPE(qs_rho_type), POINTER :: rho, rho_aux_fit, rhox, rhox_aux
227 TYPE(rho_atom_type), DIMENSION(:), POINTER :: rho_atom_set, rho_atom_set_f, &
228 rho_atom_set_g
229 TYPE(section_vals_type), POINTER :: hfx_section, xc_section
230 TYPE(task_list_type), POINTER :: task_list
231 TYPE(tddfpt2_control_type), POINTER :: tddfpt_control
232
233 CALL timeset(routinen, handle)
234
235 logger => cp_get_default_logger()
236 IF (logger%para_env%is_source()) THEN
237 iounit = cp_logger_get_default_unit_nr(logger, local=.true.)
238 ELSE
239 iounit = -1
240 END IF
241
242 CALL get_qs_env(qs_env, dft_control=dft_control)
243 tddfpt_control => dft_control%tddfpt2_control
244 nspins = dft_control%nspins
245 is_rks_triplets = tddfpt_control%rks_triplets .AND. (nspins == 1)
246 IF (tddfpt_control%spinflip == no_sf_tddfpt) THEN
247 do_sf = .false.
248 ELSE
249 do_sf = .true.
250 END IF
251 cpassert(tddfpt_control%kernel == tddfpt_kernel_full)
252 do_hfx = tddfpt_control%do_hfx
253 do_hfxsr = tddfpt_control%do_hfxsr
254 do_hfxlr = tddfpt_control%do_hfxlr
255 do_admm = tddfpt_control%do_admm
256 gapw = dft_control%qs_control%gapw
257 gapw_xc = dft_control%qs_control%gapw_xc
258
259 evect => ex_env%evect
260 matrix_px1 => ex_env%matrix_px1
261 matrix_px1_admm => ex_env%matrix_px1_admm
262 matrix_px1_asymm => ex_env%matrix_px1_asymm
263 matrix_px1_admm_asymm => ex_env%matrix_px1_admm_asymm
264
265 focc = 1.0_dp
266 IF (nspins == 2) focc = 0.5_dp
267 nsev = SIZE(evect, 1)
268 DO ispin = 1, nsev
269 CALL cp_fm_get_info(evect(ispin), ncol_global=nactive(ispin))
270 ! Calculate (C*X^T + X*C^T)/2
271 CALL dbcsr_set(matrix_px1(ispin)%matrix, 0.0_dp)
272 CALL cp_dbcsr_plus_fm_fm_t(matrix_px1(ispin)%matrix, &
273 matrix_v=evect(ispin), &
274 matrix_g=gs_mos(ispin)%mos_active, &
275 ncol=nactive(ispin), alpha=2.0_dp*focc, symmetry_mode=1)
276
277 ! Calculate (C*X^T - X*C^T)/2
278 CALL dbcsr_set(matrix_px1_asymm(ispin)%matrix, 0.0_dp)
279 CALL cp_dbcsr_plus_fm_fm_t(matrix_px1_asymm(ispin)%matrix, &
280 matrix_v=gs_mos(ispin)%mos_active, &
281 matrix_g=evect(ispin), &
282 ncol=nactive(ispin), alpha=2.0_dp*focc, &
283 symmetry_mode=-1)
284 END DO
285 !
286 CALL get_qs_env(qs_env, ks_env=ks_env, pw_env=pw_env, para_env=para_env)
287 CALL get_qs_env(qs_env, xcint_weights=weights)
288 !
289 NULLIFY (hartree_local, local_rho_set, local_rho_set_admm)
290 IF (gapw .OR. gapw_xc) THEN
291 IF (nspins == 2) THEN
292 DO ispin = 1, nsev
293 CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
294 END DO
295 END IF
296 CALL get_qs_env(qs_env, &
297 atomic_kind_set=atomic_kind_set, &
298 qs_kind_set=qs_kind_set)
299 CALL local_rho_set_create(local_rho_set)
300 CALL allocate_rho_atom_internals(local_rho_set%rho_atom_set, atomic_kind_set, &
301 qs_kind_set, dft_control, para_env)
302 IF (gapw) THEN
303 CALL get_qs_env(qs_env, natom=natom)
304 CALL init_rho0(local_rho_set, qs_env, dft_control%qs_control%gapw_control, &
305 zcore=0.0_dp)
306 CALL rho0_s_grid_create(pw_env, local_rho_set%rho0_mpole)
307 CALL hartree_local_create(hartree_local)
308 CALL init_coulomb_local(hartree_local, natom)
309 END IF
310
311 CALL get_qs_env(qs_env=qs_env, oce=oce, sap_oce=sap_oce, sab_orb=sab)
312 CALL create_oce_set(oce)
313 CALL get_qs_env(qs_env=qs_env, nkind=nkind, particle_set=particle_set)
314 CALL allocate_oce_set(oce, nkind)
315 eps_fit = dft_control%qs_control%gapw_control%eps_fit
316 CALL build_oce_matrices(oce%intac, .true., 1, qs_kind_set, particle_set, &
317 sap_oce, eps_fit)
318 CALL set_qs_env(qs_env, oce=oce)
319
320 mpga(1:nsev, 1:1) => matrix_px1(1:nsev)
321 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set%rho_atom_set, &
322 qs_kind_set, oce, sab, para_env)
323 CALL prepare_gapw_den(qs_env, local_rho_set, do_rho0=gapw)
324 !
325 CALL local_rho_set_create(local_rho_set_f)
326 CALL allocate_rho_atom_internals(local_rho_set_f%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_f%rho_atom_set, &
329 qs_kind_set, oce, sab, para_env)
330 CALL prepare_gapw_den(qs_env, local_rho_set_f, do_rho0=.false.)
331 !
332 CALL local_rho_set_create(local_rho_set_g)
333 CALL allocate_rho_atom_internals(local_rho_set_g%rho_atom_set, atomic_kind_set, &
334 qs_kind_set, dft_control, para_env)
335 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_g%rho_atom_set, &
336 qs_kind_set, oce, sab, para_env)
337 CALL prepare_gapw_den(qs_env, local_rho_set_g, do_rho0=.false.)
338 IF (nspins == 2) THEN
339 DO ispin = 1, nsev
340 CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
341 END DO
342 END IF
343 END IF
344 !
345 IF (do_admm) THEN
346 CALL get_qs_env(qs_env, admm_env=admm_env)
347 nao_aux = admm_env%nao_aux_fit
348 nao = admm_env%nao_orb
349 ! Fit the symmetrized and antisymmetrized matrices
350 DO ispin = 1, nsev
351
352 CALL copy_dbcsr_to_fm(matrix_px1(ispin)%matrix, admm_env%work_orb_orb)
353 CALL parallel_gemm('N', 'N', nao_aux, nao, nao, &
354 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
355 admm_env%work_aux_orb)
356 CALL parallel_gemm('N', 'T', nao_aux, nao_aux, nao, &
357 1.0_dp, admm_env%work_aux_orb, admm_env%A, 0.0_dp, &
358 admm_env%work_aux_aux)
359 CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_px1_admm(ispin)%matrix, &
360 keep_sparsity=.true.)
361
362 CALL copy_dbcsr_to_fm(matrix_px1_asymm(ispin)%matrix, admm_env%work_orb_orb)
363 CALL parallel_gemm('N', 'N', nao_aux, nao, nao, &
364 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
365 admm_env%work_aux_orb)
366 CALL parallel_gemm('N', 'T', nao_aux, nao_aux, nao, &
367 1.0_dp, admm_env%work_aux_orb, admm_env%A, 0.0_dp, &
368 admm_env%work_aux_aux)
369 CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_px1_admm_asymm(ispin)%matrix, &
370 keep_sparsity=.true.)
371 END DO
372 !
373 IF (admm_env%do_gapw) THEN
374 IF (do_admm .AND. tddfpt_control%admm_xc_correction) THEN
375 IF (admm_env%aux_exch_func == do_admm_aux_exch_func_none) THEN
376 ! nothing to do
377 ELSE
378 CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set)
379 CALL local_rho_set_create(local_rho_set_admm)
380 CALL allocate_rho_atom_internals(local_rho_set_admm%rho_atom_set, atomic_kind_set, &
381 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
382 mpga(1:nsev, 1:1) => matrix_px1_admm(1:nsev)
383 CALL get_admm_env(admm_env, sab_aux_fit=sab_aux_fit)
384 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_admm%rho_atom_set, &
385 admm_env%admm_gapw_env%admm_kind_set, &
386 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
387 CALL prepare_gapw_den(qs_env, local_rho_set_admm, do_rho0=.false., &
388 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
389 !
390 CALL local_rho_set_create(local_rho_set_f_admm)
391 CALL allocate_rho_atom_internals(local_rho_set_f_admm%rho_atom_set, atomic_kind_set, &
392 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
393 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_f_admm%rho_atom_set, &
394 admm_env%admm_gapw_env%admm_kind_set, &
395 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
396 CALL prepare_gapw_den(qs_env, local_rho_set_f_admm, do_rho0=.false., &
397 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
398 !
399 CALL local_rho_set_create(local_rho_set_g_admm)
400 CALL allocate_rho_atom_internals(local_rho_set_g_admm%rho_atom_set, atomic_kind_set, &
401 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
402 CALL calculate_rho_atom_coeff(qs_env, mpga, local_rho_set_g_admm%rho_atom_set, &
403 admm_env%admm_gapw_env%admm_kind_set, &
404 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
405 CALL prepare_gapw_den(qs_env, local_rho_set_g_admm, do_rho0=.false., &
406 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
407 END IF
408 END IF
409 END IF
410 END IF
411 !
412 CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, &
413 poisson_env=poisson_env)
414
415 ALLOCATE (rhox_r(nsev), rhox_g(nsev))
416 DO ispin = 1, SIZE(evect, 1)
417 CALL auxbas_pw_pool%create_pw(rhox_r(ispin))
418 CALL auxbas_pw_pool%create_pw(rhox_g(ispin))
419 END DO
420 CALL auxbas_pw_pool%create_pw(rhox_tot_gspace)
421
422 CALL pw_zero(rhox_tot_gspace)
423 DO ispin = 1, nsev
424 ! Calculate gridpoint values of the density associated to 2*matrix_px1 = C*X^T + X*C^T
425 IF (nspins == 2) CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
426 CALL calculate_rho_elec(ks_env=ks_env, matrix_p=matrix_px1(ispin)%matrix, &
427 rho=rhox_r(ispin), rho_gspace=rhox_g(ispin), &
428 soft_valid=gapw)
429 ! rhox_tot_gspace contains the values on the grid points of rhox = sum_munu 4D^X_munu*mu(r)*nu(r)
430 CALL pw_axpy(rhox_g(ispin), rhox_tot_gspace)
431 ! Recover matrix_px1 = (C*X^T + X*C^T)/2
432 IF (nspins == 2) CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
433 END DO
434
435 IF (gapw_xc) THEN
436 ALLOCATE (rhoxx_r(nsev), rhoxx_g(nsev))
437 DO ispin = 1, nsev
438 CALL auxbas_pw_pool%create_pw(rhoxx_r(ispin))
439 CALL auxbas_pw_pool%create_pw(rhoxx_g(ispin))
440 END DO
441 DO ispin = 1, nsev
442 IF (nspins == 2) CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
443 CALL calculate_rho_elec(ks_env=ks_env, matrix_p=matrix_px1(ispin)%matrix, &
444 rho=rhoxx_r(ispin), rho_gspace=rhoxx_g(ispin), &
445 soft_valid=gapw_xc)
446 IF (nspins == 2) CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
447 END DO
448 END IF
449
450 CALL get_qs_env(qs_env, matrix_s=matrix_s, force=force)
451
452 IF (.NOT. (is_rks_triplets .OR. do_sf)) THEN
453 CALL auxbas_pw_pool%create_pw(xv_hartree_rspace)
454 CALL auxbas_pw_pool%create_pw(xv_hartree_gspace)
455 ! calculate associated hartree potential
456 IF (gapw) THEN
457 CALL pw_axpy(local_rho_set%rho0_mpole%rho0_s_gs, rhox_tot_gspace)
458 IF (ASSOCIATED(local_rho_set%rho0_mpole%rhoz_cneo_s_gs)) THEN
459 CALL pw_axpy(local_rho_set%rho0_mpole%rhoz_cneo_s_gs, rhox_tot_gspace)
460 END IF
461 END IF
462 CALL pw_poisson_solve(poisson_env, rhox_tot_gspace, xehartree, &
463 xv_hartree_gspace)
464 CALL pw_transfer(xv_hartree_gspace, xv_hartree_rspace)
465 CALL pw_scale(xv_hartree_rspace, xv_hartree_rspace%pw_grid%dvol)
466 !
467 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
468 NULLIFY (matrix_hx)
469 CALL dbcsr_allocate_matrix_set(matrix_hx, nspins)
470 DO ispin = 1, nspins
471 ALLOCATE (matrix_hx(ispin)%matrix)
472 CALL dbcsr_create(matrix_hx(ispin)%matrix, template=matrix_s(1)%matrix)
473 CALL dbcsr_copy(matrix_hx(ispin)%matrix, matrix_s(1)%matrix)
474 CALL dbcsr_set(matrix_hx(ispin)%matrix, 0.0_dp)
475 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=xv_hartree_rspace, &
476 pmat=matrix_px1(ispin), hmat=matrix_hx(ispin), &
477 gapw=gapw, calculate_forces=.true.)
478 END DO
479 IF (debug_forces) THEN
480 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
481 CALL para_env%sum(fodeb)
482 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dKh[Dx] ", fodeb
483 END IF
484 IF (gapw) THEN
485 IF (debug_forces) fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1)
486 CALL vh_1c_gg_integrals(qs_env, eh1c, hartree_local%ecoul_1c, local_rho_set, para_env, tddft=.true., &
487 core_2nd=.true.)
488 IF (nspins == 1) THEN
489 kval = 1.0_dp
490 ELSE
491 kval = 0.5_dp
492 END IF
493 CALL integrate_vhg0_rspace(qs_env, xv_hartree_rspace, para_env, calculate_forces=.true., &
494 local_rho_set=local_rho_set, kforce=kval)
495 IF (debug_forces) THEN
496 fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1) - fodeb(1:3)
497 CALL para_env%sum(fodeb)
498 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dKh[Dx]PAWg0", fodeb
499 END IF
500 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
501 CALL update_ks_atom(qs_env, matrix_hx, matrix_px1, forces=.true., &
502 rho_atom_external=local_rho_set%rho_atom_set)
503 IF (debug_forces) THEN
504 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
505 CALL para_env%sum(fodeb)
506 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dKh[Dx]PAW", fodeb
507 END IF
508 END IF
509 END IF
510
511 ! XC
512 IF (full_kernel%do_exck) THEN
513 cpabort("NYA")
514 END IF
515 NULLIFY (fxc_rho, fxc_tau, gxc_rho, gxc_tau)
516 xc_section => full_kernel%xc_section
517 CALL section_vals_val_get(xc_section, "XC_FUNCTIONAL%_SECTION_PARAMETERS_", &
518 i_val=myfun)
519 IF (.NOT. ((myfun == xc_none) .OR. (tddfpt_control%spinflip == tddfpt_sf_col))) THEN
520 SELECT CASE (ex_env%xc_kernel_method)
522 do_analytic = .true.
523 do_numeric = .true.
525 do_analytic = .true.
526 do_numeric = .false.
528 do_analytic = .false.
529 do_numeric = .true.
530 CASE DEFAULT
531 cpabort("invalid xc_kernel_method")
532 END SELECT
533 order = ex_env%diff_order
534 eps_delta = ex_env%eps_delta_rho
535
536 IF (gapw_xc) THEN
537 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho_xc=rho)
538 ELSE
539 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho=rho)
540 END IF
541 CALL qs_rho_get(rho, rho_ao=matrix_p)
542 NULLIFY (rhox)
543 ALLOCATE (rhox)
544 ! Create rhox object to collect all information on matrix_px1, including its values on the
545 ! grid points
546 CALL qs_rho_create(rhox)
547 IF (gapw_xc) THEN
548 CALL qs_rho_set(rho_struct=rhox, rho_ao=matrix_px1, rho_r=rhoxx_r, rho_g=rhoxx_g, &
549 rho_r_valid=.true., rho_g_valid=.true.)
550 ELSE
551 CALL qs_rho_set(rho_struct=rhox, rho_ao=matrix_px1, rho_r=rhox_r, rho_g=rhox_g, &
552 rho_r_valid=.true., rho_g_valid=.true.)
553 END IF
554 ! Calculate the exchange-correlation kernel derivative contribution, notice that for open-shell
555 ! rhox_r contains a factor of 2!
556 IF (do_analytic .AND. .NOT. do_numeric) THEN
557 IF (.NOT. do_sf) THEN
558 cpabort("Analytic 3rd EXC derivatives not available")
559 ELSE !TODO
560 CALL get_qs_env(qs_env, xcint_weights=weights)
561 CALL qs_fgxc_analytic(rho, rhox, xc_section, weights, auxbas_pw_pool, &
562 fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
563 END IF
564 ELSEIF (do_numeric) THEN
565 IF (do_analytic) THEN
566 CALL qs_fgxc_gdiff(ks_env, rho, rhox, xc_section, order, eps_delta, is_rks_triplets, &
567 weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
568 ELSE
569 CALL qs_fgxc_create(ks_env, rho, rhox, xc_section, order, is_rks_triplets, &
570 fxc_rho, fxc_tau, gxc_rho, gxc_tau)
571 END IF
572 ELSE
573 cpabort("FHXC forces analytic/numeric")
574 END IF
575
576 IF (nspins == 2) THEN
577 DO ispin = 1, nspins
578 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
579 IF (ASSOCIATED(gxc_tau)) CALL pw_scale(gxc_tau(ispin), 0.5_dp)
580 END DO
581 END IF
582 IF (gapw .OR. gapw_xc) THEN
583 IF (do_analytic .AND. .NOT. do_numeric) THEN
584 cpabort("Analytic 3rd EXC derivatives not available")
585 ELSEIF (do_numeric) THEN
586 IF (do_analytic) THEN
587 CALL gfxc_atom_diff(qs_env, ex_env%local_rho_set%rho_atom_set, &
588 local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, &
589 qs_kind_set, xc_section, is_rks_triplets, order, eps_delta)
590 ELSE
591 CALL calculate_gfxc_atom(qs_env, ex_env%local_rho_set%rho_atom_set, &
592 local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, &
593 qs_kind_set, xc_section, is_rks_triplets, order)
594 END IF
595 ELSE
596 cpabort("FHXC forces analytic/numeric")
597 END IF
598 END IF
599
600 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
601 NULLIFY (matrix_fx)
602 CALL dbcsr_allocate_matrix_set(matrix_fx, SIZE(fxc_rho))
603 DO ispin = 1, SIZE(fxc_rho, 1)
604 ALLOCATE (matrix_fx(ispin)%matrix)
605 CALL dbcsr_create(matrix_fx(ispin)%matrix, template=matrix_s(1)%matrix)
606 CALL dbcsr_copy(matrix_fx(ispin)%matrix, matrix_s(1)%matrix)
607 CALL dbcsr_set(matrix_fx(ispin)%matrix, 0.0_dp)
608 CALL pw_scale(fxc_rho(ispin), fxc_rho(ispin)%pw_grid%dvol)
609 ! Calculate 2sum_sigmatau<munu|fxc|sigmatau>D^X_sigmatau
610 ! fxc_rho here containes a factor of 2
611 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=fxc_rho(ispin), &
612 pmat=matrix_px1(ispin), hmat=matrix_fx(ispin), &
613 gapw=(gapw .OR. gapw_xc), calculate_forces=.true.)
614 END DO
615 IF (debug_forces) THEN
616 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
617 CALL para_env%sum(fodeb)
618 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dfxc[Dx] ", fodeb
619 END IF
620
621 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
622 NULLIFY (matrix_gx)
623 CALL dbcsr_allocate_matrix_set(matrix_gx, nspins)
624 ! Calculate exchange-correlation kernel derivative 2<D^X D^X|gxc|mu nu>
625 ! gxc comes with a factor of 4, so a factor of 1/2 is introduced
626 DO ispin = 1, nspins
627 ALLOCATE (matrix_gx(ispin)%matrix)
628 CALL dbcsr_create(matrix_gx(ispin)%matrix, template=matrix_s(1)%matrix)
629 CALL dbcsr_copy(matrix_gx(ispin)%matrix, matrix_s(1)%matrix)
630 CALL dbcsr_set(matrix_gx(ispin)%matrix, 0.0_dp)
631 CALL pw_scale(gxc_rho(ispin), gxc_rho(ispin)%pw_grid%dvol)
632 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
633 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=gxc_rho(ispin), &
634 pmat=matrix_p(ispin), hmat=matrix_gx(ispin), &
635 gapw=(gapw .OR. gapw_xc), calculate_forces=.true.)
636 CALL dbcsr_scale(matrix_gx(ispin)%matrix, 2.0_dp)
637 END DO
638 IF (debug_forces) THEN
639 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
640 CALL para_env%sum(fodeb)
641 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dgxc[Dx]", fodeb
642 END IF
643 CALL qs_fgxc_release(ks_env, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
644
645 ! grid weight contribution to forces
646 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
647 CALL accint_weight_force(qs_env, rho, rhox, 2, xc_section, is_rks_triplets)
648 IF (debug_forces) THEN
649 fodeb(1:3) = force(1)%rho_elec(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*fxc[Dx]*dw", fodeb
652 END IF
653
654 ! Well, this is a hack :-(
655 ! When qs_rho_set() was called on rhox it assumed ownership of the passed arrays.
656 ! However, these arrays actually belong to ex_env. Hence, we can not call qs_rho_release()
657 ! because this would release the arrays. Instead we're simply going to deallocate rhox.
658 DEALLOCATE (rhox)
659
660 IF (gapw .OR. gapw_xc) THEN
661 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
662 CALL update_ks_atom(qs_env, matrix_fx, matrix_px1, forces=.true., tddft=.true., &
663 rho_atom_external=local_rho_set_f%rho_atom_set, &
664 kintegral=1.0_dp, kforce=1.0_dp)
665 IF (debug_forces) THEN
666 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
667 CALL para_env%sum(fodeb)
668 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dfxc[Dx]PAW ", fodeb
669 END IF
670 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
671 IF (nspins == 1) THEN
672 CALL update_ks_atom(qs_env, matrix_gx, matrix_p, forces=.true., tddft=.true., &
673 rho_atom_external=local_rho_set_g%rho_atom_set, &
674 kscale=0.5_dp)
675 ELSE
676 CALL update_ks_atom(qs_env, matrix_gx, matrix_p, forces=.true., &
677 rho_atom_external=local_rho_set_g%rho_atom_set, &
678 kintegral=0.5_dp, kforce=0.25_dp)
679 END IF
680 IF (debug_forces) THEN
681 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
682 CALL para_env%sum(fodeb)
683 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dgxc[Dx]PAW ", fodeb
684 END IF
685 END IF
686 END IF
687
688 ! ADMM XC correction Exc[rho_admm]
689 IF (do_admm .AND. tddfpt_control%admm_xc_correction .AND. (tddfpt_control%spinflip /= tddfpt_sf_col)) THEN
690 IF (admm_env%aux_exch_func == do_admm_aux_exch_func_none) THEN
691 ! nothing to do
692 ELSE
693 IF (.NOT. tddfpt_control%admm_symm) THEN
694 CALL cp_warn(__location__, "Forces need symmetric ADMM kernel corrections")
695 cpabort("ADMM KERNEL CORRECTION")
696 END IF
697 xc_section => admm_env%xc_section_aux
698 CALL get_admm_env(admm_env, rho_aux_fit=rho_aux_fit, matrix_s_aux_fit=matrix_s_aux_fit, &
699 task_list_aux_fit=task_list)
700 basis_type = "AUX_FIT"
701 IF (admm_env%do_gapw) THEN
702 basis_type = "AUX_FIT_SOFT"
703 task_list => admm_env%admm_gapw_env%task_list
704 END IF
705 !
706 NULLIFY (mfx, mgx)
707 CALL dbcsr_allocate_matrix_set(mfx, nsev)
708 CALL dbcsr_allocate_matrix_set(mgx, nspins)
709 DO ispin = 1, nsev
710 ALLOCATE (mfx(ispin)%matrix)
711 CALL dbcsr_create(mfx(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
712 CALL dbcsr_copy(mfx(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
713 CALL dbcsr_set(mfx(ispin)%matrix, 0.0_dp)
714 END DO
715 DO ispin = 1, nspins
716 ALLOCATE (mgx(ispin)%matrix)
717 CALL dbcsr_create(mgx(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
718 CALL dbcsr_copy(mgx(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
719 CALL dbcsr_set(mgx(ispin)%matrix, 0.0_dp)
720 END DO
721
722 ! ADMM density and response density
723 NULLIFY (rho_g_aux, rho_r_aux, rhox_g_aux, rhox_r_aux)
724 CALL qs_rho_get(rho_aux_fit, rho_r=rho_r_aux, rho_g=rho_g_aux)
725 CALL qs_rho_get(rho_aux_fit, rho_ao=matrix_p_admm)
726 ! rhox_aux
727 ALLOCATE (rhox_r_aux(nsev), rhox_g_aux(nsev))
728 DO ispin = 1, nsev
729 CALL auxbas_pw_pool%create_pw(rhox_r_aux(ispin))
730 CALL auxbas_pw_pool%create_pw(rhox_g_aux(ispin))
731 END DO
732 DO ispin = 1, nsev
733 CALL calculate_rho_elec(ks_env=ks_env, matrix_p=matrix_px1_admm(ispin)%matrix, &
734 rho=rhox_r_aux(ispin), rho_gspace=rhox_g_aux(ispin), &
735 basis_type=basis_type, &
736 task_list_external=task_list)
737 END DO
738 !
739 NULLIFY (rhox_aux)
740 ALLOCATE (rhox_aux)
741 CALL qs_rho_create(rhox_aux)
742 CALL qs_rho_set(rho_struct=rhox_aux, rho_ao=matrix_px1_admm, &
743 rho_r=rhox_r_aux, rho_g=rhox_g_aux, &
744 rho_r_valid=.true., rho_g_valid=.true.)
745 IF (do_analytic .AND. .NOT. do_numeric) THEN
746 cpabort("Analytic 3rd derivatives of EXC not available")
747 ELSEIF (do_numeric) THEN
748 IF (do_analytic) THEN
749 CALL qs_fgxc_gdiff(ks_env, rho_aux_fit, rhox_aux, xc_section, order, eps_delta, &
750 is_rks_triplets, weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
751 ELSE
752 CALL qs_fgxc_create(ks_env, rho_aux_fit, rhox_aux, xc_section, &
753 order, is_rks_triplets, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
754 END IF
755 ELSE
756 cpabort("FHXC forces analytic/numeric")
757 END IF
758
759 ! grid weight contribution to forces ADMM XC correction term
760 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
761 !
762 CALL accint_weight_force(qs_env, rho_aux_fit, rhox_aux, 2, xc_section, is_rks_triplets)
763 !
764 IF (debug_forces) THEN
765 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
766 CALL para_env%sum(fodeb)
767 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx_admm*fxc[Dx_admm]*dw", fodeb
768 END IF
769
770 ! Well, this is a hack :-(
771 ! When qs_rho_set() was called on rhox_aux it assumed ownership of the passed arrays.
772 ! However, these arrays actually belong to ex_env. Hence, we can not call qs_rho_release()
773 ! because this would release the arrays. Instead we're simply going to deallocate rhox_aux.
774 DEALLOCATE (rhox_aux)
775
776 DO ispin = 1, nsev
777 CALL auxbas_pw_pool%give_back_pw(rhox_r_aux(ispin))
778 CALL auxbas_pw_pool%give_back_pw(rhox_g_aux(ispin))
779 END DO
780 DEALLOCATE (rhox_r_aux, rhox_g_aux)
781 fscal = 1.0_dp
782 IF (nspins == 2) fscal = 2.0_dp
783 !
784 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
785 DO ispin = 1, nsev
786 CALL pw_scale(fxc_rho(ispin), fxc_rho(ispin)%pw_grid%dvol)
787 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=fxc_rho(ispin), &
788 hmat=mfx(ispin), &
789 pmat=matrix_px1_admm(ispin), &
790 basis_type=basis_type, &
791 calculate_forces=.true., &
792 force_adm=fscal, &
793 task_list_external=task_list)
794 END DO
795 IF (debug_forces) THEN
796 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
797 CALL para_env%sum(fodeb)
798 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dfxc[Dx]ADMM", fodeb
799 END IF
800
801 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
802 DO ispin = 1, nsev
803 CALL pw_scale(gxc_rho(ispin), gxc_rho(ispin)%pw_grid%dvol)
804 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
805 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=gxc_rho(ispin), &
806 hmat=mgx(ispin), &
807 pmat=matrix_p_admm(ispin), &
808 basis_type=basis_type, &
809 calculate_forces=.true., &
810 force_adm=fscal, &
811 task_list_external=task_list)
812 CALL dbcsr_scale(mgx(ispin)%matrix, 2.0_dp)
813 END DO
814 IF (debug_forces) THEN
815 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
816 CALL para_env%sum(fodeb)
817 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dgxc[Dx]ADMM", fodeb
818 END IF
819 CALL qs_fgxc_release(ks_env, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
820 !
821 IF (admm_env%do_gapw) THEN
822 CALL get_admm_env(admm_env, sab_aux_fit=sab_aux_fit)
823 rho_atom_set => admm_env%admm_gapw_env%local_rho_set%rho_atom_set
824 rho_atom_set_f => local_rho_set_f_admm%rho_atom_set
825 rho_atom_set_g => local_rho_set_g_admm%rho_atom_set
826
827 IF (do_analytic .AND. .NOT. do_numeric) THEN
828 cpabort("Analytic 3rd EXC derivatives not available")
829 ELSEIF (do_numeric) THEN
830 IF (do_analytic) THEN
831 CALL gfxc_atom_diff(qs_env, rho_atom_set, &
832 rho_atom_set_f, rho_atom_set_g, &
833 admm_env%admm_gapw_env%admm_kind_set, xc_section, &
834 is_rks_triplets, order, eps_delta)
835 ELSE
836 CALL calculate_gfxc_atom(qs_env, rho_atom_set, &
837 rho_atom_set_f, rho_atom_set_g, &
838 admm_env%admm_gapw_env%admm_kind_set, xc_section, &
839 is_rks_triplets, order)
840 END IF
841 ELSE
842 cpabort("FHXC forces analytic/numeric")
843 END IF
844
845 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
846 IF (nspins == 1) THEN
847 CALL update_ks_atom(qs_env, mfx, matrix_px1_admm, forces=.true., &
848 rho_atom_external=rho_atom_set_f, &
849 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
850 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
851 kintegral=2.0_dp, kforce=0.5_dp)
852 ELSE
853 CALL update_ks_atom(qs_env, mfx, matrix_px1_admm, forces=.true., &
854 rho_atom_external=rho_atom_set_f, &
855 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
856 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
857 kintegral=2.0_dp, kforce=1.0_dp)
858 END IF
859 IF (debug_forces) THEN
860 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
861 CALL para_env%sum(fodeb)
862 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dfxc[Dx]ADMM-PAW ", fodeb
863 END IF
864 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
865 IF (nspins == 1) THEN
866 CALL update_ks_atom(qs_env, mgx, matrix_p, forces=.true., &
867 rho_atom_external=rho_atom_set_g, &
868 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
869 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
870 kintegral=1.0_dp, kforce=0.5_dp)
871 ELSE
872 CALL update_ks_atom(qs_env, mgx, matrix_p, forces=.true., &
873 rho_atom_external=rho_atom_set_g, &
874 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
875 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
876 kintegral=1.0_dp, kforce=1.0_dp)
877 END IF
878 IF (debug_forces) THEN
879 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
880 CALL para_env%sum(fodeb)
881 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dgxc[Dx]ADMM-PAW ", fodeb
882 END IF
883 END IF
884 !
885 ! A' fx A - Forces
886 !
887 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
888 fval = 2.0_dp*real(nspins, kind=dp)
889 CALL admm_projection_derivative(qs_env, mfx, matrix_px1, fval)
890 IF (debug_forces) THEN
891 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
892 CALL para_env%sum(fodeb)
893 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*dfXC(P)*S' ", fodeb
894 END IF
895 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
896 fval = 2.0_dp*real(nspins, kind=dp)
897 CALL admm_projection_derivative(qs_env, mgx, matrix_p, fval)
898 IF (debug_forces) THEN
899 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
900 CALL para_env%sum(fodeb)
901 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*dgXC(P)*S' ", fodeb
902 END IF
903 !
904 ! Add ADMM fx/gx to the full basis fx/gx
905 fscal = 1.0_dp
906 IF (nspins == 2) fscal = 2.0_dp
907 nao = admm_env%nao_orb
908 nao_aux = admm_env%nao_aux_fit
909 ALLOCATE (dbwork)
910 CALL dbcsr_create(dbwork, template=matrix_fx(1)%matrix)
911 DO ispin = 1, nsev
912 ! fx
913 CALL cp_dbcsr_sm_fm_multiply(mfx(ispin)%matrix, admm_env%A, &
914 admm_env%work_aux_orb, nao)
915 CALL parallel_gemm('T', 'N', nao, nao, nao_aux, &
916 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
917 admm_env%work_orb_orb)
918 CALL dbcsr_copy(dbwork, matrix_fx(1)%matrix)
919 CALL dbcsr_set(dbwork, 0.0_dp)
920 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork, keep_sparsity=.true.)
921 CALL dbcsr_add(matrix_fx(ispin)%matrix, dbwork, 1.0_dp, fscal)
922 ! gx
923 CALL cp_dbcsr_sm_fm_multiply(mgx(ispin)%matrix, admm_env%A, &
924 admm_env%work_aux_orb, nao)
925 CALL parallel_gemm('T', 'N', nao, nao, nao_aux, &
926 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
927 admm_env%work_orb_orb)
928 CALL dbcsr_set(dbwork, 0.0_dp)
929 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork, keep_sparsity=.true.)
930 CALL dbcsr_add(matrix_gx(ispin)%matrix, dbwork, 1.0_dp, fscal)
931 END DO
932 CALL dbcsr_release(dbwork)
933 DEALLOCATE (dbwork)
936
937 END IF
938 END IF
939
940 DO ispin = 1, nsev
941 CALL auxbas_pw_pool%give_back_pw(rhox_r(ispin))
942 CALL auxbas_pw_pool%give_back_pw(rhox_g(ispin))
943 END DO
944 DEALLOCATE (rhox_r, rhox_g)
945 CALL auxbas_pw_pool%give_back_pw(rhox_tot_gspace)
946 IF (gapw_xc) THEN
947 DO ispin = 1, nsev
948 CALL auxbas_pw_pool%give_back_pw(rhoxx_r(ispin))
949 CALL auxbas_pw_pool%give_back_pw(rhoxx_g(ispin))
950 END DO
951 DEALLOCATE (rhoxx_r, rhoxx_g)
952 END IF
953 IF (.NOT. (is_rks_triplets .OR. do_sf)) THEN
954 CALL auxbas_pw_pool%give_back_pw(xv_hartree_rspace)
955 CALL auxbas_pw_pool%give_back_pw(xv_hartree_gspace)
956 END IF
957
958 ! HFX
959 IF (do_hfx) THEN
960 NULLIFY (matrix_hfx, matrix_hfx_asymm)
961 CALL dbcsr_allocate_matrix_set(matrix_hfx, nsev)
962 CALL dbcsr_allocate_matrix_set(matrix_hfx_asymm, nsev)
963 DO ispin = 1, nsev
964 ALLOCATE (matrix_hfx(ispin)%matrix)
965 CALL dbcsr_create(matrix_hfx(ispin)%matrix, template=matrix_s(1)%matrix)
966 CALL dbcsr_copy(matrix_hfx(ispin)%matrix, matrix_s(1)%matrix)
967 CALL dbcsr_set(matrix_hfx(ispin)%matrix, 0.0_dp)
968
969 ALLOCATE (matrix_hfx_asymm(ispin)%matrix)
970 CALL dbcsr_create(matrix_hfx_asymm(ispin)%matrix, template=matrix_s(1)%matrix, &
971 matrix_type=dbcsr_type_antisymmetric)
972 CALL dbcsr_complete_redistribute(matrix_hfx(ispin)%matrix, matrix_hfx_asymm(ispin)%matrix)
973 END DO
974 !
975 xc_section => full_kernel%xc_section
976 hfx_section => section_vals_get_subs_vals(xc_section, "HF")
977 CALL section_vals_get(hfx_section, n_repetition=n_rep_hf)
978 cpassert(n_rep_hf == 1)
979 CALL section_vals_val_get(hfx_section, "TREAT_LSD_IN_CORE", l_val=hfx_treat_lsd_in_core, &
980 i_rep_section=1)
981 mspin = 1
982 IF (hfx_treat_lsd_in_core) mspin = nsev
983 !
984 CALL get_qs_env(qs_env=qs_env, x_data=x_data, s_mstruct_changed=s_mstruct_changed)
985 distribute_fock_matrix = .true.
986 !
987 IF (do_admm) THEN
988 CALL get_admm_env(qs_env%admm_env, matrix_s_aux_fit=matrix_s_aux_fit)
989 NULLIFY (matrix_hfx_admm, matrix_hfx_admm_asymm)
990 CALL dbcsr_allocate_matrix_set(matrix_hfx_admm, nsev)
991 CALL dbcsr_allocate_matrix_set(matrix_hfx_admm_asymm, nsev)
992 DO ispin = 1, nsev
993 ALLOCATE (matrix_hfx_admm(ispin)%matrix)
994 CALL dbcsr_create(matrix_hfx_admm(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
995 CALL dbcsr_copy(matrix_hfx_admm(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
996 CALL dbcsr_set(matrix_hfx_admm(ispin)%matrix, 0.0_dp)
997
998 ALLOCATE (matrix_hfx_admm_asymm(ispin)%matrix)
999 CALL dbcsr_create(matrix_hfx_admm_asymm(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix, &
1000 matrix_type=dbcsr_type_antisymmetric)
1001 CALL dbcsr_complete_redistribute(matrix_hfx_admm(ispin)%matrix, matrix_hfx_admm_asymm(ispin)%matrix)
1002 END DO
1003 !
1004 NULLIFY (mpe, mhe)
1005 ALLOCATE (mpe(nsev, 1), mhe(nsev, 1))
1006 DO ispin = 1, nsev
1007 mhe(ispin, 1)%matrix => matrix_hfx_admm(ispin)%matrix
1008 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
1009 END DO
1010 IF (x_data(1, 1)%do_hfx_ri) THEN
1011 eh1 = 0.0_dp
1012 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1013 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1014 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1015 ELSE
1016 DO ispin = 1, mspin
1017 eh1 = 0.0
1018 CALL integrate_four_center(qs_env, x_data, mhe, eh1, mpe, hfx_section, &
1019 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1020 ispin=ispin, nspins=nsev)
1021 END DO
1022 END IF
1023 !anti-symmetric density
1024 DO ispin = 1, nsev
1025 mhe(ispin, 1)%matrix => matrix_hfx_admm_asymm(ispin)%matrix
1026 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1027 END DO
1028 IF (x_data(1, 1)%do_hfx_ri) THEN
1029 eh1 = 0.0_dp
1030 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1031 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1032 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1033 ELSE
1034 DO ispin = 1, mspin
1035 eh1 = 0.0
1036 CALL integrate_four_center(qs_env, x_data, mhe, eh1, mpe, hfx_section, &
1037 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1038 ispin=ispin, nspins=nsev)
1039 END DO
1040 END IF
1041 !
1042 nao = admm_env%nao_orb
1043 nao_aux = admm_env%nao_aux_fit
1044 ALLOCATE (dbwork, dbwork_asymm)
1045 CALL dbcsr_create(dbwork, template=matrix_hfx(1)%matrix)
1046 CALL dbcsr_create(dbwork_asymm, template=matrix_hfx(1)%matrix, matrix_type=dbcsr_type_antisymmetric)
1047 DO ispin = 1, nsev
1048 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx_admm(ispin)%matrix, admm_env%A, &
1049 admm_env%work_aux_orb, nao)
1050 CALL parallel_gemm('T', 'N', nao, nao, nao_aux, &
1051 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
1052 admm_env%work_orb_orb)
1053 CALL dbcsr_copy(dbwork, matrix_hfx(1)%matrix)
1054 CALL dbcsr_set(dbwork, 0.0_dp)
1055 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork, keep_sparsity=.true.)
1056 CALL dbcsr_add(matrix_hfx(ispin)%matrix, dbwork, 1.0_dp, 1.0_dp)
1057 !anti-symmetric case
1058 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx_admm_asymm(ispin)%matrix, admm_env%A, &
1059 admm_env%work_aux_orb, nao)
1060 CALL parallel_gemm('T', 'N', nao, nao, nao_aux, &
1061 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
1062 admm_env%work_orb_orb)
1063 CALL dbcsr_copy(dbwork_asymm, matrix_hfx_asymm(1)%matrix)
1064 CALL dbcsr_set(dbwork_asymm, 0.0_dp)
1065 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork_asymm, keep_sparsity=.true.)
1066 CALL dbcsr_add(matrix_hfx_asymm(ispin)%matrix, dbwork_asymm, 1.0_dp, 1.0_dp)
1067 END DO
1068 CALL dbcsr_release(dbwork)
1069 CALL dbcsr_release(dbwork_asymm)
1070 DEALLOCATE (dbwork, dbwork_asymm)
1071 ! forces
1072 ! ADMM Projection force
1073 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
1074 fval = 4.0_dp*real(nspins, kind=dp)*0.5_dp !0.5 for symm/anti-symm
1075 CALL admm_projection_derivative(qs_env, matrix_hfx_admm, matrix_px1, fval)
1076 CALL admm_projection_derivative(qs_env, matrix_hfx_admm_asymm, matrix_px1_asymm, fval)
1077 IF (debug_forces) THEN
1078 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
1079 CALL para_env%sum(fodeb)
1080 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: P*Hx(P)*S' ", fodeb
1081 END IF
1082 !
1083 use_virial = .false.
1084 NULLIFY (mdum)
1085 fval = 2.0_dp*real(nspins, kind=dp)*0.5_dp !0.5 factor because of symemtry/anti-symmetry
1086 ! For SF TDDFT integrate_four_center and derivatives_four_center routines introduce a factor of 1/2
1087 IF (do_sf) fval = fval*2.0_dp
1088 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1089 DO ispin = 1, nsev
1090 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
1091 END DO
1092 IF (x_data(1, 1)%do_hfx_ri) THEN
1093 CALL hfx_ri_update_forces(qs_env, x_data(1, 1)%ri_data, nspins, &
1094 x_data(1, 1)%general_parameter%fraction, &
1095 rho_ao=mpe, rho_ao_resp=mdum, &
1096 use_virial=use_virial, rescale_factor=fval)
1097 ELSE
1098 CALL derivatives_four_center(qs_env, mpe, mdum, hfx_section, para_env, 1, use_virial, &
1099 adiabatic_rescale_factor=fval, nspins=nsev)
1100 END IF
1101 DO ispin = 1, nsev
1102 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1103 END DO
1104 IF (x_data(1, 1)%do_hfx_ri) THEN
1105 CALL hfx_ri_update_forces(qs_env, x_data(1, 1)%ri_data, nspins, &
1106 x_data(1, 1)%general_parameter%fraction, &
1107 rho_ao=mpe, rho_ao_resp=mdum, &
1108 use_virial=use_virial, rescale_factor=fval)
1109 ELSE
1110 CALL derivatives_four_center(qs_env, mpe, mdum, hfx_section, para_env, 1, use_virial, &
1111 adiabatic_rescale_factor=fval, nspins=SIZE(mpe, 1))
1112 END IF
1113 IF (debug_forces) THEN
1114 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
1115 CALL para_env%sum(fodeb)
1116 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dhfx'*Dx ", fodeb
1117 END IF
1118 !
1119 DEALLOCATE (mpe, mhe)
1120 !
1121 CALL dbcsr_deallocate_matrix_set(matrix_hfx_admm)
1122 CALL dbcsr_deallocate_matrix_set(matrix_hfx_admm_asymm)
1123 ELSE
1124 NULLIFY (mpe, mhe)
1125 ALLOCATE (mpe(nsev, 1), mhe(nsev, 1))
1126 DO ispin = 1, nsev
1127 mhe(ispin, 1)%matrix => matrix_hfx(ispin)%matrix
1128 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1129 END DO
1130 IF (x_data(1, 1)%do_hfx_ri) THEN
1131 eh1 = 0.0_dp
1132 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1133 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1134 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1135 ELSE
1136 DO ispin = 1, mspin
1137 eh1 = 0.0
1138 CALL integrate_four_center(qs_env, x_data, mhe, eh1, mpe, hfx_section, &
1139 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1140 ispin=ispin, nspins=SIZE(mpe, 1))
1141 END DO
1142 END IF
1143
1144 !anti-symmetric density matrix
1145 DO ispin = 1, nsev
1146 mhe(ispin, 1)%matrix => matrix_hfx_asymm(ispin)%matrix
1147 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1148 END DO
1149 IF (x_data(1, 1)%do_hfx_ri) THEN
1150 eh1 = 0.0_dp
1151 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1152 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1153 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1154 ELSE
1155 DO ispin = 1, mspin
1156 eh1 = 0.0
1157 CALL integrate_four_center(qs_env, x_data, mhe, eh1, mpe, hfx_section, &
1158 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1159 ispin=ispin, nspins=SIZE(mpe, 1))
1160 END DO
1161 END IF
1162 ! forces
1163 use_virial = .false.
1164 NULLIFY (mdum)
1165 fval = 2.0_dp*real(nspins, kind=dp)*0.5_dp !extra 0.5 factor because of symmetry/antisymemtry
1166 ! For SF TDDFT integrate_four_center and derivatives_four_center routines introduce a factor of 1/2
1167 IF (do_sf) fval = fval*2.0_dp
1168 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1169 DO ispin = 1, nsev
1170 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1171 END DO
1172 IF (x_data(1, 1)%do_hfx_ri) THEN
1173 CALL hfx_ri_update_forces(qs_env, x_data(1, 1)%ri_data, nspins, &
1174 x_data(1, 1)%general_parameter%fraction, &
1175 rho_ao=mpe, rho_ao_resp=mdum, &
1176 use_virial=use_virial, rescale_factor=fval)
1177 ELSE
1178 CALL derivatives_four_center(qs_env, mpe, mdum, hfx_section, para_env, 1, use_virial, &
1179 adiabatic_rescale_factor=fval, nspins=SIZE(mpe, 1))
1180 END IF
1181 DO ispin = 1, nsev
1182 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1183 END DO
1184 IF (x_data(1, 1)%do_hfx_ri) THEN
1185 CALL hfx_ri_update_forces(qs_env, x_data(1, 1)%ri_data, nspins, &
1186 x_data(1, 1)%general_parameter%fraction, &
1187 rho_ao=mpe, rho_ao_resp=mdum, &
1188 use_virial=use_virial, rescale_factor=fval)
1189 ELSE
1190 CALL derivatives_four_center(qs_env, mpe, mdum, hfx_section, para_env, 1, use_virial, &
1191 adiabatic_rescale_factor=fval, nspins=SIZE(mpe, 1))
1192 END IF
1193 IF (debug_forces) THEN
1194 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
1195 CALL para_env%sum(fodeb)
1196 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Dx*dhfx*Dx ", fodeb
1197 END IF
1198 !
1199 DEALLOCATE (mpe, mhe)
1200 END IF
1201 fval = 2.0_dp*real(nspins, kind=dp)*0.5_dp !extra 0.5 because of symm/antisymm
1202 ! For SF TDDFT integrate_four_center and derivatives_four_center routines introduce a factor of 1/2
1203 IF (do_sf) fval = fval*2.0_dp
1204 DO ispin = 1, nsev
1205 CALL dbcsr_scale(matrix_hfx(ispin)%matrix, fval)
1206 CALL dbcsr_scale(matrix_hfx_asymm(ispin)%matrix, fval)
1207 END DO
1208 END IF
1209
1210 IF (gapw .OR. gapw_xc) THEN
1211 CALL local_rho_set_release(local_rho_set)
1212 CALL local_rho_set_release(local_rho_set_f)
1213 CALL local_rho_set_release(local_rho_set_g)
1214 IF (gapw) THEN
1215 CALL hartree_local_release(hartree_local)
1216 END IF
1217 END IF
1218 IF (do_admm) THEN
1219 IF (admm_env%do_gapw) THEN
1220 IF (tddfpt_control%admm_xc_correction) THEN
1221 IF (qs_env%admm_env%aux_exch_func /= do_admm_aux_exch_func_none) THEN
1222 CALL local_rho_set_release(local_rho_set_admm)
1223 CALL local_rho_set_release(local_rho_set_f_admm)
1224 CALL local_rho_set_release(local_rho_set_g_admm)
1225 END IF
1226 END IF
1227 END IF
1228 END IF
1229
1230 ! HFX short range
1231 IF (do_hfxsr) THEN
1232 cpabort("HFXSR not implemented")
1233 END IF
1234 ! HFX long range
1235 IF (do_hfxlr) THEN
1236 cpabort("HFXLR not implemented")
1237 END IF
1238
1239 CALL get_qs_env(qs_env, sab_orb=sab_orb)
1240 NULLIFY (matrix_wx1)
1241 CALL dbcsr_allocate_matrix_set(matrix_wx1, nspins)
1242 cpmos => ex_env%cpmos
1243 focc = 2.0_dp
1244 IF (nspins == 2) focc = 1.0_dp
1245
1246 ! Initialize mos and dimensions of occupied space
1247 ! In the following comments mos is referred to as Ca and mos2 as Cb
1248 spin = 1
1249 mos => gs_mos(1)%mos_occ
1250 mosa => gs_mos(1)%mos_active
1251 norb(1) = gs_mos(1)%nmo_occ
1252 nactive(1) = gs_mos(1)%nmo_active
1253 IF (nspins == 2) THEN
1254 mos2 => gs_mos(2)%mos_occ
1255 mosa2 => gs_mos(2)%mos_active
1256 norb(2) = gs_mos(2)%nmo_occ
1257 nactive(2) = gs_mos(2)%nmo_active
1258 END IF
1259 ! Build response vector, Eq. 49, and the third term of \Lamda_munu, Eq. 51
1260 DO ispin = 1, nspins
1261
1262 IF (nactive(ispin) == norb(ispin)) THEN
1263 do_res = .false.
1264 DO ia = 1, nactive(ispin)
1265 cpassert(ia == gs_mos(ispin)%index_active(ia))
1266 END DO
1267 ELSE
1268 do_res = .true.
1269 END IF
1270
1271 ! Initialize mos and dimensions of occupied space
1272 IF (.NOT. do_sf) THEN
1273 spin = ispin
1274 mos => gs_mos(ispin)%mos_occ
1275 mos2 => gs_mos(ispin)%mos_occ
1276 mosa => gs_mos(ispin)%mos_active
1277 mosa2 => gs_mos(ispin)%mos_active
1278 END IF
1279
1280 ! Create working fields for the response vector
1281 CALL cp_fm_create(cpscr, gs_mos(ispin)%mos_active%matrix_struct, "cpscr", set_zero=.true.)
1282 !
1283 CALL cp_fm_get_info(gs_mos(ispin)%mos_occ, matrix_struct=fm_struct, nrow_global=nao)
1284 !
1285 CALL cp_fm_create(avamat, fm_struct, nrow=nactive(spin), ncol=nactive(spin))
1286 CALL cp_fm_create(avcmat, fm_struct, nrow=nactive(spin), ncol=norb(spin))
1287 CALL cp_fm_create(cvcmat, fm_struct, nrow=norb(spin), ncol=norb(spin))
1288 !
1289 CALL cp_fm_create(vcvec, gs_mos(ispin)%mos_occ%matrix_struct, "vcvec")
1290 CALL cp_fm_create(vavec, gs_mos(ispin)%mos_active%matrix_struct, "vavec")
1291
1292 ! Allocate and initialize the Lambda matrix
1293 ALLOCATE (matrix_wx1(ispin)%matrix)
1294 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1295 CALL cp_dbcsr_alloc_block_from_nbl(matrix_wx1(ispin)%matrix, sab_orb)
1296 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1297
1298 ! Add Hartree contributions to the perturbation vector
1299 IF (.NOT. (is_rks_triplets .OR. do_sf)) THEN
1300 CALL cp_dbcsr_sm_fm_multiply(matrix_hx(ispin)%matrix, evect(ispin), &
1301 cpscr, nactive(ispin), alpha=focc, beta=1.0_dp)
1302 CALL cp_dbcsr_sm_fm_multiply(matrix_hx(ispin)%matrix, mos, vcvec, norb(ispin), &
1303 alpha=1.0_dp, beta=0.0_dp)
1304 CALL parallel_gemm("T", "N", nactive(ispin), norb(ispin), nao, 1.0_dp, &
1305 mosa, vcvec, 0.0_dp, avcmat)
1306 CALL parallel_gemm("N", "N", nao, norb(ispin), nactive(ispin), 1.0_dp, &
1307 evect(ispin), avcmat, 0.0_dp, vcvec)
1308 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), norb(ispin), alpha=-focc, beta=1.0_dp)
1309 !
1310 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=mos, matrix_g=vcvec, &
1311 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1312 END IF
1313 ! Add exchange-correlation kernel and exchange-correlation kernel derivative contributions to the response vector
1314 IF ((myfun /= xc_none) .AND. (tddfpt_control%spinflip /= tddfpt_sf_col)) THEN
1315
1316 ! XC Kernel contributions
1317 ! For spin-flip excitations this is the only contribution to the alpha response vector
1318 IF (.NOT. (do_sf .AND. (ispin == 2))) THEN
1319 ! F*X
1320 CALL cp_dbcsr_sm_fm_multiply(matrix_fx(spin)%matrix, evect(spin), &
1321 cpscr, nactive(ispin), alpha=focc, beta=1.0_dp)
1322 END IF
1323 ! For spin-flip excitations this is the only contribution to the beta response vector
1324 IF (.NOT. (do_sf .AND. (ispin == 1))) THEN
1325 ! F*Cb
1326 CALL cp_dbcsr_sm_fm_multiply(matrix_fx(spin)%matrix, mos2, vcvec, &
1327 norb(ispin), alpha=1.0_dp, beta=0.0_dp)
1328 ! Ca^T*F*Cb
1329 CALL parallel_gemm("T", "N", nactive(spin), norb(ispin), nao, 1.0_dp, &
1330 mosa, vcvec, 0.0_dp, avcmat)
1331 ! X*Ca^T*F*Cb
1332 CALL parallel_gemm("N", "N", nao, norb(ispin), nactive(spin), 1.0_dp, &
1333 evect(spin), avcmat, 0.0_dp, vcvec)
1334 ! -S*X*Ca^T*F*Cb
1335 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1336 norb(ispin), alpha=-focc, beta=1.0_dp)
1337 ! Add contributions to the \Lambda_munu for the perturbed overlap matrix term, third term of Eq. 51
1338 ! 2X*Ca^T*F*Cb*Cb^T
1339 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=gs_mos(ispin)%mos_occ, &
1340 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1341 END IF
1342 !
1343
1344 ! XC g (third functional derivative) contributions
1345 ! g*Ca*focc
1346 CALL cp_dbcsr_sm_fm_multiply(matrix_gx(ispin)%matrix, gs_mos(ispin)%mos_occ, &
1347 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1348 ! Add contributions to the \Lambda_munu for the perturbed overlap matrix term, third term of Eq. 51
1349 ! g*Ca
1350 CALL cp_dbcsr_sm_fm_multiply(matrix_gx(ispin)%matrix, gs_mos(ispin)%mos_occ, vcvec, norb(ispin), &
1351 alpha=1.0_dp, beta=0.0_dp)
1352 ! Ca^T*g*Ca
1353 CALL parallel_gemm("T", "N", norb(ispin), norb(ispin), nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1354 ! Ca*Ca^T*g*Ca
1355 CALL parallel_gemm("N", "N", nao, norb(ispin), norb(ispin), 1.0_dp, gs_mos(ispin)%mos_occ, cvcmat, 0.0_dp, vcvec)
1356 ! Ca*Ca^T*g*Ca*Ca^T
1357 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=gs_mos(ispin)%mos_occ, &
1358 ncol=norb(ispin), alpha=1.0_dp, symmetry_mode=1)
1359 !
1360 END IF
1361 ! Add Fock contributions to the response vector
1362 IF (do_hfx) THEN
1363 ! For spin-flip excitations this is the only contribution to the alpha response vector
1364 IF (.NOT. (do_sf .AND. (ispin == 2))) THEN
1365 ! F^sym*X
1366 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx(spin)%matrix, evect(spin), &
1367 cpscr, nactive(spin), alpha=focc, beta=1.0_dp)
1368 ! F^asym*X
1369 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx_asymm(spin)%matrix, evect(spin), &
1370 cpscr, nactive(spin), alpha=focc, beta=1.0_dp)
1371 END IF
1372
1373 ! For spin-flip excitations this is the only contribution to the beta response vector
1374 IF (.NOT. (do_sf .AND. (ispin == 1))) THEN
1375 ! F^sym*Cb
1376 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx(spin)%matrix, mos2, vcvec, norb(ispin), &
1377 alpha=1.0_dp, beta=0.0_dp)
1378 ! -F^asym*Cb
1379 CALL cp_dbcsr_sm_fm_multiply(matrix_hfx_asymm(spin)%matrix, mos2, vcvec, norb(ispin), &
1380 alpha=1.0_dp, beta=1.0_dp)
1381 ! Ca^T*F*Cb
1382 CALL parallel_gemm("T", "N", nactive(spin), norb(ispin), nao, 1.0_dp, &
1383 mosa, vcvec, 0.0_dp, avcmat)
1384 ! X*Ca^T*F*Cb
1385 CALL parallel_gemm("N", "N", nao, norb(ispin), nactive(spin), 1.0_dp, &
1386 evect(spin), avcmat, 0.0_dp, vcvec)
1387 ! -S*X*Ca^T*F*Cb
1388 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1389 norb(ispin), alpha=-focc, beta=1.0_dp)
1390 ! Add contributions to the \Lambda_munu for the perturbed overlap matrix term, third term of Eq. 51
1391 ! 2X*Ca^T*F*Cb*Cb^T
1392 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=mos2, &
1393 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1394 END IF
1395 END IF
1396 !
1397 IF (do_res) THEN
1398 DO ia = 1, nactive(ispin)
1399 ib = gs_mos(ispin)%index_active(ia)
1400 CALL cp_fm_add_columns(cpscr, cpmos(ispin), 1, 1.0_dp, ia, ib)
1401 END DO
1402 ELSE
1403 CALL cp_fm_geadd(1.0_dp, "N", cpscr, 1.0_dp, cpmos(ispin))
1404 END IF
1405 !
1406 CALL cp_fm_release(cpscr)
1407 CALL cp_fm_release(avamat)
1408 CALL cp_fm_release(avcmat)
1409 CALL cp_fm_release(cvcmat)
1410 CALL cp_fm_release(vcvec)
1411 CALL cp_fm_release(vavec)
1412 END DO
1413
1414 IF (.NOT. (is_rks_triplets .OR. do_sf)) THEN
1415 CALL dbcsr_deallocate_matrix_set(matrix_hx)
1416 END IF
1417 IF (ASSOCIATED(ex_env%matrix_wx1)) CALL dbcsr_deallocate_matrix_set(ex_env%matrix_wx1)
1418 ex_env%matrix_wx1 => matrix_wx1
1419 IF (.NOT. ((myfun == xc_none) .OR. (tddfpt_control%spinflip == tddfpt_sf_col))) THEN
1420 CALL dbcsr_deallocate_matrix_set(matrix_fx)
1421 CALL dbcsr_deallocate_matrix_set(matrix_gx)
1422 END IF
1423 IF (do_hfx) THEN
1424 CALL dbcsr_deallocate_matrix_set(matrix_hfx)
1425 CALL dbcsr_deallocate_matrix_set(matrix_hfx_asymm)
1426 END IF
1427
1428 CALL timestop(handle)
1429
1430 END SUBROUTINE fhxc_force
1431
1432! **************************************************************************************************
1433!> \brief Simplified Tamm Dancoff approach (sTDA). Kernel contribution to forces
1434!> \param qs_env ...
1435!> \param ex_env ...
1436!> \param gs_mos ...
1437!> \param stda_env ...
1438!> \param sub_env ...
1439!> \param work ...
1440!> \param debug_forces ...
1441! **************************************************************************************************
1442 SUBROUTINE stda_force(qs_env, ex_env, gs_mos, stda_env, sub_env, work, debug_forces)
1443
1444 TYPE(qs_environment_type), POINTER :: qs_env
1445 TYPE(excited_energy_type), POINTER :: ex_env
1446 TYPE(tddfpt_ground_state_mos), DIMENSION(:), &
1447 POINTER :: gs_mos
1448 TYPE(stda_env_type), POINTER :: stda_env
1449 TYPE(tddfpt_subgroup_env_type) :: sub_env
1450 TYPE(tddfpt_work_matrices) :: work
1451 LOGICAL, INTENT(IN) :: debug_forces
1452
1453 CHARACTER(len=*), PARAMETER :: routinen = 'stda_force'
1454
1455 INTEGER :: atom_i, atom_j, ewald_type, handle, i, &
1456 ia, iatom, idimk, ikind, iounit, is, &
1457 ispin, jatom, jkind, jspin, nao, &
1458 natom, norb, nsgf, nspins
1459 INTEGER, ALLOCATABLE, DIMENSION(:) :: atom_of_kind, first_sgf, kind_of, &
1460 last_sgf
1461 INTEGER, DIMENSION(2) :: nactive, nlim
1462 LOGICAL :: calculate_forces, do_coulomb, do_ewald, &
1463 found, is_rks_triplets, use_virial
1464 REAL(kind=dp) :: alpha, bp, dgabr, dr, eta, fdim, gabr, &
1465 hfx, rbeta, spinfac, xfac
1466 REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: tcharge, tv
1467 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: gtcharge
1468 REAL(kind=dp), DIMENSION(3) :: fij, fodeb, rij
1469 REAL(kind=dp), DIMENSION(:, :), POINTER :: gab, pblock
1470 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
1471 TYPE(cell_type), POINTER :: cell
1472 TYPE(cp_fm_struct_type), POINTER :: fmstruct, fmstruct_mat, fmstructjspin
1473 TYPE(cp_fm_type) :: cvcmat, cvec, cvecjspin, t0matrix, &
1474 t1matrix, vcvec, xvec
1475 TYPE(cp_fm_type), ALLOCATABLE, DIMENSION(:) :: xtransformed
1476 TYPE(cp_fm_type), DIMENSION(:), POINTER :: cpmos, x
1477 TYPE(cp_fm_type), POINTER :: ct, ctjspin, ucmatrix, uxmatrix
1478 TYPE(cp_logger_type), POINTER :: logger
1479 TYPE(dbcsr_iterator_type) :: iter
1480 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: gamma_matrix, matrix_plo, matrix_s, &
1481 matrix_wx1, scrm
1482 TYPE(dbcsr_type) :: pdens, ptrans
1483 TYPE(dbcsr_type), POINTER :: tempmat
1484 TYPE(dft_control_type), POINTER :: dft_control
1485 TYPE(ewald_environment_type), POINTER :: ewald_env
1486 TYPE(ewald_pw_type), POINTER :: ewald_pw
1487 TYPE(mp_para_env_type), POINTER :: para_env
1488 TYPE(neighbor_list_set_p_type), DIMENSION(:), &
1489 POINTER :: n_list, sab_orb
1490 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1491 TYPE(qs_force_type), DIMENSION(:), POINTER :: force
1492 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1493 TYPE(qs_ks_env_type), POINTER :: ks_env
1494 TYPE(stda_control_type), POINTER :: stda_control
1495 TYPE(tddfpt2_control_type), POINTER :: tddfpt_control
1496 TYPE(virial_type), POINTER :: virial
1497
1498 CALL timeset(routinen, handle)
1499
1500 cpassert(ASSOCIATED(ex_env))
1501 cpassert(ASSOCIATED(gs_mos))
1502
1503 logger => cp_get_default_logger()
1504 IF (logger%para_env%is_source()) THEN
1505 iounit = cp_logger_get_default_unit_nr(logger, local=.true.)
1506 ELSE
1507 iounit = -1
1508 END IF
1509
1510 CALL get_qs_env(qs_env, dft_control=dft_control)
1511 tddfpt_control => dft_control%tddfpt2_control
1512 stda_control => tddfpt_control%stda_control
1513 nspins = dft_control%nspins
1514 is_rks_triplets = tddfpt_control%rks_triplets .AND. (nspins == 1)
1515
1516 x => ex_env%evect
1517
1518 nactive(:) = stda_env%nactive(:)
1519 xfac = 2.0_dp
1520 spinfac = 2.0_dp
1521 IF (nspins == 2) spinfac = 1.0_dp
1522 NULLIFY (matrix_wx1)
1523 CALL dbcsr_allocate_matrix_set(matrix_wx1, nspins)
1524 NULLIFY (matrix_plo)
1525 CALL dbcsr_allocate_matrix_set(matrix_plo, nspins)
1526
1527 IF (nspins == 1 .AND. is_rks_triplets) THEN
1528 do_coulomb = .false.
1529 ELSE
1530 do_coulomb = .true.
1531 END IF
1532 do_ewald = stda_control%do_ewald
1533
1534 CALL get_qs_env(qs_env, para_env=para_env, force=force)
1535
1536 CALL get_qs_env(qs_env, natom=natom, cell=cell, &
1537 particle_set=particle_set, qs_kind_set=qs_kind_set)
1538 ALLOCATE (first_sgf(natom))
1539 ALLOCATE (last_sgf(natom))
1540 CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf, last_sgf=last_sgf)
1541
1542 CALL get_qs_env(qs_env, ks_env=ks_env, matrix_s=matrix_s, sab_orb=sab_orb, atomic_kind_set=atomic_kind_set)
1543 CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind)
1544
1545 ! calculate Loewdin transformed Davidson trial vector tilde(X)=S^1/2*X
1546 ! and tilde(tilde(X))=S^1/2_A*tilde(X)_A
1547 ALLOCATE (xtransformed(nspins))
1548 DO ispin = 1, nspins
1549 NULLIFY (fmstruct)
1550 ct => work%ctransformed(ispin)
1551 CALL cp_fm_get_info(ct, matrix_struct=fmstruct)
1552 CALL cp_fm_create(matrix=xtransformed(ispin), matrix_struct=fmstruct, name="XTRANSFORMED")
1553 END DO
1554 CALL get_lowdin_x(work%shalf, x, xtransformed)
1555
1556 ALLOCATE (tcharge(natom), gtcharge(natom, 4))
1557
1558 cpmos => ex_env%cpmos
1559
1560 DO ispin = 1, nspins
1561 ct => work%ctransformed(ispin)
1562 CALL cp_fm_get_info(ct, matrix_struct=fmstruct, nrow_global=nsgf)
1563 ALLOCATE (tv(nsgf))
1564 CALL cp_fm_create(cvec, fmstruct)
1565 CALL cp_fm_create(xvec, fmstruct)
1566 !
1567 ALLOCATE (matrix_wx1(ispin)%matrix)
1568 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1569 CALL cp_dbcsr_alloc_block_from_nbl(matrix_wx1(ispin)%matrix, sab_orb)
1570 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1571 ALLOCATE (matrix_plo(ispin)%matrix)
1572 CALL dbcsr_create(matrix=matrix_plo(ispin)%matrix, template=matrix_s(1)%matrix)
1573 CALL cp_dbcsr_alloc_block_from_nbl(matrix_plo(ispin)%matrix, sab_orb)
1574 CALL dbcsr_set(matrix_plo(ispin)%matrix, 0.0_dp)
1575 !
1576 ! *** Coulomb contribution
1577 !
1578 IF (do_coulomb) THEN
1579 !
1580 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1581 !
1582 tcharge(:) = 0.0_dp
1583 DO jspin = 1, nspins
1584 ctjspin => work%ctransformed(jspin)
1585 CALL cp_fm_get_info(ctjspin, matrix_struct=fmstructjspin)
1586 CALL cp_fm_get_info(ctjspin, matrix_struct=fmstructjspin, nrow_global=nsgf)
1587 CALL cp_fm_create(cvecjspin, fmstructjspin)
1588 ! CV(mu,j) = CT(mu,j)*XT(mu,j)
1589 CALL cp_fm_schur_product(ctjspin, xtransformed(jspin), cvecjspin)
1590 ! TV(mu) = SUM_j CV(mu,j)
1591 CALL cp_fm_vectorssum(cvecjspin, tv, "R")
1592 ! contract charges
1593 ! TC(a) = SUM_(mu of a) TV(mu)
1594 DO ia = 1, natom
1595 DO is = first_sgf(ia), last_sgf(ia)
1596 tcharge(ia) = tcharge(ia) + tv(is)
1597 END DO
1598 END DO
1599 CALL cp_fm_release(cvecjspin)
1600 END DO !jspin
1601 ! Apply tcharge*gab -> gtcharge
1602 ! gT(b) = SUM_a g(a,b)*TC(a)
1603 ! gab = work%gamma_exchange(1)%matrix
1604 gtcharge = 0.0_dp
1605 ! short range contribution
1606 NULLIFY (gamma_matrix)
1607 CALL setup_gamma(qs_env, stda_env, sub_env, gamma_matrix, ndim=4)
1608 tempmat => gamma_matrix(1)%matrix
1609 CALL dbcsr_iterator_start(iter, tempmat)
1610 DO WHILE (dbcsr_iterator_blocks_left(iter))
1611 CALL dbcsr_iterator_next_block(iter, iatom, jatom, gab)
1612 gtcharge(iatom, 1) = gtcharge(iatom, 1) + gab(1, 1)*tcharge(jatom)
1613 IF (iatom /= jatom) THEN
1614 gtcharge(jatom, 1) = gtcharge(jatom, 1) + gab(1, 1)*tcharge(iatom)
1615 END IF
1616 DO idimk = 2, 4
1617 fdim = -1.0_dp
1618 CALL dbcsr_get_block_p(matrix=gamma_matrix(idimk)%matrix, &
1619 row=iatom, col=jatom, block=gab, found=found)
1620 IF (found) THEN
1621 gtcharge(iatom, idimk) = gtcharge(iatom, idimk) + gab(1, 1)*tcharge(jatom)
1622 IF (iatom /= jatom) THEN
1623 gtcharge(jatom, idimk) = gtcharge(jatom, idimk) + fdim*gab(1, 1)*tcharge(iatom)
1624 END IF
1625 END IF
1626 END DO
1627 END DO
1628 CALL dbcsr_iterator_stop(iter)
1629 CALL dbcsr_deallocate_matrix_set(gamma_matrix)
1630 ! Ewald long range contribution
1631 IF (do_ewald) THEN
1632 ewald_env => work%ewald_env
1633 ewald_pw => work%ewald_pw
1634 CALL ewald_env_get(ewald_env, alpha=alpha, ewald_type=ewald_type)
1635 CALL get_qs_env(qs_env=qs_env, sab_orb=n_list, virial=virial)
1636 use_virial = .false.
1637 calculate_forces = .false.
1638 CALL tb_ewald_overlap(gtcharge, tcharge, alpha, n_list, virial, use_virial)
1639 CALL tb_spme_evaluate(ewald_env, ewald_pw, particle_set, cell, &
1640 gtcharge, tcharge, calculate_forces, virial, use_virial)
1641 ! add self charge interaction contribution
1642 IF (para_env%is_source()) THEN
1643 gtcharge(:, 1) = gtcharge(:, 1) - 2._dp*alpha*oorootpi*tcharge(:)
1644 END IF
1645 ELSE
1646 nlim = get_limit(natom, para_env%num_pe, para_env%mepos)
1647 DO iatom = nlim(1), nlim(2)
1648 DO jatom = 1, iatom - 1
1649 rij = particle_set(iatom)%r - particle_set(jatom)%r
1650 rij = pbc(rij, cell)
1651 dr = sqrt(sum(rij(:)**2))
1652 IF (dr > 1.e-6_dp) THEN
1653 gtcharge(iatom, 1) = gtcharge(iatom, 1) + tcharge(jatom)/dr
1654 gtcharge(jatom, 1) = gtcharge(jatom, 1) + tcharge(iatom)/dr
1655 DO idimk = 2, 4
1656 gtcharge(iatom, idimk) = gtcharge(iatom, idimk) + rij(idimk - 1)*tcharge(jatom)/dr**3
1657 gtcharge(jatom, idimk) = gtcharge(jatom, idimk) - rij(idimk - 1)*tcharge(iatom)/dr**3
1658 END DO
1659 END IF
1660 END DO
1661 END DO
1662 END IF
1663 CALL para_env%sum(gtcharge(:, 1))
1664 ! expand charges
1665 ! TV(mu) = TC(a of mu)
1666 tv(1:nsgf) = 0.0_dp
1667 DO ia = 1, natom
1668 DO is = first_sgf(ia), last_sgf(ia)
1669 tv(is) = gtcharge(ia, 1)
1670 END DO
1671 END DO
1672 !
1673 DO iatom = 1, natom
1674 ikind = kind_of(iatom)
1675 atom_i = atom_of_kind(iatom)
1676 DO i = 1, 3
1677 fij(i) = spinfac*spinfac*gtcharge(iatom, i + 1)*tcharge(iatom)
1678 END DO
1679 force(ikind)%rho_elec(1, atom_i) = force(ikind)%rho_elec(1, atom_i) - fij(1)
1680 force(ikind)%rho_elec(2, atom_i) = force(ikind)%rho_elec(2, atom_i) - fij(2)
1681 force(ikind)%rho_elec(3, atom_i) = force(ikind)%rho_elec(3, atom_i) - fij(3)
1682 END DO
1683 !
1684 IF (debug_forces) THEN
1685 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1686 CALL para_env%sum(fodeb)
1687 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Coul[X] ", fodeb
1688 END IF
1689 norb = nactive(ispin)
1690 ! forces from Lowdin charge derivative
1691 CALL cp_fm_get_info(work%S_C0_C0T(ispin), matrix_struct=fmstruct)
1692 CALL cp_fm_create(t0matrix, matrix_struct=fmstruct, name="T0 SCRATCH")
1693 CALL cp_fm_create(t1matrix, matrix_struct=fmstruct, name="T1 SCRATCH")
1694 ALLOCATE (ucmatrix)
1695 CALL fm_pool_create_fm(work%fm_pool_ao_mo_active(ispin)%pool, ucmatrix)
1696 ALLOCATE (uxmatrix)
1697 CALL fm_pool_create_fm(work%fm_pool_ao_mo_active(ispin)%pool, uxmatrix)
1698 ct => work%ctransformed(ispin)
1699 CALL cp_fm_to_fm(ct, cvec)
1700 CALL cp_fm_row_scale(cvec, tv)
1701 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1702 cvec, 0.0_dp, ucmatrix)
1703 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1704 x(ispin), 0.0_dp, uxmatrix)
1705 CALL parallel_gemm('N', 'T', nsgf, nsgf, norb, 1.0_dp, uxmatrix, ucmatrix, 0.0_dp, t0matrix)
1706 CALL cp_fm_to_fm(xtransformed(ispin), cvec)
1707 CALL cp_fm_row_scale(cvec, tv)
1708 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1709 cvec, 0.0_dp, uxmatrix)
1710 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1711 gs_mos(ispin)%mos_occ, 0.0_dp, ucmatrix)
1712 CALL parallel_gemm('N', 'T', nsgf, nsgf, norb, 1.0_dp, ucmatrix, uxmatrix, 1.0_dp, t0matrix)
1713 CALL cp_fm_schur_product(work%slambda, t0matrix, t1matrix)
1714 !
1715 CALL parallel_gemm('N', 'N', nsgf, nsgf, nsgf, spinfac, work%S_eigenvectors, t1matrix, &
1716 0.0_dp, t0matrix)
1717 CALL cp_dbcsr_plus_fm_fm_t(matrix_plo(ispin)%matrix, matrix_v=t0matrix, &
1718 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1719 CALL fm_pool_give_back_fm(work%fm_pool_ao_mo_active(ispin)%pool, ucmatrix)
1720 DEALLOCATE (ucmatrix)
1721 CALL fm_pool_give_back_fm(work%fm_pool_ao_mo_active(ispin)%pool, uxmatrix)
1722 DEALLOCATE (uxmatrix)
1723 CALL cp_fm_release(t0matrix)
1724 CALL cp_fm_release(t1matrix)
1725 !
1726 ! CV(mu,i) = TV(mu)*XT(mu,i)
1727 CALL cp_fm_to_fm(xtransformed(ispin), cvec)
1728 CALL cp_fm_row_scale(cvec, tv)
1729 CALL cp_dbcsr_sm_fm_multiply(work%shalf, cvec, cpmos(ispin), norb, 2.0_dp*spinfac, 1.0_dp)
1730 ! CV(mu,i) = TV(mu)*CT(mu,i)
1731 ct => work%ctransformed(ispin)
1732 CALL cp_fm_to_fm(ct, cvec)
1733 CALL cp_fm_row_scale(cvec, tv)
1734 ! Shalf(nu,mu)*CV(mu,i)
1735 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1736 CALL cp_fm_create(vcvec, fmstruct)
1737 CALL cp_dbcsr_sm_fm_multiply(work%shalf, cvec, vcvec, norb, 1.0_dp, 0.0_dp)
1738 CALL cp_fm_struct_create(fmstruct_mat, context=fmstruct%context, nrow_global=norb, &
1739 ncol_global=norb, para_env=fmstruct%para_env)
1740 CALL cp_fm_create(cvcmat, fmstruct_mat)
1741 CALL cp_fm_struct_release(fmstruct_mat)
1742 CALL parallel_gemm("T", "N", norb, norb, nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1743 CALL parallel_gemm("N", "N", nao, norb, norb, 1.0_dp, x(ispin), cvcmat, 0.0_dp, vcvec)
1744 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1745 nactive(ispin), alpha=-2.0_dp*spinfac, beta=1.0_dp)
1746 ! wx1
1747 alpha = 2.0_dp
1748 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=gs_mos(ispin)%mos_occ, &
1749 matrix_g=vcvec, ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1750 CALL cp_fm_release(vcvec)
1751 CALL cp_fm_release(cvcmat)
1752 END IF
1753 !
1754 ! *** Exchange contribution
1755 !
1756 IF (stda_env%do_exchange) THEN
1757 !
1758 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1759 !
1760 norb = nactive(ispin)
1761 !
1762 tempmat => work%shalf
1763 CALL dbcsr_create(pdens, template=tempmat, matrix_type=dbcsr_type_no_symmetry)
1764 ! P(nu,mu) = SUM_j XT(nu,j)*CT(mu,j)
1765 ct => work%ctransformed(ispin)
1766 CALL dbcsr_set(pdens, 0.0_dp)
1767 CALL cp_dbcsr_plus_fm_fm_t(pdens, xtransformed(ispin), ct, nactive(ispin), &
1768 1.0_dp, keep_sparsity=.false.)
1769 CALL dbcsr_filter(pdens, stda_env%eps_td_filter)
1770 ! Apply PP*gab -> PP; gab = gamma_coulomb
1771 ! P(nu,mu) = P(nu,mu)*g(a of nu,b of mu)
1772 bp = stda_env%beta_param
1773 hfx = stda_env%hfx_fraction
1774 CALL dbcsr_iterator_start(iter, pdens)
1775 DO WHILE (dbcsr_iterator_blocks_left(iter))
1776 CALL dbcsr_iterator_next_block(iter, iatom, jatom, pblock)
1777 rij = particle_set(iatom)%r - particle_set(jatom)%r
1778 rij = pbc(rij, cell)
1779 dr = sqrt(sum(rij(:)**2))
1780 ikind = kind_of(iatom)
1781 jkind = kind_of(jatom)
1782 eta = (stda_env%kind_param_set(ikind)%kind_param%hardness_param + &
1783 stda_env%kind_param_set(jkind)%kind_param%hardness_param)/2.0_dp
1784 rbeta = dr**bp
1785 IF (hfx > 0.0_dp) THEN
1786 gabr = (1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp)
1787 ELSE
1788 IF (dr < 1.0e-6_dp) THEN
1789 gabr = 0.0_dp
1790 ELSE
1791 gabr = 1._dp/dr
1792 END IF
1793 END IF
1794 ! gabr = (1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp)
1795 ! forces
1796 IF (dr > 1.0e-6_dp) THEN
1797 IF (hfx > 0.0_dp) THEN
1798 dgabr = -(1._dp/bp)*(1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp + 1._dp)
1799 dgabr = bp*rbeta/dr**2*dgabr
1800 dgabr = sum(pblock**2)*dgabr
1801 ELSE
1802 dgabr = -1.0_dp/dr**3
1803 dgabr = sum(pblock**2)*dgabr
1804 END IF
1805 atom_i = atom_of_kind(iatom)
1806 atom_j = atom_of_kind(jatom)
1807 DO i = 1, 3
1808 fij(i) = dgabr*rij(i)
1809 END DO
1810 force(ikind)%rho_elec(1, atom_i) = force(ikind)%rho_elec(1, atom_i) - fij(1)
1811 force(ikind)%rho_elec(2, atom_i) = force(ikind)%rho_elec(2, atom_i) - fij(2)
1812 force(ikind)%rho_elec(3, atom_i) = force(ikind)%rho_elec(3, atom_i) - fij(3)
1813 force(jkind)%rho_elec(1, atom_j) = force(jkind)%rho_elec(1, atom_j) + fij(1)
1814 force(jkind)%rho_elec(2, atom_j) = force(jkind)%rho_elec(2, atom_j) + fij(2)
1815 force(jkind)%rho_elec(3, atom_j) = force(jkind)%rho_elec(3, atom_j) + fij(3)
1816 END IF
1817 !
1818 pblock = gabr*pblock
1819 END DO
1820 CALL dbcsr_iterator_stop(iter)
1821 !
1822 ! Transpose pdens matrix
1823 CALL dbcsr_create(ptrans, template=pdens)
1824 CALL dbcsr_transposed(ptrans, pdens)
1825 !
1826 ! forces from Lowdin charge derivative
1827 CALL cp_fm_get_info(work%S_C0_C0T(ispin), matrix_struct=fmstruct)
1828 CALL cp_fm_create(t0matrix, matrix_struct=fmstruct, name="T0 SCRATCH")
1829 CALL cp_fm_create(t1matrix, matrix_struct=fmstruct, name="T1 SCRATCH")
1830 ALLOCATE (ucmatrix)
1831 CALL fm_pool_create_fm(work%fm_pool_ao_mo_active(ispin)%pool, ucmatrix)
1832 ALLOCATE (uxmatrix)
1833 CALL fm_pool_create_fm(work%fm_pool_ao_mo_active(ispin)%pool, uxmatrix)
1834 ct => work%ctransformed(ispin)
1835 CALL cp_dbcsr_sm_fm_multiply(pdens, ct, cvec, norb, 1.0_dp, 0.0_dp)
1836 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1837 cvec, 0.0_dp, ucmatrix)
1838 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1839 x(ispin), 0.0_dp, uxmatrix)
1840 CALL parallel_gemm('N', 'T', nsgf, nsgf, norb, 1.0_dp, uxmatrix, ucmatrix, 0.0_dp, t0matrix)
1841 CALL cp_dbcsr_sm_fm_multiply(ptrans, xtransformed(ispin), cvec, norb, 1.0_dp, 0.0_dp)
1842 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1843 cvec, 0.0_dp, uxmatrix)
1844 CALL parallel_gemm('T', 'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1845 gs_mos(ispin)%mos_occ, 0.0_dp, ucmatrix)
1846 CALL parallel_gemm('N', 'T', nsgf, nsgf, norb, 1.0_dp, ucmatrix, uxmatrix, 1.0_dp, t0matrix)
1847 CALL cp_fm_schur_product(work%slambda, t0matrix, t1matrix)
1848 CALL parallel_gemm('N', 'N', nsgf, nsgf, nsgf, -1.0_dp, work%S_eigenvectors, t1matrix, &
1849 0.0_dp, t0matrix)
1850 CALL cp_dbcsr_plus_fm_fm_t(matrix_plo(ispin)%matrix, matrix_v=t0matrix, &
1851 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1852 CALL fm_pool_give_back_fm(work%fm_pool_ao_mo_active(ispin)%pool, ucmatrix)
1853 DEALLOCATE (ucmatrix)
1854 CALL fm_pool_give_back_fm(work%fm_pool_ao_mo_active(ispin)%pool, uxmatrix)
1855 DEALLOCATE (uxmatrix)
1856 CALL cp_fm_release(t0matrix)
1857 CALL cp_fm_release(t1matrix)
1858
1859 ! RHS contribution to response matrix
1860 ! CV(nu,i) = P(nu,mu)*XT(mu,i)
1861 CALL cp_dbcsr_sm_fm_multiply(ptrans, xtransformed(ispin), cvec, norb, 1.0_dp, 0.0_dp)
1862 CALL cp_dbcsr_sm_fm_multiply(work%shalf, cvec, cpmos(ispin), norb, &
1863 alpha=-xfac, beta=1.0_dp)
1864 !
1865 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1866 CALL cp_fm_create(vcvec, fmstruct)
1867 ! CV(nu,i) = P(nu,mu)*CT(mu,i)
1868 CALL cp_dbcsr_sm_fm_multiply(ptrans, ct, cvec, norb, 1.0_dp, 0.0_dp)
1869 CALL cp_dbcsr_sm_fm_multiply(work%shalf, cvec, vcvec, norb, 1.0_dp, 0.0_dp)
1870 CALL cp_fm_struct_create(fmstruct_mat, context=fmstruct%context, nrow_global=norb, &
1871 ncol_global=norb, para_env=fmstruct%para_env)
1872 CALL cp_fm_create(cvcmat, fmstruct_mat)
1873 CALL cp_fm_struct_release(fmstruct_mat)
1874 CALL parallel_gemm("T", "N", norb, norb, nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1875 CALL parallel_gemm("N", "N", nao, norb, norb, 1.0_dp, x(ispin), cvcmat, 0.0_dp, vcvec)
1876 CALL cp_dbcsr_sm_fm_multiply(matrix_s(1)%matrix, vcvec, cpmos(ispin), &
1877 norb, alpha=xfac, beta=1.0_dp)
1878 ! wx1
1879 IF (nspins == 2) THEN
1880 alpha = -2.0_dp
1881 ELSE
1882 alpha = -1.0_dp
1883 END IF
1884 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=gs_mos(ispin)%mos_occ, &
1885 matrix_g=vcvec, &
1886 ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1887 CALL cp_fm_release(vcvec)
1888 CALL cp_fm_release(cvcmat)
1889 !
1890 CALL dbcsr_release(pdens)
1891 CALL dbcsr_release(ptrans)
1892 !
1893 IF (debug_forces) THEN
1894 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1895 CALL para_env%sum(fodeb)
1896 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Exch[X] ", fodeb
1897 END IF
1898 END IF
1899 !
1900 CALL cp_fm_release(cvec)
1901 CALL cp_fm_release(xvec)
1902 DEALLOCATE (tv)
1903 END DO
1904
1905 CALL cp_fm_release(xtransformed)
1906 DEALLOCATE (tcharge, gtcharge)
1907 DEALLOCATE (first_sgf, last_sgf)
1908
1909 ! Lowdin forces
1910 IF (nspins == 2) THEN
1911 CALL dbcsr_add(matrix_plo(1)%matrix, matrix_plo(2)%matrix, &
1912 alpha_scalar=1.0_dp, beta_scalar=1.0_dp)
1913 END IF
1914 CALL dbcsr_scale(matrix_plo(1)%matrix, -1.0_dp)
1915 NULLIFY (scrm)
1916 IF (debug_forces) fodeb(1:3) = force(1)%overlap(1:3, 1)
1917 CALL build_overlap_matrix(ks_env, matrix_s=scrm, &
1918 matrix_name="OVERLAP MATRIX", &
1919 basis_type_a="ORB", basis_type_b="ORB", &
1920 sab_nl=sab_orb, calculate_forces=.true., &
1921 matrix_p=matrix_plo(1)%matrix)
1923 CALL dbcsr_deallocate_matrix_set(matrix_plo)
1924 IF (debug_forces) THEN
1925 fodeb(1:3) = force(1)%overlap(1:3, 1) - fodeb(1:3)
1926 CALL para_env%sum(fodeb)
1927 IF (iounit > 0) WRITE (iounit, "(T3,A,T33,3F16.8)") "DEBUG:: Lowdin ", fodeb
1928 END IF
1929
1930 IF (ASSOCIATED(ex_env%matrix_wx1)) CALL dbcsr_deallocate_matrix_set(ex_env%matrix_wx1)
1931 ex_env%matrix_wx1 => matrix_wx1
1932
1933 CALL timestop(handle)
1934
1935 END SUBROUTINE stda_force
1936
1937! **************************************************************************************************
1938
1939END MODULE qs_tddfpt2_fhxc_forces
subroutine, public accint_weight_force(qs_env, rho, rho1, order, xc_section, triplet)
...
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_add_columns(msource, mtarget, ncol, alpha, source_start, target_start)
Add (and scale) a subset of columns of a fm to a fm b = alpha*a + b.
subroutine, public cp_fm_geadd(alpha, trans, matrix_a, beta, matrix_b)
interface to BLACS geadd: matrix_b = beta*matrix_b + alpha*opt(matrix_a) where opt(matrix_a) can be e...
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, nrow, ncol, set_zero)
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, mimic, 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, xcint_weights, 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, mimic, 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:629
subroutine, public qs_fgxc_gdiff(ks_env, rho0_struct, rho1_struct, xc_section, accuracy, epsrho, is_triplet, weights, fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip)
...
Definition qs_fxc.F:462
subroutine, public qs_fgxc_release(ks_env, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
...
Definition qs_fxc.F:758
subroutine, public qs_fgxc_analytic(rho0_struct, rho1_struct, xc_section, weights, 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:307
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:60
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:511
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.