165 SUBROUTINE fhxc_force(qs_env, ex_env, gs_mos, full_kernel, debug_forces)
172 LOGICAL,
INTENT(IN) :: debug_forces
174 CHARACTER(LEN=*),
PARAMETER :: routinen =
'fhxc_force'
176 CHARACTER(LEN=default_string_length) :: basis_type
177 INTEGER :: handle, iounit, ispin, mspin, myfun, &
178 n_rep_hf, nao, nao_aux, natom, nkind, &
179 norb(2), nspins, order, spin
180 LOGICAL :: distribute_fock_matrix, do_admm,
do_analytic, do_hfx, do_hfxlr, do_hfxsr, &
181 do_numeric, do_sf, gapw, gapw_xc, hfx_treat_lsd_in_core, is_rks_triplets, &
182 s_mstruct_changed, use_virial
183 REAL(kind=
dp) :: eh1, eh1c, eps_delta, eps_fit, focc, &
184 fscal, fval, kval, xehartree
185 REAL(kind=
dp),
DIMENSION(3) :: fodeb
190 TYPE(
cp_fm_type),
DIMENSION(:),
POINTER :: cpmos, evect
193 TYPE(
dbcsr_p_type),
DIMENSION(:),
POINTER :: matrix_fx, matrix_gx, matrix_hfx, &
194 matrix_hfx_admm, matrix_hfx_admm_asymm, matrix_hfx_asymm, matrix_hx, matrix_p, &
195 matrix_p_admm, matrix_px1, matrix_px1_admm, matrix_px1_admm_asymm, matrix_px1_asymm, &
196 matrix_s, matrix_s_aux_fit, matrix_wx1, mdum, mfx, mgx
197 TYPE(
dbcsr_p_type),
DIMENSION(:, :),
POINTER :: mhe, mpe, mpga
198 TYPE(
dbcsr_type),
POINTER :: dbwork, dbwork_asymm
201 TYPE(
hfx_type),
DIMENSION(:, :),
POINTER :: x_data
202 TYPE(
local_rho_type),
POINTER :: local_rho_set, local_rho_set_admm, local_rho_set_f, &
203 local_rho_set_f_admm, local_rho_set_g, local_rho_set_g_admm
206 POINTER :: sab, sab_aux_fit, sab_orb, sap_oce
210 TYPE(
pw_c1d_gs_type),
DIMENSION(:),
POINTER :: rho_g_aux, rhox_g, rhox_g_aux, rhoxx_g
215 TYPE(
pw_r3d_rs_type),
DIMENSION(:),
POINTER :: fxc_rho, fxc_tau, gxc_rho, gxc_tau, &
216 rho_r_aux, rhox_r, rhox_r_aux, rhoxx_r
218 TYPE(
qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
220 TYPE(
qs_rho_type),
POINTER :: rho, rho_aux_fit, rhox, rhox_aux
221 TYPE(
rho_atom_type),
DIMENSION(:),
POINTER :: rho_atom_set, rho_atom_set_f, &
227 CALL timeset(routinen, handle)
230 IF (logger%para_env%is_source())
THEN
236 CALL get_qs_env(qs_env, dft_control=dft_control)
237 tddfpt_control => dft_control%tddfpt2_control
238 nspins = dft_control%nspins
239 is_rks_triplets = tddfpt_control%rks_triplets .AND. (nspins == 1)
246 do_hfx = tddfpt_control%do_hfx
247 do_hfxsr = tddfpt_control%do_hfxsr
248 do_hfxlr = tddfpt_control%do_hfxlr
249 do_admm = tddfpt_control%do_admm
250 gapw = dft_control%qs_control%gapw
251 gapw_xc = dft_control%qs_control%gapw_xc
253 evect => ex_env%evect
254 matrix_px1 => ex_env%matrix_px1
255 matrix_px1_admm => ex_env%matrix_px1_admm
256 matrix_px1_asymm => ex_env%matrix_px1_asymm
257 matrix_px1_admm_asymm => ex_env%matrix_px1_admm_asymm
260 IF (nspins == 2) focc = 0.5_dp
261 DO ispin = 1,
SIZE(evect, 1)
263 CALL dbcsr_set(matrix_px1(ispin)%matrix, 0.0_dp)
266 matrix_v=evect(ispin), &
267 matrix_g=gs_mos(ispin)%mos_occ, &
268 ncol=norb(ispin), alpha=2.0_dp*focc, symmetry_mode=1)
271 CALL dbcsr_set(matrix_px1_asymm(ispin)%matrix, 0.0_dp)
274 matrix_v=gs_mos(ispin)%mos_occ, &
275 matrix_g=evect(ispin), &
276 ncol=norb(ispin), alpha=2.0_dp*focc, &
280 CALL get_qs_env(qs_env, ks_env=ks_env, pw_env=pw_env, para_env=para_env)
282 NULLIFY (hartree_local, local_rho_set, local_rho_set_admm)
283 IF (gapw .OR. gapw_xc)
THEN
284 IF (nspins == 2)
THEN
285 DO ispin = 1,
SIZE(evect, 1)
290 atomic_kind_set=atomic_kind_set, &
291 qs_kind_set=qs_kind_set)
294 qs_kind_set, dft_control, para_env)
297 CALL init_rho0(local_rho_set, qs_env, dft_control%qs_control%gapw_control, &
304 CALL get_qs_env(qs_env=qs_env, oce=oce, sap_oce=sap_oce, sab_orb=sab)
306 CALL get_qs_env(qs_env=qs_env, nkind=nkind, particle_set=particle_set)
308 eps_fit = dft_control%qs_control%gapw_control%eps_fit
313 mpga(1:
SIZE(evect, 1), 1:1) => matrix_px1(1:
SIZE(evect, 1))
315 qs_kind_set, oce, sab, para_env)
320 qs_kind_set, dft_control, para_env)
322 qs_kind_set, oce, sab, para_env)
327 qs_kind_set, dft_control, para_env)
329 qs_kind_set, oce, sab, para_env)
331 IF (nspins == 2)
THEN
332 DO ispin = 1,
SIZE(evect, 1)
340 nao_aux = admm_env%nao_aux_fit
341 nao = admm_env%nao_orb
343 DO ispin = 1,
SIZE(evect, 1)
347 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
348 admm_env%work_aux_orb)
350 1.0_dp, admm_env%work_aux_orb, admm_env%A, 0.0_dp, &
351 admm_env%work_aux_aux)
352 CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_px1_admm(ispin)%matrix, &
353 keep_sparsity=.true.)
355 CALL copy_dbcsr_to_fm(matrix_px1_asymm(ispin)%matrix, admm_env%work_orb_orb)
357 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
358 admm_env%work_aux_orb)
360 1.0_dp, admm_env%work_aux_orb, admm_env%A, 0.0_dp, &
361 admm_env%work_aux_aux)
362 CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_px1_admm_asymm(ispin)%matrix, &
363 keep_sparsity=.true.)
366 IF (admm_env%do_gapw)
THEN
367 IF (do_admm .AND. tddfpt_control%admm_xc_correction)
THEN
371 CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set)
374 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
375 mpga(1:
SIZE(evect, 1), 1:1) => matrix_px1_admm(1:
SIZE(evect, 1))
378 admm_env%admm_gapw_env%admm_kind_set, &
379 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
381 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
385 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
387 admm_env%admm_gapw_env%admm_kind_set, &
388 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
390 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
394 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
396 admm_env%admm_gapw_env%admm_kind_set, &
397 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
399 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
405 CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, &
406 poisson_env=poisson_env)
408 ALLOCATE (rhox_r(
SIZE(evect, 1)), rhox_g(
SIZE(evect, 1)))
409 DO ispin = 1,
SIZE(evect, 1)
410 CALL auxbas_pw_pool%create_pw(rhox_r(ispin))
411 CALL auxbas_pw_pool%create_pw(rhox_g(ispin))
413 CALL auxbas_pw_pool%create_pw(rhox_tot_gspace)
416 DO ispin = 1,
SIZE(evect, 1)
418 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
420 rho=rhox_r(ispin), rho_gspace=rhox_g(ispin), &
423 CALL pw_axpy(rhox_g(ispin), rhox_tot_gspace)
425 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
429 ALLOCATE (rhoxx_r(
SIZE(evect, 1)), rhoxx_g(
SIZE(evect, 1)))
430 DO ispin = 1,
SIZE(evect, 1)
431 CALL auxbas_pw_pool%create_pw(rhoxx_r(ispin))
432 CALL auxbas_pw_pool%create_pw(rhoxx_g(ispin))
434 DO ispin = 1,
SIZE(evect, 1)
435 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
437 rho=rhoxx_r(ispin), rho_gspace=rhoxx_g(ispin), &
439 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
443 CALL get_qs_env(qs_env, matrix_s=matrix_s, force=force)
445 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
446 CALL auxbas_pw_pool%create_pw(xv_hartree_rspace)
447 CALL auxbas_pw_pool%create_pw(xv_hartree_gspace)
450 CALL pw_axpy(local_rho_set%rho0_mpole%rho0_s_gs, rhox_tot_gspace)
451 IF (
ASSOCIATED(local_rho_set%rho0_mpole%rhoz_cneo_s_gs))
THEN
452 CALL pw_axpy(local_rho_set%rho0_mpole%rhoz_cneo_s_gs, rhox_tot_gspace)
457 CALL pw_transfer(xv_hartree_gspace, xv_hartree_rspace)
458 CALL pw_scale(xv_hartree_rspace, xv_hartree_rspace%pw_grid%dvol)
460 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
464 ALLOCATE (matrix_hx(ispin)%matrix)
465 CALL dbcsr_create(matrix_hx(ispin)%matrix, template=matrix_s(1)%matrix)
466 CALL dbcsr_copy(matrix_hx(ispin)%matrix, matrix_s(1)%matrix)
467 CALL dbcsr_set(matrix_hx(ispin)%matrix, 0.0_dp)
468 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=xv_hartree_rspace, &
469 pmat=matrix_px1(ispin), hmat=matrix_hx(ispin), &
470 gapw=gapw, calculate_forces=.true.)
472 IF (debug_forces)
THEN
473 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
474 CALL para_env%sum(fodeb)
475 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dKh[Dx] ", fodeb
478 IF (debug_forces) fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1)
479 CALL vh_1c_gg_integrals(qs_env, eh1c, hartree_local%ecoul_1c, local_rho_set, para_env, tddft=.true., &
481 IF (nspins == 1)
THEN
487 local_rho_set=local_rho_set, kforce=kval)
488 IF (debug_forces)
THEN
489 fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1) - fodeb(1:3)
490 CALL para_env%sum(fodeb)
491 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dKh[Dx]PAWg0", fodeb
493 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
494 CALL update_ks_atom(qs_env, matrix_hx, matrix_px1, forces=.true., &
495 rho_atom_external=local_rho_set%rho_atom_set)
496 IF (debug_forces)
THEN
497 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
498 CALL para_env%sum(fodeb)
499 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dKh[Dx]PAW", fodeb
505 IF (full_kernel%do_exck)
THEN
508 NULLIFY (fxc_rho, fxc_tau, gxc_rho, gxc_tau)
509 xc_section => full_kernel%xc_section
513 SELECT CASE (ex_env%xc_kernel_method)
524 cpabort(
"invalid xc_kernel_method")
526 order = ex_env%diff_order
527 eps_delta = ex_env%eps_delta_rho
530 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho_xc=rho)
532 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho=rho)
541 CALL qs_rho_set(rho_struct=rhox, rho_ao=matrix_px1, rho_r=rhoxx_r, rho_g=rhoxx_g, &
542 rho_r_valid=.true., rho_g_valid=.true.)
544 CALL qs_rho_set(rho_struct=rhox, rho_ao=matrix_px1, rho_r=rhox_r, rho_g=rhox_g, &
545 rho_r_valid=.true., rho_g_valid=.true.)
550 IF (.NOT. do_sf)
THEN
551 cpabort(
"Analytic 3rd EXC derivatives not available")
554 fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
558 CALL qs_fgxc_gdiff(ks_env, rho, rhox, xc_section, order, eps_delta, is_rks_triplets, &
559 fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
561 CALL qs_fgxc_create(ks_env, rho, rhox, xc_section, order, is_rks_triplets, &
562 fxc_rho, fxc_tau, gxc_rho, gxc_tau)
565 cpabort(
"FHXC forces analytic/numeric")
574 IF (nspins == 2)
THEN
576 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
577 IF (
ASSOCIATED(gxc_tau))
CALL pw_scale(gxc_tau(ispin), 0.5_dp)
580 IF (gapw .OR. gapw_xc)
THEN
582 cpabort(
"Analytic 3rd EXC derivatives not available")
586 local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, &
587 qs_kind_set, xc_section, is_rks_triplets, order, eps_delta)
590 local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, &
591 qs_kind_set, xc_section, is_rks_triplets, order)
594 cpabort(
"FHXC forces analytic/numeric")
598 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
601 DO ispin = 1,
SIZE(fxc_rho, 1)
602 ALLOCATE (matrix_fx(ispin)%matrix)
603 CALL dbcsr_create(matrix_fx(ispin)%matrix, template=matrix_s(1)%matrix)
604 CALL dbcsr_copy(matrix_fx(ispin)%matrix, matrix_s(1)%matrix)
605 CALL dbcsr_set(matrix_fx(ispin)%matrix, 0.0_dp)
606 CALL pw_scale(fxc_rho(ispin), fxc_rho(ispin)%pw_grid%dvol)
609 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=fxc_rho(ispin), &
610 pmat=matrix_px1(ispin), hmat=matrix_fx(ispin), &
611 gapw=(gapw .OR. gapw_xc), calculate_forces=.true.)
613 IF (debug_forces)
THEN
614 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
615 CALL para_env%sum(fodeb)
616 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dfxc[Dx] ", fodeb
619 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
625 ALLOCATE (matrix_gx(ispin)%matrix)
626 CALL dbcsr_create(matrix_gx(ispin)%matrix, template=matrix_s(1)%matrix)
627 CALL dbcsr_copy(matrix_gx(ispin)%matrix, matrix_s(1)%matrix)
628 CALL dbcsr_set(matrix_gx(ispin)%matrix, 0.0_dp)
629 CALL pw_scale(gxc_rho(ispin), gxc_rho(ispin)%pw_grid%dvol)
630 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
631 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=gxc_rho(ispin), &
632 pmat=matrix_p(ispin), hmat=matrix_gx(ispin), &
633 gapw=(gapw .OR. gapw_xc), calculate_forces=.true.)
636 IF (debug_forces)
THEN
637 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
638 CALL para_env%sum(fodeb)
639 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dgxc[Dx]", fodeb
643 IF (gapw .OR. gapw_xc)
THEN
644 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
645 CALL update_ks_atom(qs_env, matrix_fx, matrix_px1, forces=.true., tddft=.true., &
646 rho_atom_external=local_rho_set_f%rho_atom_set, &
647 kintegral=1.0_dp, kforce=1.0_dp)
648 IF (debug_forces)
THEN
649 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
650 CALL para_env%sum(fodeb)
651 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dfxc[Dx]PAW ", fodeb
653 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
654 IF (nspins == 1)
THEN
655 CALL update_ks_atom(qs_env, matrix_gx, matrix_p, forces=.true., tddft=.true., &
656 rho_atom_external=local_rho_set_g%rho_atom_set, &
660 rho_atom_external=local_rho_set_g%rho_atom_set, &
661 kintegral=0.5_dp, kforce=0.25_dp)
663 IF (debug_forces)
THEN
664 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
665 CALL para_env%sum(fodeb)
666 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dgxc[Dx]PAW ", fodeb
672 IF (do_admm .AND. tddfpt_control%admm_xc_correction .AND. (tddfpt_control%spinflip .NE.
tddfpt_sf_col))
THEN
676 IF (.NOT. tddfpt_control%admm_symm)
THEN
677 CALL cp_warn(__location__,
"Forces need symmetric ADMM kernel corrections")
678 cpabort(
"ADMM KERNEL CORRECTION")
680 xc_section => admm_env%xc_section_aux
681 CALL get_admm_env(admm_env, rho_aux_fit=rho_aux_fit, matrix_s_aux_fit=matrix_s_aux_fit, &
682 task_list_aux_fit=task_list)
683 basis_type =
"AUX_FIT"
684 IF (admm_env%do_gapw)
THEN
685 basis_type =
"AUX_FIT_SOFT"
686 task_list => admm_env%admm_gapw_env%task_list
692 DO ispin = 1,
SIZE(evect, 1)
693 ALLOCATE (mfx(ispin)%matrix)
694 CALL dbcsr_create(mfx(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
695 CALL dbcsr_copy(mfx(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
696 CALL dbcsr_set(mfx(ispin)%matrix, 0.0_dp)
699 ALLOCATE (mgx(ispin)%matrix)
700 CALL dbcsr_create(mgx(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
701 CALL dbcsr_copy(mgx(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
702 CALL dbcsr_set(mgx(ispin)%matrix, 0.0_dp)
706 NULLIFY (rho_g_aux, rho_r_aux, rhox_g_aux, rhox_r_aux)
707 CALL qs_rho_get(rho_aux_fit, rho_r=rho_r_aux, rho_g=rho_g_aux)
708 CALL qs_rho_get(rho_aux_fit, rho_ao=matrix_p_admm)
710 ALLOCATE (rhox_r_aux(
SIZE(evect, 1)), rhox_g_aux(
SIZE(evect, 1)))
711 DO ispin = 1,
SIZE(evect, 1)
712 CALL auxbas_pw_pool%create_pw(rhox_r_aux(ispin))
713 CALL auxbas_pw_pool%create_pw(rhox_g_aux(ispin))
715 DO ispin = 1,
SIZE(evect, 1)
717 rho=rhox_r_aux(ispin), rho_gspace=rhox_g_aux(ispin), &
718 basis_type=basis_type, &
719 task_list_external=task_list)
725 CALL qs_rho_set(rho_struct=rhox_aux, rho_ao=matrix_px1_admm, &
726 rho_r=rhox_r_aux, rho_g=rhox_g_aux, &
727 rho_r_valid=.true., rho_g_valid=.true.)
729 cpabort(
"Analytic 3rd derivatives of EXC not available")
732 CALL qs_fgxc_gdiff(ks_env, rho_aux_fit, rhox_aux, xc_section, order, eps_delta, &
733 is_rks_triplets, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
736 order, is_rks_triplets, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
739 cpabort(
"FHXC forces analytic/numeric")
746 DEALLOCATE (rhox_aux)
748 DO ispin = 1,
SIZE(evect, 1)
749 CALL auxbas_pw_pool%give_back_pw(rhox_r_aux(ispin))
750 CALL auxbas_pw_pool%give_back_pw(rhox_g_aux(ispin))
752 DEALLOCATE (rhox_r_aux, rhox_g_aux)
754 IF (nspins == 2) fscal = 2.0_dp
756 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
757 DO ispin = 1,
SIZE(evect, 1)
758 CALL pw_scale(fxc_rho(ispin), fxc_rho(ispin)%pw_grid%dvol)
759 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=fxc_rho(ispin), &
761 pmat=matrix_px1_admm(ispin), &
762 basis_type=basis_type, &
763 calculate_forces=.true., &
765 task_list_external=task_list)
767 IF (debug_forces)
THEN
768 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
769 CALL para_env%sum(fodeb)
770 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dfxc[Dx]ADMM", fodeb
773 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
774 DO ispin = 1,
SIZE(evect, 1)
775 CALL pw_scale(gxc_rho(ispin), gxc_rho(ispin)%pw_grid%dvol)
776 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
777 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=gxc_rho(ispin), &
779 pmat=matrix_p_admm(ispin), &
780 basis_type=basis_type, &
781 calculate_forces=.true., &
783 task_list_external=task_list)
786 IF (debug_forces)
THEN
787 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
788 CALL para_env%sum(fodeb)
789 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dgxc[Dx]ADMM", fodeb
793 IF (admm_env%do_gapw)
THEN
795 rho_atom_set => admm_env%admm_gapw_env%local_rho_set%rho_atom_set
796 rho_atom_set_f => local_rho_set_f_admm%rho_atom_set
797 rho_atom_set_g => local_rho_set_g_admm%rho_atom_set
800 cpabort(
"Analytic 3rd EXC derivatives not available")
804 rho_atom_set_f, rho_atom_set_g, &
805 admm_env%admm_gapw_env%admm_kind_set, xc_section, &
806 is_rks_triplets, order, eps_delta)
809 rho_atom_set_f, rho_atom_set_g, &
810 admm_env%admm_gapw_env%admm_kind_set, xc_section, &
811 is_rks_triplets, order)
814 cpabort(
"FHXC forces analytic/numeric")
817 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
818 IF (nspins == 1)
THEN
819 CALL update_ks_atom(qs_env, mfx, matrix_px1_admm, forces=.true., &
820 rho_atom_external=rho_atom_set_f, &
821 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
822 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
823 kintegral=2.0_dp, kforce=0.5_dp)
825 CALL update_ks_atom(qs_env, mfx, matrix_px1_admm, forces=.true., &
826 rho_atom_external=rho_atom_set_f, &
827 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
828 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
829 kintegral=2.0_dp, kforce=1.0_dp)
831 IF (debug_forces)
THEN
832 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
833 CALL para_env%sum(fodeb)
834 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dfxc[Dx]ADMM-PAW ", fodeb
836 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
837 IF (nspins == 1)
THEN
839 rho_atom_external=rho_atom_set_g, &
840 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
841 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
842 kintegral=1.0_dp, kforce=0.5_dp)
845 rho_atom_external=rho_atom_set_g, &
846 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
847 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
848 kintegral=1.0_dp, kforce=1.0_dp)
850 IF (debug_forces)
THEN
851 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
852 CALL para_env%sum(fodeb)
853 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dgxc[Dx]ADMM-PAW ", fodeb
859 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
860 fval = 2.0_dp*real(nspins, kind=
dp)
862 IF (debug_forces)
THEN
863 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
864 CALL para_env%sum(fodeb)
865 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: P*dfXC(P)*S' ", fodeb
867 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
868 fval = 2.0_dp*real(nspins, kind=
dp)
870 IF (debug_forces)
THEN
871 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
872 CALL para_env%sum(fodeb)
873 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: P*dgXC(P)*S' ", fodeb
878 IF (nspins == 2) fscal = 2.0_dp
879 nao = admm_env%nao_orb
880 nao_aux = admm_env%nao_aux_fit
883 DO ispin = 1,
SIZE(evect, 1)
886 admm_env%work_aux_orb, nao)
888 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
889 admm_env%work_orb_orb)
893 CALL dbcsr_add(matrix_fx(ispin)%matrix, dbwork, 1.0_dp, fscal)
896 admm_env%work_aux_orb, nao)
898 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
899 admm_env%work_orb_orb)
902 CALL dbcsr_add(matrix_gx(ispin)%matrix, dbwork, 1.0_dp, fscal)
912 DO ispin = 1,
SIZE(evect, 1)
913 CALL auxbas_pw_pool%give_back_pw(rhox_r(ispin))
914 CALL auxbas_pw_pool%give_back_pw(rhox_g(ispin))
916 DEALLOCATE (rhox_r, rhox_g)
917 CALL auxbas_pw_pool%give_back_pw(rhox_tot_gspace)
919 DO ispin = 1,
SIZE(evect, 1)
920 CALL auxbas_pw_pool%give_back_pw(rhoxx_r(ispin))
921 CALL auxbas_pw_pool%give_back_pw(rhoxx_g(ispin))
923 DEALLOCATE (rhoxx_r, rhoxx_g)
925 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
926 CALL auxbas_pw_pool%give_back_pw(xv_hartree_rspace)
927 CALL auxbas_pw_pool%give_back_pw(xv_hartree_gspace)
932 NULLIFY (matrix_hfx, matrix_hfx_asymm)
935 DO ispin = 1,
SIZE(evect, 1)
936 ALLOCATE (matrix_hfx(ispin)%matrix)
937 CALL dbcsr_create(matrix_hfx(ispin)%matrix, template=matrix_s(1)%matrix)
938 CALL dbcsr_copy(matrix_hfx(ispin)%matrix, matrix_s(1)%matrix)
939 CALL dbcsr_set(matrix_hfx(ispin)%matrix, 0.0_dp)
941 ALLOCATE (matrix_hfx_asymm(ispin)%matrix)
942 CALL dbcsr_create(matrix_hfx_asymm(ispin)%matrix, template=matrix_s(1)%matrix, &
943 matrix_type=dbcsr_type_antisymmetric)
947 xc_section => full_kernel%xc_section
950 cpassert(n_rep_hf == 1)
954 IF (hfx_treat_lsd_in_core) mspin =
SIZE(evect, 1)
956 CALL get_qs_env(qs_env=qs_env, x_data=x_data, s_mstruct_changed=s_mstruct_changed)
957 distribute_fock_matrix = .true.
960 CALL get_admm_env(qs_env%admm_env, matrix_s_aux_fit=matrix_s_aux_fit)
961 NULLIFY (matrix_hfx_admm, matrix_hfx_admm_asymm)
964 DO ispin = 1,
SIZE(evect, 1)
965 ALLOCATE (matrix_hfx_admm(ispin)%matrix)
966 CALL dbcsr_create(matrix_hfx_admm(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
967 CALL dbcsr_copy(matrix_hfx_admm(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
968 CALL dbcsr_set(matrix_hfx_admm(ispin)%matrix, 0.0_dp)
970 ALLOCATE (matrix_hfx_admm_asymm(ispin)%matrix)
971 CALL dbcsr_create(matrix_hfx_admm_asymm(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix, &
972 matrix_type=dbcsr_type_antisymmetric)
977 ALLOCATE (mpe(
SIZE(evect, 1), 1), mhe(
SIZE(evect, 1), 1))
978 DO ispin = 1,
SIZE(evect)
979 mhe(ispin, 1)%matrix => matrix_hfx_admm(ispin)%matrix
980 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
982 IF (x_data(1, 1)%do_hfx_ri)
THEN
985 geometry_did_change=s_mstruct_changed, nspins=nspins, &
986 hf_fraction=x_data(1, 1)%general_parameter%fraction)
991 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
992 ispin=ispin, nspins=
SIZE(evect, 1))
996 DO ispin = 1,
SIZE(evect, 1)
997 mhe(ispin, 1)%matrix => matrix_hfx_admm_asymm(ispin)%matrix
998 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1000 IF (x_data(1, 1)%do_hfx_ri)
THEN
1002 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1003 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1004 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1009 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1010 ispin=ispin, nspins=
SIZE(evect, 1))
1014 nao = admm_env%nao_orb
1015 nao_aux = admm_env%nao_aux_fit
1016 ALLOCATE (dbwork, dbwork_asymm)
1017 CALL dbcsr_create(dbwork, template=matrix_hfx(1)%matrix)
1018 CALL dbcsr_create(dbwork_asymm, template=matrix_hfx(1)%matrix, matrix_type=dbcsr_type_antisymmetric)
1019 DO ispin = 1,
SIZE(evect, 1)
1021 admm_env%work_aux_orb, nao)
1023 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
1024 admm_env%work_orb_orb)
1025 CALL dbcsr_copy(dbwork, matrix_hfx(1)%matrix)
1028 CALL dbcsr_add(matrix_hfx(ispin)%matrix, dbwork, 1.0_dp, 1.0_dp)
1031 admm_env%work_aux_orb, nao)
1033 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
1034 admm_env%work_orb_orb)
1035 CALL dbcsr_copy(dbwork_asymm, matrix_hfx_asymm(1)%matrix)
1037 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork_asymm, keep_sparsity=.true.)
1038 CALL dbcsr_add(matrix_hfx_asymm(ispin)%matrix, dbwork_asymm, 1.0_dp, 1.0_dp)
1042 DEALLOCATE (dbwork, dbwork_asymm)
1045 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
1046 fval = 4.0_dp*real(nspins, kind=
dp)*0.5_dp
1049 IF (debug_forces)
THEN
1050 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
1051 CALL para_env%sum(fodeb)
1052 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: P*Hx(P)*S' ", fodeb
1055 use_virial = .false.
1057 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1059 IF (do_sf) fval = fval*2.0_dp
1060 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1061 DO ispin = 1,
SIZE(evect, 1)
1062 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
1064 IF (x_data(1, 1)%do_hfx_ri)
THEN
1066 x_data(1, 1)%general_parameter%fraction, &
1067 rho_ao=mpe, rho_ao_resp=mdum, &
1068 use_virial=use_virial, rescale_factor=fval)
1071 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
1073 DO ispin = 1,
SIZE(evect, 1)
1074 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1076 IF (x_data(1, 1)%do_hfx_ri)
THEN
1078 x_data(1, 1)%general_parameter%fraction, &
1079 rho_ao=mpe, rho_ao_resp=mdum, &
1080 use_virial=use_virial, rescale_factor=fval)
1083 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
1085 IF (debug_forces)
THEN
1086 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
1087 CALL para_env%sum(fodeb)
1088 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dhfx'*Dx ", fodeb
1091 DEALLOCATE (mpe, mhe)
1097 ALLOCATE (mpe(
SIZE(evect, 1), 1), mhe(
SIZE(evect, 1), 1))
1098 DO ispin = 1,
SIZE(evect, 1)
1099 mhe(ispin, 1)%matrix => matrix_hfx(ispin)%matrix
1100 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1102 IF (x_data(1, 1)%do_hfx_ri)
THEN
1104 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1105 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1106 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1111 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1112 ispin=ispin, nspins=
SIZE(mpe, 1))
1117 DO ispin = 1,
SIZE(evect, 1)
1118 mhe(ispin, 1)%matrix => matrix_hfx_asymm(ispin)%matrix
1119 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1121 IF (x_data(1, 1)%do_hfx_ri)
THEN
1123 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1124 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1125 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1130 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1131 ispin=ispin, nspins=
SIZE(mpe, 1))
1135 use_virial = .false.
1137 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1139 IF (do_sf) fval = fval*2.0_dp
1140 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1141 DO ispin = 1,
SIZE(evect, 1)
1142 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1144 IF (x_data(1, 1)%do_hfx_ri)
THEN
1146 x_data(1, 1)%general_parameter%fraction, &
1147 rho_ao=mpe, rho_ao_resp=mdum, &
1148 use_virial=use_virial, rescale_factor=fval)
1151 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
1153 DO ispin = 1,
SIZE(evect, 1)
1154 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1156 IF (x_data(1, 1)%do_hfx_ri)
THEN
1158 x_data(1, 1)%general_parameter%fraction, &
1159 rho_ao=mpe, rho_ao_resp=mdum, &
1160 use_virial=use_virial, rescale_factor=fval)
1163 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
1165 IF (debug_forces)
THEN
1166 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
1167 CALL para_env%sum(fodeb)
1168 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dhfx*Dx ", fodeb
1171 DEALLOCATE (mpe, mhe)
1173 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1175 IF (do_sf) fval = fval*2.0_dp
1176 DO ispin = 1,
SIZE(evect, 1)
1178 CALL dbcsr_scale(matrix_hfx_asymm(ispin)%matrix, fval)
1182 IF (gapw .OR. gapw_xc)
THEN
1191 IF (admm_env%do_gapw)
THEN
1192 IF (tddfpt_control%admm_xc_correction)
THEN
1204 cpabort(
"HFXSR not implemented")
1208 cpabort(
"HFXLR not implemented")
1212 NULLIFY (matrix_wx1)
1214 cpmos => ex_env%cpmos
1216 IF (nspins == 2) focc = 1.0_dp
1221 mos => gs_mos(1)%mos_occ
1223 IF (nspins == 2)
THEN
1224 mos2 => gs_mos(2)%mos_occ
1228 DO ispin = 1, nspins
1231 IF (.NOT. do_sf)
THEN
1233 mos => gs_mos(ispin)%mos_occ
1234 mos2 => gs_mos(ispin)%mos_occ
1238 CALL cp_fm_create(vcvec, gs_mos(ispin)%mos_occ%matrix_struct,
"vcvec")
1239 CALL cp_fm_get_info(vcvec, matrix_struct=fm_struct, nrow_global=nao)
1240 CALL cp_fm_struct_create(fm_struct_mat, context=fm_struct%context, nrow_global=norb(spin), &
1241 ncol_global=norb(ispin), para_env=fm_struct%para_env)
1245 ALLOCATE (matrix_wx1(ispin)%matrix)
1246 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1248 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1251 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
1253 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1255 CALL parallel_gemm(
"T",
"N", norb(ispin), norb(ispin), nao, 1.0_dp, mos, vcvec, 0.0_dp, cvcmat)
1256 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), norb(ispin), 1.0_dp, evect(ispin), cvcmat, 0.0_dp, vcvec)
1258 norb(ispin), alpha=-focc, beta=1.0_dp)
1261 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1268 IF (.NOT. (do_sf .AND. (ispin .EQ. 2)))
THEN
1271 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1274 IF (.NOT. (do_sf .AND. (ispin .EQ. 1)))
THEN
1278 CALL parallel_gemm(
"T",
"N", norb(spin), norb(ispin), nao, 1.0_dp, mos, vcvec, 0.0_dp, cvcmat)
1280 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), norb(spin), 1.0_dp, evect(spin), cvcmat, 0.0_dp, vcvec)
1283 norb(ispin), alpha=-focc, beta=1.0_dp)
1286 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=gs_mos(ispin)%mos_occ, &
1287 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1294 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1298 alpha=1.0_dp, beta=0.0_dp)
1300 CALL parallel_gemm(
"T",
"N", norb(ispin), norb(ispin), nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1302 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), norb(ispin), 1.0_dp, gs_mos(ispin)%mos_occ, cvcmat, 0.0_dp, vcvec)
1304 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=gs_mos(ispin)%mos_occ, &
1305 ncol=norb(ispin), alpha=1.0_dp, symmetry_mode=1)
1311 IF (.NOT. (do_sf .AND. (ispin .EQ. 2)))
THEN
1314 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1317 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1321 IF (.NOT. (do_sf .AND. (ispin .EQ. 1)))
THEN
1326 alpha=1.0_dp, beta=1.0_dp)
1328 CALL parallel_gemm(
"T",
"N", norb(spin), norb(ispin), nao, 1.0_dp, mos, vcvec, 0.0_dp, cvcmat)
1330 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), norb(spin), 1.0_dp, evect(spin), cvcmat, 0.0_dp, vcvec)
1333 norb(ispin), alpha=-focc, beta=1.0_dp)
1337 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1345 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
1349 ex_env%matrix_wx1 => matrix_wx1
1359 CALL timestop(handle)
1373 SUBROUTINE stda_force(qs_env, ex_env, gs_mos, stda_env, sub_env, work, debug_forces)
1382 LOGICAL,
INTENT(IN) :: debug_forces
1384 CHARACTER(len=*),
PARAMETER :: routinen =
'stda_force'
1386 INTEGER :: atom_i, atom_j, ewald_type, handle, i, &
1387 ia, iatom, idimk, ikind, iounit, is, &
1388 ispin, jatom, jkind, jspin, nao, &
1389 natom, norb, nsgf, nspins
1390 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: atom_of_kind, first_sgf, kind_of, &
1392 INTEGER,
DIMENSION(2) :: nactive, nlim
1393 LOGICAL :: calculate_forces, do_coulomb, do_ewald, &
1394 found, is_rks_triplets, use_virial
1395 REAL(kind=
dp) :: alpha, bp, dgabr, dr, eta, fdim, gabr, &
1396 hfx, rbeta, spinfac, xfac
1397 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:) :: tcharge, tv
1398 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: gtcharge
1399 REAL(kind=
dp),
DIMENSION(3) :: fij, fodeb, rij
1400 REAL(kind=
dp),
DIMENSION(:, :),
POINTER :: gab, pblock
1404 TYPE(
cp_fm_type) :: cvcmat, cvec, cvecjspin, t0matrix, &
1405 t1matrix, vcvec, xvec
1406 TYPE(
cp_fm_type),
ALLOCATABLE,
DIMENSION(:) :: xtransformed
1407 TYPE(
cp_fm_type),
DIMENSION(:),
POINTER :: cpmos, x
1408 TYPE(
cp_fm_type),
POINTER :: ct, ctjspin, ucmatrix, uxmatrix
1411 TYPE(
dbcsr_p_type),
DIMENSION(:),
POINTER :: gamma_matrix, matrix_plo, matrix_s, &
1420 POINTER :: n_list, sab_orb
1423 TYPE(
qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
1429 CALL timeset(routinen, handle)
1431 cpassert(
ASSOCIATED(ex_env))
1432 cpassert(
ASSOCIATED(gs_mos))
1435 IF (logger%para_env%is_source())
THEN
1441 CALL get_qs_env(qs_env, dft_control=dft_control)
1442 tddfpt_control => dft_control%tddfpt2_control
1443 stda_control => tddfpt_control%stda_control
1444 nspins = dft_control%nspins
1445 is_rks_triplets = tddfpt_control%rks_triplets .AND. (nspins == 1)
1449 nactive(:) = stda_env%nactive(:)
1452 IF (nspins == 2) spinfac = 1.0_dp
1453 NULLIFY (matrix_wx1)
1455 NULLIFY (matrix_plo)
1458 IF (nspins == 1 .AND. is_rks_triplets)
THEN
1459 do_coulomb = .false.
1463 do_ewald = stda_control%do_ewald
1465 CALL get_qs_env(qs_env, para_env=para_env, force=force)
1467 CALL get_qs_env(qs_env, natom=natom, cell=cell, &
1468 particle_set=particle_set, qs_kind_set=qs_kind_set)
1469 ALLOCATE (first_sgf(natom))
1470 ALLOCATE (last_sgf(natom))
1471 CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf, last_sgf=last_sgf)
1473 CALL get_qs_env(qs_env, ks_env=ks_env, matrix_s=matrix_s, sab_orb=sab_orb, atomic_kind_set=atomic_kind_set)
1474 CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind)
1478 ALLOCATE (xtransformed(nspins))
1479 DO ispin = 1, nspins
1481 ct => work%ctransformed(ispin)
1483 CALL cp_fm_create(matrix=xtransformed(ispin), matrix_struct=fmstruct, name=
"XTRANSFORMED")
1487 ALLOCATE (tcharge(natom), gtcharge(natom, 4))
1489 cpmos => ex_env%cpmos
1491 DO ispin = 1, nspins
1492 ct => work%ctransformed(ispin)
1493 CALL cp_fm_get_info(ct, matrix_struct=fmstruct, nrow_global=nsgf)
1498 ALLOCATE (matrix_wx1(ispin)%matrix)
1499 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1501 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1502 ALLOCATE (matrix_plo(ispin)%matrix)
1503 CALL dbcsr_create(matrix=matrix_plo(ispin)%matrix, template=matrix_s(1)%matrix)
1505 CALL dbcsr_set(matrix_plo(ispin)%matrix, 0.0_dp)
1509 IF (do_coulomb)
THEN
1511 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1514 DO jspin = 1, nspins
1515 ctjspin => work%ctransformed(jspin)
1517 CALL cp_fm_get_info(ctjspin, matrix_struct=fmstructjspin, nrow_global=nsgf)
1526 DO is = first_sgf(ia), last_sgf(ia)
1527 tcharge(ia) = tcharge(ia) + tv(is)
1537 NULLIFY (gamma_matrix)
1538 CALL setup_gamma(qs_env, stda_env, sub_env, gamma_matrix, ndim=4)
1539 tempmat => gamma_matrix(1)%matrix
1543 gtcharge(iatom, 1) = gtcharge(iatom, 1) + gab(1, 1)*tcharge(jatom)
1544 IF (iatom /= jatom)
THEN
1545 gtcharge(jatom, 1) = gtcharge(jatom, 1) + gab(1, 1)*tcharge(iatom)
1550 row=iatom, col=jatom, block=gab, found=found)
1552 gtcharge(iatom, idimk) = gtcharge(iatom, idimk) + gab(1, 1)*tcharge(jatom)
1553 IF (iatom /= jatom)
THEN
1554 gtcharge(jatom, idimk) = gtcharge(jatom, idimk) + fdim*gab(1, 1)*tcharge(iatom)
1563 ewald_env => work%ewald_env
1564 ewald_pw => work%ewald_pw
1565 CALL ewald_env_get(ewald_env, alpha=alpha, ewald_type=ewald_type)
1566 CALL get_qs_env(qs_env=qs_env, sab_orb=n_list, virial=virial)
1567 use_virial = .false.
1568 calculate_forces = .false.
1569 CALL tb_ewald_overlap(gtcharge, tcharge, alpha, n_list, virial, use_virial)
1571 gtcharge, tcharge, calculate_forces, virial, use_virial)
1573 IF (para_env%is_source())
THEN
1574 gtcharge(:, 1) = gtcharge(:, 1) - 2._dp*alpha*
oorootpi*tcharge(:)
1577 nlim =
get_limit(natom, para_env%num_pe, para_env%mepos)
1578 DO iatom = nlim(1), nlim(2)
1579 DO jatom = 1, iatom - 1
1580 rij = particle_set(iatom)%r - particle_set(jatom)%r
1581 rij =
pbc(rij, cell)
1582 dr = sqrt(sum(rij(:)**2))
1583 IF (dr > 1.e-6_dp)
THEN
1584 gtcharge(iatom, 1) = gtcharge(iatom, 1) + tcharge(jatom)/dr
1585 gtcharge(jatom, 1) = gtcharge(jatom, 1) + tcharge(iatom)/dr
1587 gtcharge(iatom, idimk) = gtcharge(iatom, idimk) + rij(idimk - 1)*tcharge(jatom)/dr**3
1588 gtcharge(jatom, idimk) = gtcharge(jatom, idimk) - rij(idimk - 1)*tcharge(iatom)/dr**3
1594 CALL para_env%sum(gtcharge(:, 1))
1599 DO is = first_sgf(ia), last_sgf(ia)
1600 tv(is) = gtcharge(ia, 1)
1605 ikind = kind_of(iatom)
1606 atom_i = atom_of_kind(iatom)
1608 fij(i) = spinfac*spinfac*gtcharge(iatom, i + 1)*tcharge(iatom)
1610 force(ikind)%rho_elec(1, atom_i) = force(ikind)%rho_elec(1, atom_i) - fij(1)
1611 force(ikind)%rho_elec(2, atom_i) = force(ikind)%rho_elec(2, atom_i) - fij(2)
1612 force(ikind)%rho_elec(3, atom_i) = force(ikind)%rho_elec(3, atom_i) - fij(3)
1615 IF (debug_forces)
THEN
1616 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1617 CALL para_env%sum(fodeb)
1618 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Coul[X] ", fodeb
1620 norb = nactive(ispin)
1622 CALL cp_fm_get_info(work%S_C0_C0T(ispin), matrix_struct=fmstruct)
1623 CALL cp_fm_create(t0matrix, matrix_struct=fmstruct, name=
"T0 SCRATCH")
1624 CALL cp_fm_create(t1matrix, matrix_struct=fmstruct, name=
"T1 SCRATCH")
1629 ct => work%ctransformed(ispin)
1632 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1633 cvec, 0.0_dp, ucmatrix)
1634 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1635 x(ispin), 0.0_dp, uxmatrix)
1636 CALL parallel_gemm(
'N',
'T', nsgf, nsgf, norb, 1.0_dp, uxmatrix, ucmatrix, 0.0_dp, t0matrix)
1639 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1640 cvec, 0.0_dp, uxmatrix)
1641 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1642 gs_mos(ispin)%mos_occ, 0.0_dp, ucmatrix)
1643 CALL parallel_gemm(
'N',
'T', nsgf, nsgf, norb, 1.0_dp, ucmatrix, uxmatrix, 1.0_dp, t0matrix)
1646 CALL parallel_gemm(
'N',
'N', nsgf, nsgf, nsgf, spinfac, work%S_eigenvectors, t1matrix, &
1649 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1651 DEALLOCATE (ucmatrix)
1653 DEALLOCATE (uxmatrix)
1662 ct => work%ctransformed(ispin)
1666 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1670 ncol_global=norb, para_env=fmstruct%para_env)
1673 CALL parallel_gemm(
"T",
"N", norb, norb, nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1674 CALL parallel_gemm(
"N",
"N", nao, norb, norb, 1.0_dp, x(ispin), cvcmat, 0.0_dp, vcvec)
1676 nactive(ispin), alpha=-2.0_dp*spinfac, beta=1.0_dp)
1680 matrix_g=vcvec, ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1687 IF (stda_env%do_exchange)
THEN
1689 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1691 norb = nactive(ispin)
1693 tempmat => work%shalf
1694 CALL dbcsr_create(pdens, template=tempmat, matrix_type=dbcsr_type_no_symmetry)
1696 ct => work%ctransformed(ispin)
1699 1.0_dp, keep_sparsity=.false.)
1703 bp = stda_env%beta_param
1704 hfx = stda_env%hfx_fraction
1708 rij = particle_set(iatom)%r - particle_set(jatom)%r
1709 rij =
pbc(rij, cell)
1710 dr = sqrt(sum(rij(:)**2))
1711 ikind = kind_of(iatom)
1712 jkind = kind_of(jatom)
1713 eta = (stda_env%kind_param_set(ikind)%kind_param%hardness_param + &
1714 stda_env%kind_param_set(jkind)%kind_param%hardness_param)/2.0_dp
1716 IF (hfx > 0.0_dp)
THEN
1717 gabr = (1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp)
1719 IF (dr < 1.0e-6_dp)
THEN
1727 IF (dr > 1.0e-6_dp)
THEN
1728 IF (hfx > 0.0_dp)
THEN
1729 dgabr = -(1._dp/bp)*(1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp + 1._dp)
1730 dgabr = bp*rbeta/dr**2*dgabr
1731 dgabr = sum(pblock**2)*dgabr
1733 dgabr = -1.0_dp/dr**3
1734 dgabr = sum(pblock**2)*dgabr
1736 atom_i = atom_of_kind(iatom)
1737 atom_j = atom_of_kind(jatom)
1739 fij(i) = dgabr*rij(i)
1741 force(ikind)%rho_elec(1, atom_i) = force(ikind)%rho_elec(1, atom_i) - fij(1)
1742 force(ikind)%rho_elec(2, atom_i) = force(ikind)%rho_elec(2, atom_i) - fij(2)
1743 force(ikind)%rho_elec(3, atom_i) = force(ikind)%rho_elec(3, atom_i) - fij(3)
1744 force(jkind)%rho_elec(1, atom_j) = force(jkind)%rho_elec(1, atom_j) + fij(1)
1745 force(jkind)%rho_elec(2, atom_j) = force(jkind)%rho_elec(2, atom_j) + fij(2)
1746 force(jkind)%rho_elec(3, atom_j) = force(jkind)%rho_elec(3, atom_j) + fij(3)
1749 pblock = gabr*pblock
1758 CALL cp_fm_get_info(work%S_C0_C0T(ispin), matrix_struct=fmstruct)
1759 CALL cp_fm_create(t0matrix, matrix_struct=fmstruct, name=
"T0 SCRATCH")
1760 CALL cp_fm_create(t1matrix, matrix_struct=fmstruct, name=
"T1 SCRATCH")
1765 ct => work%ctransformed(ispin)
1767 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1768 cvec, 0.0_dp, ucmatrix)
1769 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1770 x(ispin), 0.0_dp, uxmatrix)
1771 CALL parallel_gemm(
'N',
'T', nsgf, nsgf, norb, 1.0_dp, uxmatrix, ucmatrix, 0.0_dp, t0matrix)
1773 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1774 cvec, 0.0_dp, uxmatrix)
1775 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1776 gs_mos(ispin)%mos_occ, 0.0_dp, ucmatrix)
1777 CALL parallel_gemm(
'N',
'T', nsgf, nsgf, norb, 1.0_dp, ucmatrix, uxmatrix, 1.0_dp, t0matrix)
1779 CALL parallel_gemm(
'N',
'N', nsgf, nsgf, nsgf, -1.0_dp, work%S_eigenvectors, t1matrix, &
1782 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1784 DEALLOCATE (ucmatrix)
1786 DEALLOCATE (uxmatrix)
1794 alpha=-xfac, beta=1.0_dp)
1796 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1802 ncol_global=norb, para_env=fmstruct%para_env)
1805 CALL parallel_gemm(
"T",
"N", norb, norb, nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1806 CALL parallel_gemm(
"N",
"N", nao, norb, norb, 1.0_dp, x(ispin), cvcmat, 0.0_dp, vcvec)
1808 norb, alpha=xfac, beta=1.0_dp)
1810 IF (nspins == 2)
THEN
1817 ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1824 IF (debug_forces)
THEN
1825 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1826 CALL para_env%sum(fodeb)
1827 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Exch[X] ", fodeb
1837 DEALLOCATE (tcharge, gtcharge)
1838 DEALLOCATE (first_sgf, last_sgf)
1841 IF (nspins == 2)
THEN
1842 CALL dbcsr_add(matrix_plo(1)%matrix, matrix_plo(2)%matrix, &
1843 alpha_scalar=1.0_dp, beta_scalar=1.0_dp)
1847 IF (debug_forces) fodeb(1:3) = force(1)%overlap(1:3, 1)
1849 matrix_name=
"OVERLAP MATRIX", &
1850 basis_type_a=
"ORB", basis_type_b=
"ORB", &
1851 sab_nl=sab_orb, calculate_forces=.true., &
1852 matrix_p=matrix_plo(1)%matrix)
1855 IF (debug_forces)
THEN
1856 fodeb(1:3) = force(1)%overlap(1:3, 1) - fodeb(1:3)
1857 CALL para_env%sum(fodeb)
1858 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Lowdin ", fodeb
1862 ex_env%matrix_wx1 => matrix_wx1
1864 CALL timestop(handle)