167 SUBROUTINE fhxc_force(qs_env, ex_env, gs_mos, full_kernel, debug_forces)
174 LOGICAL,
INTENT(IN) :: debug_forces
176 CHARACTER(LEN=*),
PARAMETER :: routinen =
'fhxc_force'
178 CHARACTER(LEN=default_string_length) :: basis_type
179 INTEGER :: handle, ia, ib, iounit, ispin, mspin, &
180 myfun, n_rep_hf, nactive(2), nao, &
181 nao_aux, natom, nkind, norb(2), nsev, &
183 LOGICAL :: distribute_fock_matrix, do_admm,
do_analytic, do_hfx, do_hfxlr, do_hfxsr, &
184 do_numeric, do_res, do_sf, gapw, gapw_xc, hfx_treat_lsd_in_core, is_rks_triplets, &
185 s_mstruct_changed, use_virial
186 REAL(kind=
dp) :: eh1, eh1c, eps_delta, eps_fit, focc, &
187 fscal, fval, kval, xehartree
188 REAL(kind=
dp),
DIMENSION(3) :: fodeb
192 TYPE(
cp_fm_type) :: avamat, avcmat, cpscr, cvcmat, vavec, &
194 TYPE(
cp_fm_type),
DIMENSION(:),
POINTER :: cpmos, evect
195 TYPE(
cp_fm_type),
POINTER :: mos, mos2, mosa, mosa2
197 TYPE(
dbcsr_p_type),
DIMENSION(:),
POINTER :: matrix_fx, matrix_gx, matrix_hfx, &
198 matrix_hfx_admm, matrix_hfx_admm_asymm, matrix_hfx_asymm, matrix_hx, matrix_p, &
199 matrix_p_admm, matrix_px1, matrix_px1_admm, matrix_px1_admm_asymm, matrix_px1_asymm, &
200 matrix_s, matrix_s_aux_fit, matrix_wx1, mdum, mfx, mgx
201 TYPE(
dbcsr_p_type),
DIMENSION(:, :),
POINTER :: mhe, mpe, mpga
202 TYPE(
dbcsr_type),
POINTER :: dbwork, dbwork_asymm
205 TYPE(
hfx_type),
DIMENSION(:, :),
POINTER :: x_data
206 TYPE(
local_rho_type),
POINTER :: local_rho_set, local_rho_set_admm, local_rho_set_f, &
207 local_rho_set_f_admm, local_rho_set_g, local_rho_set_g_admm
210 POINTER :: sab, sab_aux_fit, sab_orb, sap_oce
214 TYPE(
pw_c1d_gs_type),
DIMENSION(:),
POINTER :: rho_g_aux, rhox_g, rhox_g_aux, rhoxx_g
219 TYPE(
pw_r3d_rs_type),
DIMENSION(:),
POINTER :: fxc_rho, fxc_tau, gxc_rho, gxc_tau, &
220 rho_r_aux, rhox_r, rhox_r_aux, rhoxx_r
222 TYPE(
qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
224 TYPE(
qs_rho_type),
POINTER :: rho, rho_aux_fit, rhox, rhox_aux
225 TYPE(
rho_atom_type),
DIMENSION(:),
POINTER :: rho_atom_set, rho_atom_set_f, &
231 CALL timeset(routinen, handle)
234 IF (logger%para_env%is_source())
THEN
240 CALL get_qs_env(qs_env, dft_control=dft_control)
241 tddfpt_control => dft_control%tddfpt2_control
242 nspins = dft_control%nspins
243 is_rks_triplets = tddfpt_control%rks_triplets .AND. (nspins == 1)
250 do_hfx = tddfpt_control%do_hfx
251 do_hfxsr = tddfpt_control%do_hfxsr
252 do_hfxlr = tddfpt_control%do_hfxlr
253 do_admm = tddfpt_control%do_admm
254 gapw = dft_control%qs_control%gapw
255 gapw_xc = dft_control%qs_control%gapw_xc
257 evect => ex_env%evect
258 matrix_px1 => ex_env%matrix_px1
259 matrix_px1_admm => ex_env%matrix_px1_admm
260 matrix_px1_asymm => ex_env%matrix_px1_asymm
261 matrix_px1_admm_asymm => ex_env%matrix_px1_admm_asymm
264 IF (nspins == 2) focc = 0.5_dp
265 nsev =
SIZE(evect, 1)
269 CALL dbcsr_set(matrix_px1(ispin)%matrix, 0.0_dp)
271 matrix_v=evect(ispin), &
272 matrix_g=gs_mos(ispin)%mos_active, &
273 ncol=nactive(ispin), alpha=2.0_dp*focc, symmetry_mode=1)
276 CALL dbcsr_set(matrix_px1_asymm(ispin)%matrix, 0.0_dp)
278 matrix_v=gs_mos(ispin)%mos_active, &
279 matrix_g=evect(ispin), &
280 ncol=nactive(ispin), alpha=2.0_dp*focc, &
284 CALL get_qs_env(qs_env, ks_env=ks_env, pw_env=pw_env, para_env=para_env)
286 NULLIFY (hartree_local, local_rho_set, local_rho_set_admm)
287 IF (gapw .OR. gapw_xc)
THEN
288 IF (nspins == 2)
THEN
294 atomic_kind_set=atomic_kind_set, &
295 qs_kind_set=qs_kind_set)
298 qs_kind_set, dft_control, para_env)
301 CALL init_rho0(local_rho_set, qs_env, dft_control%qs_control%gapw_control, &
308 CALL get_qs_env(qs_env=qs_env, oce=oce, sap_oce=sap_oce, sab_orb=sab)
310 CALL get_qs_env(qs_env=qs_env, nkind=nkind, particle_set=particle_set)
312 eps_fit = dft_control%qs_control%gapw_control%eps_fit
317 mpga(1:nsev, 1:1) => matrix_px1(1:nsev)
319 qs_kind_set, oce, sab, para_env)
324 qs_kind_set, dft_control, para_env)
326 qs_kind_set, oce, sab, para_env)
331 qs_kind_set, dft_control, para_env)
333 qs_kind_set, oce, sab, para_env)
335 IF (nspins == 2)
THEN
344 nao_aux = admm_env%nao_aux_fit
345 nao = admm_env%nao_orb
351 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
352 admm_env%work_aux_orb)
354 1.0_dp, admm_env%work_aux_orb, admm_env%A, 0.0_dp, &
355 admm_env%work_aux_aux)
356 CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_px1_admm(ispin)%matrix, &
357 keep_sparsity=.true.)
359 CALL copy_dbcsr_to_fm(matrix_px1_asymm(ispin)%matrix, admm_env%work_orb_orb)
361 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
362 admm_env%work_aux_orb)
364 1.0_dp, admm_env%work_aux_orb, admm_env%A, 0.0_dp, &
365 admm_env%work_aux_aux)
366 CALL copy_fm_to_dbcsr(admm_env%work_aux_aux, matrix_px1_admm_asymm(ispin)%matrix, &
367 keep_sparsity=.true.)
370 IF (admm_env%do_gapw)
THEN
371 IF (do_admm .AND. tddfpt_control%admm_xc_correction)
THEN
375 CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set)
378 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
379 mpga(1:nsev, 1:1) => matrix_px1_admm(1:nsev)
382 admm_env%admm_gapw_env%admm_kind_set, &
383 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
385 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
389 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
391 admm_env%admm_gapw_env%admm_kind_set, &
392 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
394 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
398 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
400 admm_env%admm_gapw_env%admm_kind_set, &
401 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
403 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
409 CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, &
410 poisson_env=poisson_env)
412 ALLOCATE (rhox_r(nsev), rhox_g(nsev))
413 DO ispin = 1,
SIZE(evect, 1)
414 CALL auxbas_pw_pool%create_pw(rhox_r(ispin))
415 CALL auxbas_pw_pool%create_pw(rhox_g(ispin))
417 CALL auxbas_pw_pool%create_pw(rhox_tot_gspace)
422 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
424 rho=rhox_r(ispin), rho_gspace=rhox_g(ispin), &
427 CALL pw_axpy(rhox_g(ispin), rhox_tot_gspace)
429 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
433 ALLOCATE (rhoxx_r(nsev), rhoxx_g(nsev))
435 CALL auxbas_pw_pool%create_pw(rhoxx_r(ispin))
436 CALL auxbas_pw_pool%create_pw(rhoxx_g(ispin))
439 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
441 rho=rhoxx_r(ispin), rho_gspace=rhoxx_g(ispin), &
443 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
447 CALL get_qs_env(qs_env, matrix_s=matrix_s, force=force)
449 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
450 CALL auxbas_pw_pool%create_pw(xv_hartree_rspace)
451 CALL auxbas_pw_pool%create_pw(xv_hartree_gspace)
454 CALL pw_axpy(local_rho_set%rho0_mpole%rho0_s_gs, rhox_tot_gspace)
455 IF (
ASSOCIATED(local_rho_set%rho0_mpole%rhoz_cneo_s_gs))
THEN
456 CALL pw_axpy(local_rho_set%rho0_mpole%rhoz_cneo_s_gs, rhox_tot_gspace)
461 CALL pw_transfer(xv_hartree_gspace, xv_hartree_rspace)
462 CALL pw_scale(xv_hartree_rspace, xv_hartree_rspace%pw_grid%dvol)
464 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
468 ALLOCATE (matrix_hx(ispin)%matrix)
469 CALL dbcsr_create(matrix_hx(ispin)%matrix, template=matrix_s(1)%matrix)
470 CALL dbcsr_copy(matrix_hx(ispin)%matrix, matrix_s(1)%matrix)
471 CALL dbcsr_set(matrix_hx(ispin)%matrix, 0.0_dp)
472 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=xv_hartree_rspace, &
473 pmat=matrix_px1(ispin), hmat=matrix_hx(ispin), &
474 gapw=gapw, calculate_forces=.true.)
476 IF (debug_forces)
THEN
477 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
478 CALL para_env%sum(fodeb)
479 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dKh[Dx] ", fodeb
482 IF (debug_forces) fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1)
483 CALL vh_1c_gg_integrals(qs_env, eh1c, hartree_local%ecoul_1c, local_rho_set, para_env, tddft=.true., &
485 IF (nspins == 1)
THEN
491 local_rho_set=local_rho_set, kforce=kval)
492 IF (debug_forces)
THEN
493 fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1) - fodeb(1:3)
494 CALL para_env%sum(fodeb)
495 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dKh[Dx]PAWg0", fodeb
497 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
498 CALL update_ks_atom(qs_env, matrix_hx, matrix_px1, forces=.true., &
499 rho_atom_external=local_rho_set%rho_atom_set)
500 IF (debug_forces)
THEN
501 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
502 CALL para_env%sum(fodeb)
503 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dKh[Dx]PAW", fodeb
509 IF (full_kernel%do_exck)
THEN
512 NULLIFY (fxc_rho, fxc_tau, gxc_rho, gxc_tau)
513 xc_section => full_kernel%xc_section
517 SELECT CASE (ex_env%xc_kernel_method)
528 cpabort(
"invalid xc_kernel_method")
530 order = ex_env%diff_order
531 eps_delta = ex_env%eps_delta_rho
534 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho_xc=rho)
536 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho=rho)
545 CALL qs_rho_set(rho_struct=rhox, rho_ao=matrix_px1, rho_r=rhoxx_r, rho_g=rhoxx_g, &
546 rho_r_valid=.true., rho_g_valid=.true.)
548 CALL qs_rho_set(rho_struct=rhox, rho_ao=matrix_px1, rho_r=rhox_r, rho_g=rhox_g, &
549 rho_r_valid=.true., rho_g_valid=.true.)
554 IF (.NOT. do_sf)
THEN
555 cpabort(
"Analytic 3rd EXC derivatives not available")
558 fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
562 CALL qs_fgxc_gdiff(ks_env, rho, rhox, xc_section, order, eps_delta, is_rks_triplets, &
563 fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
565 CALL qs_fgxc_create(ks_env, rho, rhox, xc_section, order, is_rks_triplets, &
566 fxc_rho, fxc_tau, gxc_rho, gxc_tau)
569 cpabort(
"FHXC forces analytic/numeric")
578 IF (nspins == 2)
THEN
580 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
581 IF (
ASSOCIATED(gxc_tau))
CALL pw_scale(gxc_tau(ispin), 0.5_dp)
584 IF (gapw .OR. gapw_xc)
THEN
586 cpabort(
"Analytic 3rd EXC derivatives not available")
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, eps_delta)
594 local_rho_set_f%rho_atom_set, local_rho_set_g%rho_atom_set, &
595 qs_kind_set, xc_section, is_rks_triplets, order)
598 cpabort(
"FHXC forces analytic/numeric")
602 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
605 DO ispin = 1,
SIZE(fxc_rho, 1)
606 ALLOCATE (matrix_fx(ispin)%matrix)
607 CALL dbcsr_create(matrix_fx(ispin)%matrix, template=matrix_s(1)%matrix)
608 CALL dbcsr_copy(matrix_fx(ispin)%matrix, matrix_s(1)%matrix)
609 CALL dbcsr_set(matrix_fx(ispin)%matrix, 0.0_dp)
610 CALL pw_scale(fxc_rho(ispin), fxc_rho(ispin)%pw_grid%dvol)
613 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=fxc_rho(ispin), &
614 pmat=matrix_px1(ispin), hmat=matrix_fx(ispin), &
615 gapw=(gapw .OR. gapw_xc), calculate_forces=.true.)
617 IF (debug_forces)
THEN
618 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
619 CALL para_env%sum(fodeb)
620 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dfxc[Dx] ", fodeb
623 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
629 ALLOCATE (matrix_gx(ispin)%matrix)
630 CALL dbcsr_create(matrix_gx(ispin)%matrix, template=matrix_s(1)%matrix)
631 CALL dbcsr_copy(matrix_gx(ispin)%matrix, matrix_s(1)%matrix)
632 CALL dbcsr_set(matrix_gx(ispin)%matrix, 0.0_dp)
633 CALL pw_scale(gxc_rho(ispin), gxc_rho(ispin)%pw_grid%dvol)
634 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
635 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=gxc_rho(ispin), &
636 pmat=matrix_p(ispin), hmat=matrix_gx(ispin), &
637 gapw=(gapw .OR. gapw_xc), calculate_forces=.true.)
640 IF (debug_forces)
THEN
641 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
642 CALL para_env%sum(fodeb)
643 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dgxc[Dx]", fodeb
647 IF (gapw .OR. gapw_xc)
THEN
648 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
649 CALL update_ks_atom(qs_env, matrix_fx, matrix_px1, forces=.true., tddft=.true., &
650 rho_atom_external=local_rho_set_f%rho_atom_set, &
651 kintegral=1.0_dp, kforce=1.0_dp)
652 IF (debug_forces)
THEN
653 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
654 CALL para_env%sum(fodeb)
655 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dfxc[Dx]PAW ", fodeb
657 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
658 IF (nspins == 1)
THEN
659 CALL update_ks_atom(qs_env, matrix_gx, matrix_p, forces=.true., tddft=.true., &
660 rho_atom_external=local_rho_set_g%rho_atom_set, &
664 rho_atom_external=local_rho_set_g%rho_atom_set, &
665 kintegral=0.5_dp, kforce=0.25_dp)
667 IF (debug_forces)
THEN
668 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
669 CALL para_env%sum(fodeb)
670 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dgxc[Dx]PAW ", fodeb
676 IF (do_admm .AND. tddfpt_control%admm_xc_correction .AND. (tddfpt_control%spinflip /=
tddfpt_sf_col))
THEN
680 IF (.NOT. tddfpt_control%admm_symm)
THEN
681 CALL cp_warn(__location__,
"Forces need symmetric ADMM kernel corrections")
682 cpabort(
"ADMM KERNEL CORRECTION")
684 xc_section => admm_env%xc_section_aux
685 CALL get_admm_env(admm_env, rho_aux_fit=rho_aux_fit, matrix_s_aux_fit=matrix_s_aux_fit, &
686 task_list_aux_fit=task_list)
687 basis_type =
"AUX_FIT"
688 IF (admm_env%do_gapw)
THEN
689 basis_type =
"AUX_FIT_SOFT"
690 task_list => admm_env%admm_gapw_env%task_list
697 ALLOCATE (mfx(ispin)%matrix)
698 CALL dbcsr_create(mfx(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
699 CALL dbcsr_copy(mfx(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
700 CALL dbcsr_set(mfx(ispin)%matrix, 0.0_dp)
703 ALLOCATE (mgx(ispin)%matrix)
704 CALL dbcsr_create(mgx(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
705 CALL dbcsr_copy(mgx(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
706 CALL dbcsr_set(mgx(ispin)%matrix, 0.0_dp)
710 NULLIFY (rho_g_aux, rho_r_aux, rhox_g_aux, rhox_r_aux)
711 CALL qs_rho_get(rho_aux_fit, rho_r=rho_r_aux, rho_g=rho_g_aux)
712 CALL qs_rho_get(rho_aux_fit, rho_ao=matrix_p_admm)
714 ALLOCATE (rhox_r_aux(nsev), rhox_g_aux(nsev))
716 CALL auxbas_pw_pool%create_pw(rhox_r_aux(ispin))
717 CALL auxbas_pw_pool%create_pw(rhox_g_aux(ispin))
721 rho=rhox_r_aux(ispin), rho_gspace=rhox_g_aux(ispin), &
722 basis_type=basis_type, &
723 task_list_external=task_list)
729 CALL qs_rho_set(rho_struct=rhox_aux, rho_ao=matrix_px1_admm, &
730 rho_r=rhox_r_aux, rho_g=rhox_g_aux, &
731 rho_r_valid=.true., rho_g_valid=.true.)
733 cpabort(
"Analytic 3rd derivatives of EXC not available")
736 CALL qs_fgxc_gdiff(ks_env, rho_aux_fit, rhox_aux, xc_section, order, eps_delta, &
737 is_rks_triplets, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
740 order, is_rks_triplets, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
743 cpabort(
"FHXC forces analytic/numeric")
750 DEALLOCATE (rhox_aux)
753 CALL auxbas_pw_pool%give_back_pw(rhox_r_aux(ispin))
754 CALL auxbas_pw_pool%give_back_pw(rhox_g_aux(ispin))
756 DEALLOCATE (rhox_r_aux, rhox_g_aux)
758 IF (nspins == 2) fscal = 2.0_dp
760 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
762 CALL pw_scale(fxc_rho(ispin), fxc_rho(ispin)%pw_grid%dvol)
763 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=fxc_rho(ispin), &
765 pmat=matrix_px1_admm(ispin), &
766 basis_type=basis_type, &
767 calculate_forces=.true., &
769 task_list_external=task_list)
771 IF (debug_forces)
THEN
772 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
773 CALL para_env%sum(fodeb)
774 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dfxc[Dx]ADMM", fodeb
777 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
779 CALL pw_scale(gxc_rho(ispin), gxc_rho(ispin)%pw_grid%dvol)
780 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
781 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=gxc_rho(ispin), &
783 pmat=matrix_p_admm(ispin), &
784 basis_type=basis_type, &
785 calculate_forces=.true., &
787 task_list_external=task_list)
790 IF (debug_forces)
THEN
791 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
792 CALL para_env%sum(fodeb)
793 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dgxc[Dx]ADMM", fodeb
797 IF (admm_env%do_gapw)
THEN
799 rho_atom_set => admm_env%admm_gapw_env%local_rho_set%rho_atom_set
800 rho_atom_set_f => local_rho_set_f_admm%rho_atom_set
801 rho_atom_set_g => local_rho_set_g_admm%rho_atom_set
804 cpabort(
"Analytic 3rd EXC derivatives not available")
808 rho_atom_set_f, rho_atom_set_g, &
809 admm_env%admm_gapw_env%admm_kind_set, xc_section, &
810 is_rks_triplets, order, eps_delta)
813 rho_atom_set_f, rho_atom_set_g, &
814 admm_env%admm_gapw_env%admm_kind_set, xc_section, &
815 is_rks_triplets, order)
818 cpabort(
"FHXC forces analytic/numeric")
821 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
822 IF (nspins == 1)
THEN
823 CALL update_ks_atom(qs_env, mfx, matrix_px1_admm, forces=.true., &
824 rho_atom_external=rho_atom_set_f, &
825 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
826 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
827 kintegral=2.0_dp, kforce=0.5_dp)
829 CALL update_ks_atom(qs_env, mfx, matrix_px1_admm, forces=.true., &
830 rho_atom_external=rho_atom_set_f, &
831 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
832 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
833 kintegral=2.0_dp, kforce=1.0_dp)
835 IF (debug_forces)
THEN
836 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
837 CALL para_env%sum(fodeb)
838 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dfxc[Dx]ADMM-PAW ", fodeb
840 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
841 IF (nspins == 1)
THEN
843 rho_atom_external=rho_atom_set_g, &
844 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
845 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
846 kintegral=1.0_dp, kforce=0.5_dp)
849 rho_atom_external=rho_atom_set_g, &
850 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
851 oce_external=admm_env%admm_gapw_env%oce, sab_external=sab_aux_fit, &
852 kintegral=1.0_dp, kforce=1.0_dp)
854 IF (debug_forces)
THEN
855 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
856 CALL para_env%sum(fodeb)
857 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dgxc[Dx]ADMM-PAW ", fodeb
863 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
864 fval = 2.0_dp*real(nspins, kind=
dp)
866 IF (debug_forces)
THEN
867 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
868 CALL para_env%sum(fodeb)
869 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: P*dfXC(P)*S' ", fodeb
871 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
872 fval = 2.0_dp*real(nspins, kind=
dp)
874 IF (debug_forces)
THEN
875 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
876 CALL para_env%sum(fodeb)
877 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: P*dgXC(P)*S' ", fodeb
882 IF (nspins == 2) fscal = 2.0_dp
883 nao = admm_env%nao_orb
884 nao_aux = admm_env%nao_aux_fit
890 admm_env%work_aux_orb, nao)
892 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
893 admm_env%work_orb_orb)
897 CALL dbcsr_add(matrix_fx(ispin)%matrix, dbwork, 1.0_dp, fscal)
900 admm_env%work_aux_orb, nao)
902 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
903 admm_env%work_orb_orb)
906 CALL dbcsr_add(matrix_gx(ispin)%matrix, dbwork, 1.0_dp, fscal)
917 CALL auxbas_pw_pool%give_back_pw(rhox_r(ispin))
918 CALL auxbas_pw_pool%give_back_pw(rhox_g(ispin))
920 DEALLOCATE (rhox_r, rhox_g)
921 CALL auxbas_pw_pool%give_back_pw(rhox_tot_gspace)
924 CALL auxbas_pw_pool%give_back_pw(rhoxx_r(ispin))
925 CALL auxbas_pw_pool%give_back_pw(rhoxx_g(ispin))
927 DEALLOCATE (rhoxx_r, rhoxx_g)
929 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
930 CALL auxbas_pw_pool%give_back_pw(xv_hartree_rspace)
931 CALL auxbas_pw_pool%give_back_pw(xv_hartree_gspace)
936 NULLIFY (matrix_hfx, matrix_hfx_asymm)
940 ALLOCATE (matrix_hfx(ispin)%matrix)
941 CALL dbcsr_create(matrix_hfx(ispin)%matrix, template=matrix_s(1)%matrix)
942 CALL dbcsr_copy(matrix_hfx(ispin)%matrix, matrix_s(1)%matrix)
943 CALL dbcsr_set(matrix_hfx(ispin)%matrix, 0.0_dp)
945 ALLOCATE (matrix_hfx_asymm(ispin)%matrix)
946 CALL dbcsr_create(matrix_hfx_asymm(ispin)%matrix, template=matrix_s(1)%matrix, &
947 matrix_type=dbcsr_type_antisymmetric)
951 xc_section => full_kernel%xc_section
954 cpassert(n_rep_hf == 1)
958 IF (hfx_treat_lsd_in_core) mspin = nsev
960 CALL get_qs_env(qs_env=qs_env, x_data=x_data, s_mstruct_changed=s_mstruct_changed)
961 distribute_fock_matrix = .true.
964 CALL get_admm_env(qs_env%admm_env, matrix_s_aux_fit=matrix_s_aux_fit)
965 NULLIFY (matrix_hfx_admm, matrix_hfx_admm_asymm)
969 ALLOCATE (matrix_hfx_admm(ispin)%matrix)
970 CALL dbcsr_create(matrix_hfx_admm(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix)
971 CALL dbcsr_copy(matrix_hfx_admm(ispin)%matrix, matrix_s_aux_fit(1)%matrix)
972 CALL dbcsr_set(matrix_hfx_admm(ispin)%matrix, 0.0_dp)
974 ALLOCATE (matrix_hfx_admm_asymm(ispin)%matrix)
975 CALL dbcsr_create(matrix_hfx_admm_asymm(ispin)%matrix, template=matrix_s_aux_fit(1)%matrix, &
976 matrix_type=dbcsr_type_antisymmetric)
981 ALLOCATE (mpe(nsev, 1), mhe(nsev, 1))
983 mhe(ispin, 1)%matrix => matrix_hfx_admm(ispin)%matrix
984 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
986 IF (x_data(1, 1)%do_hfx_ri)
THEN
989 geometry_did_change=s_mstruct_changed, nspins=nspins, &
990 hf_fraction=x_data(1, 1)%general_parameter%fraction)
995 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
996 ispin=ispin, nspins=nsev)
1001 mhe(ispin, 1)%matrix => matrix_hfx_admm_asymm(ispin)%matrix
1002 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1004 IF (x_data(1, 1)%do_hfx_ri)
THEN
1006 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1007 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1008 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1013 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1014 ispin=ispin, nspins=nsev)
1018 nao = admm_env%nao_orb
1019 nao_aux = admm_env%nao_aux_fit
1020 ALLOCATE (dbwork, dbwork_asymm)
1021 CALL dbcsr_create(dbwork, template=matrix_hfx(1)%matrix)
1022 CALL dbcsr_create(dbwork_asymm, template=matrix_hfx(1)%matrix, matrix_type=dbcsr_type_antisymmetric)
1025 admm_env%work_aux_orb, nao)
1027 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
1028 admm_env%work_orb_orb)
1029 CALL dbcsr_copy(dbwork, matrix_hfx(1)%matrix)
1032 CALL dbcsr_add(matrix_hfx(ispin)%matrix, dbwork, 1.0_dp, 1.0_dp)
1035 admm_env%work_aux_orb, nao)
1037 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
1038 admm_env%work_orb_orb)
1039 CALL dbcsr_copy(dbwork_asymm, matrix_hfx_asymm(1)%matrix)
1041 CALL copy_fm_to_dbcsr(admm_env%work_orb_orb, dbwork_asymm, keep_sparsity=.true.)
1042 CALL dbcsr_add(matrix_hfx_asymm(ispin)%matrix, dbwork_asymm, 1.0_dp, 1.0_dp)
1046 DEALLOCATE (dbwork, dbwork_asymm)
1049 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
1050 fval = 4.0_dp*real(nspins, kind=
dp)*0.5_dp
1053 IF (debug_forces)
THEN
1054 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
1055 CALL para_env%sum(fodeb)
1056 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: P*Hx(P)*S' ", fodeb
1059 use_virial = .false.
1061 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1063 IF (do_sf) fval = fval*2.0_dp
1064 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1066 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
1068 IF (x_data(1, 1)%do_hfx_ri)
THEN
1070 x_data(1, 1)%general_parameter%fraction, &
1071 rho_ao=mpe, rho_ao_resp=mdum, &
1072 use_virial=use_virial, rescale_factor=fval)
1075 adiabatic_rescale_factor=fval, nspins=nsev)
1078 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1080 IF (x_data(1, 1)%do_hfx_ri)
THEN
1082 x_data(1, 1)%general_parameter%fraction, &
1083 rho_ao=mpe, rho_ao_resp=mdum, &
1084 use_virial=use_virial, rescale_factor=fval)
1087 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
1089 IF (debug_forces)
THEN
1090 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
1091 CALL para_env%sum(fodeb)
1092 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dhfx'*Dx ", fodeb
1095 DEALLOCATE (mpe, mhe)
1101 ALLOCATE (mpe(nsev, 1), mhe(nsev, 1))
1103 mhe(ispin, 1)%matrix => matrix_hfx(ispin)%matrix
1104 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1106 IF (x_data(1, 1)%do_hfx_ri)
THEN
1108 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1109 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1110 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1115 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1116 ispin=ispin, nspins=
SIZE(mpe, 1))
1122 mhe(ispin, 1)%matrix => matrix_hfx_asymm(ispin)%matrix
1123 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1125 IF (x_data(1, 1)%do_hfx_ri)
THEN
1127 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhe, eh1, rho_ao=mpe, &
1128 geometry_did_change=s_mstruct_changed, nspins=nspins, &
1129 hf_fraction=x_data(1, 1)%general_parameter%fraction)
1134 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1135 ispin=ispin, nspins=
SIZE(mpe, 1))
1139 use_virial = .false.
1141 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1143 IF (do_sf) fval = fval*2.0_dp
1144 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1146 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1148 IF (x_data(1, 1)%do_hfx_ri)
THEN
1150 x_data(1, 1)%general_parameter%fraction, &
1151 rho_ao=mpe, rho_ao_resp=mdum, &
1152 use_virial=use_virial, rescale_factor=fval)
1155 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
1158 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1160 IF (x_data(1, 1)%do_hfx_ri)
THEN
1162 x_data(1, 1)%general_parameter%fraction, &
1163 rho_ao=mpe, rho_ao_resp=mdum, &
1164 use_virial=use_virial, rescale_factor=fval)
1167 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
1169 IF (debug_forces)
THEN
1170 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
1171 CALL para_env%sum(fodeb)
1172 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Dx*dhfx*Dx ", fodeb
1175 DEALLOCATE (mpe, mhe)
1177 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1179 IF (do_sf) fval = fval*2.0_dp
1182 CALL dbcsr_scale(matrix_hfx_asymm(ispin)%matrix, fval)
1186 IF (gapw .OR. gapw_xc)
THEN
1195 IF (admm_env%do_gapw)
THEN
1196 IF (tddfpt_control%admm_xc_correction)
THEN
1208 cpabort(
"HFXSR not implemented")
1212 cpabort(
"HFXLR not implemented")
1216 NULLIFY (matrix_wx1)
1218 cpmos => ex_env%cpmos
1220 IF (nspins == 2) focc = 1.0_dp
1225 mos => gs_mos(1)%mos_occ
1226 mosa => gs_mos(1)%mos_active
1227 norb(1) = gs_mos(1)%nmo_occ
1228 nactive(1) = gs_mos(1)%nmo_active
1229 IF (nspins == 2)
THEN
1230 mos2 => gs_mos(2)%mos_occ
1231 mosa2 => gs_mos(2)%mos_active
1232 norb(2) = gs_mos(2)%nmo_occ
1233 nactive(2) = gs_mos(2)%nmo_active
1236 DO ispin = 1, nspins
1238 IF (nactive(ispin) == norb(ispin))
THEN
1240 DO ia = 1, nactive(ispin)
1241 cpassert(ia == gs_mos(ispin)%index_active(ia))
1248 IF (.NOT. do_sf)
THEN
1250 mos => gs_mos(ispin)%mos_occ
1251 mos2 => gs_mos(ispin)%mos_occ
1252 mosa => gs_mos(ispin)%mos_active
1253 mosa2 => gs_mos(ispin)%mos_active
1257 CALL cp_fm_create(cpscr, gs_mos(ispin)%mos_active%matrix_struct,
"cpscr", set_zero=.true.)
1259 CALL cp_fm_get_info(gs_mos(ispin)%mos_occ, matrix_struct=fm_struct, nrow_global=nao)
1261 CALL cp_fm_create(avamat, fm_struct, nrow=nactive(spin), ncol=nactive(spin))
1262 CALL cp_fm_create(avcmat, fm_struct, nrow=nactive(spin), ncol=norb(spin))
1263 CALL cp_fm_create(cvcmat, fm_struct, nrow=norb(spin), ncol=norb(spin))
1265 CALL cp_fm_create(vcvec, gs_mos(ispin)%mos_occ%matrix_struct,
"vcvec")
1266 CALL cp_fm_create(vavec, gs_mos(ispin)%mos_active%matrix_struct,
"vavec")
1269 ALLOCATE (matrix_wx1(ispin)%matrix)
1270 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1272 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1275 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
1277 cpscr, nactive(ispin), alpha=focc, beta=1.0_dp)
1279 alpha=1.0_dp, beta=0.0_dp)
1280 CALL parallel_gemm(
"T",
"N", nactive(ispin), norb(ispin), nao, 1.0_dp, &
1281 mosa, vcvec, 0.0_dp, avcmat)
1282 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), nactive(ispin), 1.0_dp, &
1283 evect(ispin), avcmat, 0.0_dp, vcvec)
1287 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1294 IF (.NOT. (do_sf .AND. (ispin == 2)))
THEN
1297 cpscr, nactive(ispin), alpha=focc, beta=1.0_dp)
1300 IF (.NOT. (do_sf .AND. (ispin == 1)))
THEN
1303 norb(ispin), alpha=1.0_dp, beta=0.0_dp)
1305 CALL parallel_gemm(
"T",
"N", nactive(spin), norb(ispin), nao, 1.0_dp, &
1306 mosa, vcvec, 0.0_dp, avcmat)
1308 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), nactive(spin), 1.0_dp, &
1309 evect(spin), avcmat, 0.0_dp, vcvec)
1312 norb(ispin), alpha=-focc, beta=1.0_dp)
1315 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=gs_mos(ispin)%mos_occ, &
1316 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1323 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1327 alpha=1.0_dp, beta=0.0_dp)
1329 CALL parallel_gemm(
"T",
"N", norb(ispin), norb(ispin), nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1331 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), norb(ispin), 1.0_dp, gs_mos(ispin)%mos_occ, cvcmat, 0.0_dp, vcvec)
1333 CALL cp_dbcsr_plus_fm_fm_t(matrix_wx1(ispin)%matrix, matrix_v=vcvec, matrix_g=gs_mos(ispin)%mos_occ, &
1334 ncol=norb(ispin), alpha=1.0_dp, symmetry_mode=1)
1340 IF (.NOT. (do_sf .AND. (ispin == 2)))
THEN
1343 cpscr, nactive(spin), alpha=focc, beta=1.0_dp)
1346 cpscr, nactive(spin), alpha=focc, beta=1.0_dp)
1350 IF (.NOT. (do_sf .AND. (ispin == 1)))
THEN
1353 alpha=1.0_dp, beta=0.0_dp)
1356 alpha=1.0_dp, beta=1.0_dp)
1358 CALL parallel_gemm(
"T",
"N", nactive(spin), norb(ispin), nao, 1.0_dp, &
1359 mosa, vcvec, 0.0_dp, avcmat)
1361 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), nactive(spin), 1.0_dp, &
1362 evect(spin), avcmat, 0.0_dp, vcvec)
1365 norb(ispin), alpha=-focc, beta=1.0_dp)
1369 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1374 DO ia = 1, nactive(ispin)
1375 ib = gs_mos(ispin)%index_active(ia)
1379 CALL cp_fm_geadd(1.0_dp,
"N", cpscr, 1.0_dp, cpmos(ispin))
1390 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
1394 ex_env%matrix_wx1 => matrix_wx1
1404 CALL timestop(handle)
1418 SUBROUTINE stda_force(qs_env, ex_env, gs_mos, stda_env, sub_env, work, debug_forces)
1427 LOGICAL,
INTENT(IN) :: debug_forces
1429 CHARACTER(len=*),
PARAMETER :: routinen =
'stda_force'
1431 INTEGER :: atom_i, atom_j, ewald_type, handle, i, &
1432 ia, iatom, idimk, ikind, iounit, is, &
1433 ispin, jatom, jkind, jspin, nao, &
1434 natom, norb, nsgf, nspins
1435 INTEGER,
ALLOCATABLE,
DIMENSION(:) :: atom_of_kind, first_sgf, kind_of, &
1437 INTEGER,
DIMENSION(2) :: nactive, nlim
1438 LOGICAL :: calculate_forces, do_coulomb, do_ewald, &
1439 found, is_rks_triplets, use_virial
1440 REAL(kind=
dp) :: alpha, bp, dgabr, dr, eta, fdim, gabr, &
1441 hfx, rbeta, spinfac, xfac
1442 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:) :: tcharge, tv
1443 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: gtcharge
1444 REAL(kind=
dp),
DIMENSION(3) :: fij, fodeb, rij
1445 REAL(kind=
dp),
DIMENSION(:, :),
POINTER :: gab, pblock
1449 TYPE(
cp_fm_type) :: cvcmat, cvec, cvecjspin, t0matrix, &
1450 t1matrix, vcvec, xvec
1451 TYPE(
cp_fm_type),
ALLOCATABLE,
DIMENSION(:) :: xtransformed
1452 TYPE(
cp_fm_type),
DIMENSION(:),
POINTER :: cpmos, x
1453 TYPE(
cp_fm_type),
POINTER :: ct, ctjspin, ucmatrix, uxmatrix
1456 TYPE(
dbcsr_p_type),
DIMENSION(:),
POINTER :: gamma_matrix, matrix_plo, matrix_s, &
1465 POINTER :: n_list, sab_orb
1468 TYPE(
qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
1474 CALL timeset(routinen, handle)
1476 cpassert(
ASSOCIATED(ex_env))
1477 cpassert(
ASSOCIATED(gs_mos))
1480 IF (logger%para_env%is_source())
THEN
1486 CALL get_qs_env(qs_env, dft_control=dft_control)
1487 tddfpt_control => dft_control%tddfpt2_control
1488 stda_control => tddfpt_control%stda_control
1489 nspins = dft_control%nspins
1490 is_rks_triplets = tddfpt_control%rks_triplets .AND. (nspins == 1)
1494 nactive(:) = stda_env%nactive(:)
1497 IF (nspins == 2) spinfac = 1.0_dp
1498 NULLIFY (matrix_wx1)
1500 NULLIFY (matrix_plo)
1503 IF (nspins == 1 .AND. is_rks_triplets)
THEN
1504 do_coulomb = .false.
1508 do_ewald = stda_control%do_ewald
1510 CALL get_qs_env(qs_env, para_env=para_env, force=force)
1512 CALL get_qs_env(qs_env, natom=natom, cell=cell, &
1513 particle_set=particle_set, qs_kind_set=qs_kind_set)
1514 ALLOCATE (first_sgf(natom))
1515 ALLOCATE (last_sgf(natom))
1516 CALL get_particle_set(particle_set, qs_kind_set, first_sgf=first_sgf, last_sgf=last_sgf)
1518 CALL get_qs_env(qs_env, ks_env=ks_env, matrix_s=matrix_s, sab_orb=sab_orb, atomic_kind_set=atomic_kind_set)
1519 CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set, kind_of=kind_of, atom_of_kind=atom_of_kind)
1523 ALLOCATE (xtransformed(nspins))
1524 DO ispin = 1, nspins
1526 ct => work%ctransformed(ispin)
1528 CALL cp_fm_create(matrix=xtransformed(ispin), matrix_struct=fmstruct, name=
"XTRANSFORMED")
1532 ALLOCATE (tcharge(natom), gtcharge(natom, 4))
1534 cpmos => ex_env%cpmos
1536 DO ispin = 1, nspins
1537 ct => work%ctransformed(ispin)
1538 CALL cp_fm_get_info(ct, matrix_struct=fmstruct, nrow_global=nsgf)
1543 ALLOCATE (matrix_wx1(ispin)%matrix)
1544 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1546 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1547 ALLOCATE (matrix_plo(ispin)%matrix)
1548 CALL dbcsr_create(matrix=matrix_plo(ispin)%matrix, template=matrix_s(1)%matrix)
1550 CALL dbcsr_set(matrix_plo(ispin)%matrix, 0.0_dp)
1554 IF (do_coulomb)
THEN
1556 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1559 DO jspin = 1, nspins
1560 ctjspin => work%ctransformed(jspin)
1562 CALL cp_fm_get_info(ctjspin, matrix_struct=fmstructjspin, nrow_global=nsgf)
1571 DO is = first_sgf(ia), last_sgf(ia)
1572 tcharge(ia) = tcharge(ia) + tv(is)
1582 NULLIFY (gamma_matrix)
1583 CALL setup_gamma(qs_env, stda_env, sub_env, gamma_matrix, ndim=4)
1584 tempmat => gamma_matrix(1)%matrix
1588 gtcharge(iatom, 1) = gtcharge(iatom, 1) + gab(1, 1)*tcharge(jatom)
1589 IF (iatom /= jatom)
THEN
1590 gtcharge(jatom, 1) = gtcharge(jatom, 1) + gab(1, 1)*tcharge(iatom)
1595 row=iatom, col=jatom, block=gab, found=found)
1597 gtcharge(iatom, idimk) = gtcharge(iatom, idimk) + gab(1, 1)*tcharge(jatom)
1598 IF (iatom /= jatom)
THEN
1599 gtcharge(jatom, idimk) = gtcharge(jatom, idimk) + fdim*gab(1, 1)*tcharge(iatom)
1608 ewald_env => work%ewald_env
1609 ewald_pw => work%ewald_pw
1610 CALL ewald_env_get(ewald_env, alpha=alpha, ewald_type=ewald_type)
1611 CALL get_qs_env(qs_env=qs_env, sab_orb=n_list, virial=virial)
1612 use_virial = .false.
1613 calculate_forces = .false.
1614 CALL tb_ewald_overlap(gtcharge, tcharge, alpha, n_list, virial, use_virial)
1616 gtcharge, tcharge, calculate_forces, virial, use_virial)
1618 IF (para_env%is_source())
THEN
1619 gtcharge(:, 1) = gtcharge(:, 1) - 2._dp*alpha*
oorootpi*tcharge(:)
1622 nlim =
get_limit(natom, para_env%num_pe, para_env%mepos)
1623 DO iatom = nlim(1), nlim(2)
1624 DO jatom = 1, iatom - 1
1625 rij = particle_set(iatom)%r - particle_set(jatom)%r
1626 rij =
pbc(rij, cell)
1627 dr = sqrt(sum(rij(:)**2))
1628 IF (dr > 1.e-6_dp)
THEN
1629 gtcharge(iatom, 1) = gtcharge(iatom, 1) + tcharge(jatom)/dr
1630 gtcharge(jatom, 1) = gtcharge(jatom, 1) + tcharge(iatom)/dr
1632 gtcharge(iatom, idimk) = gtcharge(iatom, idimk) + rij(idimk - 1)*tcharge(jatom)/dr**3
1633 gtcharge(jatom, idimk) = gtcharge(jatom, idimk) - rij(idimk - 1)*tcharge(iatom)/dr**3
1639 CALL para_env%sum(gtcharge(:, 1))
1644 DO is = first_sgf(ia), last_sgf(ia)
1645 tv(is) = gtcharge(ia, 1)
1650 ikind = kind_of(iatom)
1651 atom_i = atom_of_kind(iatom)
1653 fij(i) = spinfac*spinfac*gtcharge(iatom, i + 1)*tcharge(iatom)
1655 force(ikind)%rho_elec(1, atom_i) = force(ikind)%rho_elec(1, atom_i) - fij(1)
1656 force(ikind)%rho_elec(2, atom_i) = force(ikind)%rho_elec(2, atom_i) - fij(2)
1657 force(ikind)%rho_elec(3, atom_i) = force(ikind)%rho_elec(3, atom_i) - fij(3)
1660 IF (debug_forces)
THEN
1661 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1662 CALL para_env%sum(fodeb)
1663 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Coul[X] ", fodeb
1665 norb = nactive(ispin)
1667 CALL cp_fm_get_info(work%S_C0_C0T(ispin), matrix_struct=fmstruct)
1668 CALL cp_fm_create(t0matrix, matrix_struct=fmstruct, name=
"T0 SCRATCH")
1669 CALL cp_fm_create(t1matrix, matrix_struct=fmstruct, name=
"T1 SCRATCH")
1674 ct => work%ctransformed(ispin)
1677 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1678 cvec, 0.0_dp, ucmatrix)
1679 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1680 x(ispin), 0.0_dp, uxmatrix)
1681 CALL parallel_gemm(
'N',
'T', nsgf, nsgf, norb, 1.0_dp, uxmatrix, ucmatrix, 0.0_dp, t0matrix)
1684 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1685 cvec, 0.0_dp, uxmatrix)
1686 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1687 gs_mos(ispin)%mos_occ, 0.0_dp, ucmatrix)
1688 CALL parallel_gemm(
'N',
'T', nsgf, nsgf, norb, 1.0_dp, ucmatrix, uxmatrix, 1.0_dp, t0matrix)
1691 CALL parallel_gemm(
'N',
'N', nsgf, nsgf, nsgf, spinfac, work%S_eigenvectors, t1matrix, &
1694 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1696 DEALLOCATE (ucmatrix)
1698 DEALLOCATE (uxmatrix)
1707 ct => work%ctransformed(ispin)
1711 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1715 ncol_global=norb, para_env=fmstruct%para_env)
1718 CALL parallel_gemm(
"T",
"N", norb, norb, nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1719 CALL parallel_gemm(
"N",
"N", nao, norb, norb, 1.0_dp, x(ispin), cvcmat, 0.0_dp, vcvec)
1721 nactive(ispin), alpha=-2.0_dp*spinfac, beta=1.0_dp)
1725 matrix_g=vcvec, ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1732 IF (stda_env%do_exchange)
THEN
1734 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1736 norb = nactive(ispin)
1738 tempmat => work%shalf
1739 CALL dbcsr_create(pdens, template=tempmat, matrix_type=dbcsr_type_no_symmetry)
1741 ct => work%ctransformed(ispin)
1744 1.0_dp, keep_sparsity=.false.)
1748 bp = stda_env%beta_param
1749 hfx = stda_env%hfx_fraction
1753 rij = particle_set(iatom)%r - particle_set(jatom)%r
1754 rij =
pbc(rij, cell)
1755 dr = sqrt(sum(rij(:)**2))
1756 ikind = kind_of(iatom)
1757 jkind = kind_of(jatom)
1758 eta = (stda_env%kind_param_set(ikind)%kind_param%hardness_param + &
1759 stda_env%kind_param_set(jkind)%kind_param%hardness_param)/2.0_dp
1761 IF (hfx > 0.0_dp)
THEN
1762 gabr = (1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp)
1764 IF (dr < 1.0e-6_dp)
THEN
1772 IF (dr > 1.0e-6_dp)
THEN
1773 IF (hfx > 0.0_dp)
THEN
1774 dgabr = -(1._dp/bp)*(1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp + 1._dp)
1775 dgabr = bp*rbeta/dr**2*dgabr
1776 dgabr = sum(pblock**2)*dgabr
1778 dgabr = -1.0_dp/dr**3
1779 dgabr = sum(pblock**2)*dgabr
1781 atom_i = atom_of_kind(iatom)
1782 atom_j = atom_of_kind(jatom)
1784 fij(i) = dgabr*rij(i)
1786 force(ikind)%rho_elec(1, atom_i) = force(ikind)%rho_elec(1, atom_i) - fij(1)
1787 force(ikind)%rho_elec(2, atom_i) = force(ikind)%rho_elec(2, atom_i) - fij(2)
1788 force(ikind)%rho_elec(3, atom_i) = force(ikind)%rho_elec(3, atom_i) - fij(3)
1789 force(jkind)%rho_elec(1, atom_j) = force(jkind)%rho_elec(1, atom_j) + fij(1)
1790 force(jkind)%rho_elec(2, atom_j) = force(jkind)%rho_elec(2, atom_j) + fij(2)
1791 force(jkind)%rho_elec(3, atom_j) = force(jkind)%rho_elec(3, atom_j) + fij(3)
1794 pblock = gabr*pblock
1803 CALL cp_fm_get_info(work%S_C0_C0T(ispin), matrix_struct=fmstruct)
1804 CALL cp_fm_create(t0matrix, matrix_struct=fmstruct, name=
"T0 SCRATCH")
1805 CALL cp_fm_create(t1matrix, matrix_struct=fmstruct, name=
"T1 SCRATCH")
1810 ct => work%ctransformed(ispin)
1812 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1813 cvec, 0.0_dp, ucmatrix)
1814 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1815 x(ispin), 0.0_dp, uxmatrix)
1816 CALL parallel_gemm(
'N',
'T', nsgf, nsgf, norb, 1.0_dp, uxmatrix, ucmatrix, 0.0_dp, t0matrix)
1818 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1819 cvec, 0.0_dp, uxmatrix)
1820 CALL parallel_gemm(
'T',
'N', nsgf, norb, nsgf, 1.0_dp, work%S_eigenvectors, &
1821 gs_mos(ispin)%mos_occ, 0.0_dp, ucmatrix)
1822 CALL parallel_gemm(
'N',
'T', nsgf, nsgf, norb, 1.0_dp, ucmatrix, uxmatrix, 1.0_dp, t0matrix)
1824 CALL parallel_gemm(
'N',
'N', nsgf, nsgf, nsgf, -1.0_dp, work%S_eigenvectors, t1matrix, &
1827 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1829 DEALLOCATE (ucmatrix)
1831 DEALLOCATE (uxmatrix)
1839 alpha=-xfac, beta=1.0_dp)
1841 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1847 ncol_global=norb, para_env=fmstruct%para_env)
1850 CALL parallel_gemm(
"T",
"N", norb, norb, nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1851 CALL parallel_gemm(
"N",
"N", nao, norb, norb, 1.0_dp, x(ispin), cvcmat, 0.0_dp, vcvec)
1853 norb, alpha=xfac, beta=1.0_dp)
1855 IF (nspins == 2)
THEN
1862 ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1869 IF (debug_forces)
THEN
1870 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1871 CALL para_env%sum(fodeb)
1872 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Exch[X] ", fodeb
1882 DEALLOCATE (tcharge, gtcharge)
1883 DEALLOCATE (first_sgf, last_sgf)
1886 IF (nspins == 2)
THEN
1887 CALL dbcsr_add(matrix_plo(1)%matrix, matrix_plo(2)%matrix, &
1888 alpha_scalar=1.0_dp, beta_scalar=1.0_dp)
1892 IF (debug_forces) fodeb(1:3) = force(1)%overlap(1:3, 1)
1894 matrix_name=
"OVERLAP MATRIX", &
1895 basis_type_a=
"ORB", basis_type_b=
"ORB", &
1896 sab_nl=sab_orb, calculate_forces=.true., &
1897 matrix_p=matrix_plo(1)%matrix)
1900 IF (debug_forces)
THEN
1901 fodeb(1:3) = force(1)%overlap(1:3, 1) - fodeb(1:3)
1902 CALL para_env%sum(fodeb)
1903 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Lowdin ", fodeb
1907 ex_env%matrix_wx1 => matrix_wx1
1909 CALL timestop(handle)