168 SUBROUTINE fhxc_force(qs_env, ex_env, gs_mos, full_kernel, debug_forces)
175 LOGICAL,
INTENT(IN) :: debug_forces
177 CHARACTER(LEN=*),
PARAMETER :: routinen =
'fhxc_force'
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, &
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
193 TYPE(
cp_fm_type) :: avamat, avcmat, cpscr, cvcmat, vavec, &
195 TYPE(
cp_fm_type),
DIMENSION(:),
POINTER :: cpmos, evect
196 TYPE(
cp_fm_type),
POINTER :: mos, mos2, mosa, mosa2
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
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
211 POINTER :: sab, sab_aux_fit, sab_orb, sap_oce
215 TYPE(
pw_c1d_gs_type),
DIMENSION(:),
POINTER :: rho_g_aux, rhox_g, rhox_g_aux, rhoxx_g
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
224 TYPE(
qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
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, &
233 CALL timeset(routinen, handle)
236 IF (logger%para_env%is_source())
THEN
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)
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
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
266 IF (nspins == 2) focc = 0.5_dp
267 nsev =
SIZE(evect, 1)
271 CALL dbcsr_set(matrix_px1(ispin)%matrix, 0.0_dp)
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)
278 CALL dbcsr_set(matrix_px1_asymm(ispin)%matrix, 0.0_dp)
280 matrix_v=gs_mos(ispin)%mos_active, &
281 matrix_g=evect(ispin), &
282 ncol=nactive(ispin), alpha=2.0_dp*focc, &
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)
289 NULLIFY (hartree_local, local_rho_set, local_rho_set_admm)
290 IF (gapw .OR. gapw_xc)
THEN
291 IF (nspins == 2)
THEN
297 atomic_kind_set=atomic_kind_set, &
298 qs_kind_set=qs_kind_set)
301 qs_kind_set, dft_control, para_env)
304 CALL init_rho0(local_rho_set, qs_env, dft_control%qs_control%gapw_control, &
311 CALL get_qs_env(qs_env=qs_env, oce=oce, sap_oce=sap_oce, sab_orb=sab)
313 CALL get_qs_env(qs_env=qs_env, nkind=nkind, particle_set=particle_set)
315 eps_fit = dft_control%qs_control%gapw_control%eps_fit
320 mpga(1:nsev, 1:1) => matrix_px1(1:nsev)
322 qs_kind_set, oce, sab, para_env)
327 qs_kind_set, dft_control, para_env)
329 qs_kind_set, oce, sab, para_env)
334 qs_kind_set, dft_control, para_env)
336 qs_kind_set, oce, sab, para_env)
338 IF (nspins == 2)
THEN
347 nao_aux = admm_env%nao_aux_fit
348 nao = admm_env%nao_orb
354 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
355 admm_env%work_aux_orb)
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.)
362 CALL copy_dbcsr_to_fm(matrix_px1_asymm(ispin)%matrix, admm_env%work_orb_orb)
364 1.0_dp, admm_env%A, admm_env%work_orb_orb, 0.0_dp, &
365 admm_env%work_aux_orb)
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.)
373 IF (admm_env%do_gapw)
THEN
374 IF (do_admm .AND. tddfpt_control%admm_xc_correction)
THEN
378 CALL get_qs_env(qs_env, atomic_kind_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)
385 admm_env%admm_gapw_env%admm_kind_set, &
386 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
388 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
392 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
394 admm_env%admm_gapw_env%admm_kind_set, &
395 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
397 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
401 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
403 admm_env%admm_gapw_env%admm_kind_set, &
404 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
406 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
412 CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, &
413 poisson_env=poisson_env)
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))
420 CALL auxbas_pw_pool%create_pw(rhox_tot_gspace)
425 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
427 rho=rhox_r(ispin), rho_gspace=rhox_g(ispin), &
430 CALL pw_axpy(rhox_g(ispin), rhox_tot_gspace)
432 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
436 ALLOCATE (rhoxx_r(nsev), rhoxx_g(nsev))
438 CALL auxbas_pw_pool%create_pw(rhoxx_r(ispin))
439 CALL auxbas_pw_pool%create_pw(rhoxx_g(ispin))
442 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 2.0_dp)
444 rho=rhoxx_r(ispin), rho_gspace=rhoxx_g(ispin), &
446 IF (nspins == 2)
CALL dbcsr_scale(matrix_px1(ispin)%matrix, 0.5_dp)
450 CALL get_qs_env(qs_env, matrix_s=matrix_s, force=force)
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)
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)
464 CALL pw_transfer(xv_hartree_gspace, xv_hartree_rspace)
465 CALL pw_scale(xv_hartree_rspace, xv_hartree_rspace%pw_grid%dvol)
467 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
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.)
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
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., &
488 IF (nspins == 1)
THEN
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
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
512 IF (full_kernel%do_exck)
THEN
515 NULLIFY (fxc_rho, fxc_tau, gxc_rho, gxc_tau)
516 xc_section => full_kernel%xc_section
520 SELECT CASE (ex_env%xc_kernel_method)
531 cpabort(
"invalid xc_kernel_method")
533 order = ex_env%diff_order
534 eps_delta = ex_env%eps_delta_rho
537 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho_xc=rho)
539 CALL get_qs_env(qs_env=qs_env, ks_env=ks_env, rho=rho)
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.)
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.)
557 IF (.NOT. do_sf)
THEN
558 cpabort(
"Analytic 3rd EXC derivatives not available")
560 CALL get_qs_env(qs_env, xcint_weights=weights)
562 fxc_rho, fxc_tau, gxc_rho, gxc_tau, spinflip=do_sf)
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)
569 CALL qs_fgxc_create(ks_env, rho, rhox, xc_section, order, is_rks_triplets, &
570 fxc_rho, fxc_tau, gxc_rho, gxc_tau)
573 cpabort(
"FHXC forces analytic/numeric")
576 IF (nspins == 2)
THEN
578 CALL pw_scale(gxc_rho(ispin), 0.5_dp)
579 IF (
ASSOCIATED(gxc_tau))
CALL pw_scale(gxc_tau(ispin), 0.5_dp)
582 IF (gapw .OR. gapw_xc)
THEN
584 cpabort(
"Analytic 3rd EXC derivatives not available")
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)
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)
596 cpabort(
"FHXC forces analytic/numeric")
600 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
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)
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.)
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
621 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
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.)
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
646 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
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
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
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, &
677 rho_atom_external=local_rho_set_g%rho_atom_set, &
678 kintegral=0.5_dp, kforce=0.25_dp)
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
689 IF (do_admm .AND. tddfpt_control%admm_xc_correction .AND. (tddfpt_control%spinflip /=
tddfpt_sf_col))
THEN
693 IF (.NOT. tddfpt_control%admm_symm)
THEN
694 CALL cp_warn(__location__,
"Forces need symmetric ADMM kernel corrections")
695 cpabort(
"ADMM KERNEL CORRECTION")
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
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)
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)
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)
727 ALLOCATE (rhox_r_aux(nsev), rhox_g_aux(nsev))
729 CALL auxbas_pw_pool%create_pw(rhox_r_aux(ispin))
730 CALL auxbas_pw_pool%create_pw(rhox_g_aux(ispin))
734 rho=rhox_r_aux(ispin), rho_gspace=rhox_g_aux(ispin), &
735 basis_type=basis_type, &
736 task_list_external=task_list)
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.)
746 cpabort(
"Analytic 3rd derivatives of EXC not available")
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)
753 order, is_rks_triplets, fxc_rho, fxc_tau, gxc_rho, gxc_tau)
756 cpabort(
"FHXC forces analytic/numeric")
760 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
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
774 DEALLOCATE (rhox_aux)
777 CALL auxbas_pw_pool%give_back_pw(rhox_r_aux(ispin))
778 CALL auxbas_pw_pool%give_back_pw(rhox_g_aux(ispin))
780 DEALLOCATE (rhox_r_aux, rhox_g_aux)
782 IF (nspins == 2) fscal = 2.0_dp
784 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
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), &
789 pmat=matrix_px1_admm(ispin), &
790 basis_type=basis_type, &
791 calculate_forces=.true., &
793 task_list_external=task_list)
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
801 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
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), &
807 pmat=matrix_p_admm(ispin), &
808 basis_type=basis_type, &
809 calculate_forces=.true., &
811 task_list_external=task_list)
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
821 IF (admm_env%do_gapw)
THEN
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
828 cpabort(
"Analytic 3rd EXC derivatives not available")
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)
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)
842 cpabort(
"FHXC forces analytic/numeric")
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)
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)
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
864 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
865 IF (nspins == 1)
THEN
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)
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)
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
887 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
888 fval = 2.0_dp*real(nspins, kind=
dp)
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
895 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
896 fval = 2.0_dp*real(nspins, kind=
dp)
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
906 IF (nspins == 2) fscal = 2.0_dp
907 nao = admm_env%nao_orb
908 nao_aux = admm_env%nao_aux_fit
914 admm_env%work_aux_orb, nao)
916 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
917 admm_env%work_orb_orb)
921 CALL dbcsr_add(matrix_fx(ispin)%matrix, dbwork, 1.0_dp, fscal)
924 admm_env%work_aux_orb, nao)
926 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
927 admm_env%work_orb_orb)
930 CALL dbcsr_add(matrix_gx(ispin)%matrix, dbwork, 1.0_dp, fscal)
941 CALL auxbas_pw_pool%give_back_pw(rhox_r(ispin))
942 CALL auxbas_pw_pool%give_back_pw(rhox_g(ispin))
944 DEALLOCATE (rhox_r, rhox_g)
945 CALL auxbas_pw_pool%give_back_pw(rhox_tot_gspace)
948 CALL auxbas_pw_pool%give_back_pw(rhoxx_r(ispin))
949 CALL auxbas_pw_pool%give_back_pw(rhoxx_g(ispin))
951 DEALLOCATE (rhoxx_r, rhoxx_g)
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)
960 NULLIFY (matrix_hfx, matrix_hfx_asymm)
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)
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)
975 xc_section => full_kernel%xc_section
978 cpassert(n_rep_hf == 1)
982 IF (hfx_treat_lsd_in_core) mspin = nsev
984 CALL get_qs_env(qs_env=qs_env, x_data=x_data, s_mstruct_changed=s_mstruct_changed)
985 distribute_fock_matrix = .true.
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)
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)
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)
1005 ALLOCATE (mpe(nsev, 1), mhe(nsev, 1))
1007 mhe(ispin, 1)%matrix => matrix_hfx_admm(ispin)%matrix
1008 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
1010 IF (x_data(1, 1)%do_hfx_ri)
THEN
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)
1019 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1020 ispin=ispin, nspins=nsev)
1025 mhe(ispin, 1)%matrix => matrix_hfx_admm_asymm(ispin)%matrix
1026 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1028 IF (x_data(1, 1)%do_hfx_ri)
THEN
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)
1037 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1038 ispin=ispin, nspins=nsev)
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)
1049 admm_env%work_aux_orb, nao)
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)
1056 CALL dbcsr_add(matrix_hfx(ispin)%matrix, dbwork, 1.0_dp, 1.0_dp)
1059 admm_env%work_aux_orb, nao)
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)
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)
1070 DEALLOCATE (dbwork, dbwork_asymm)
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
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
1083 use_virial = .false.
1085 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1087 IF (do_sf) fval = fval*2.0_dp
1088 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1090 mpe(ispin, 1)%matrix => matrix_px1_admm(ispin)%matrix
1092 IF (x_data(1, 1)%do_hfx_ri)
THEN
1094 x_data(1, 1)%general_parameter%fraction, &
1095 rho_ao=mpe, rho_ao_resp=mdum, &
1096 use_virial=use_virial, rescale_factor=fval)
1099 adiabatic_rescale_factor=fval, nspins=nsev)
1102 mpe(ispin, 1)%matrix => matrix_px1_admm_asymm(ispin)%matrix
1104 IF (x_data(1, 1)%do_hfx_ri)
THEN
1106 x_data(1, 1)%general_parameter%fraction, &
1107 rho_ao=mpe, rho_ao_resp=mdum, &
1108 use_virial=use_virial, rescale_factor=fval)
1111 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
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
1119 DEALLOCATE (mpe, mhe)
1125 ALLOCATE (mpe(nsev, 1), mhe(nsev, 1))
1127 mhe(ispin, 1)%matrix => matrix_hfx(ispin)%matrix
1128 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1130 IF (x_data(1, 1)%do_hfx_ri)
THEN
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)
1139 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1140 ispin=ispin, nspins=
SIZE(mpe, 1))
1146 mhe(ispin, 1)%matrix => matrix_hfx_asymm(ispin)%matrix
1147 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1149 IF (x_data(1, 1)%do_hfx_ri)
THEN
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)
1158 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
1159 ispin=ispin, nspins=
SIZE(mpe, 1))
1163 use_virial = .false.
1165 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1167 IF (do_sf) fval = fval*2.0_dp
1168 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
1170 mpe(ispin, 1)%matrix => matrix_px1(ispin)%matrix
1172 IF (x_data(1, 1)%do_hfx_ri)
THEN
1174 x_data(1, 1)%general_parameter%fraction, &
1175 rho_ao=mpe, rho_ao_resp=mdum, &
1176 use_virial=use_virial, rescale_factor=fval)
1179 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
1182 mpe(ispin, 1)%matrix => matrix_px1_asymm(ispin)%matrix
1184 IF (x_data(1, 1)%do_hfx_ri)
THEN
1186 x_data(1, 1)%general_parameter%fraction, &
1187 rho_ao=mpe, rho_ao_resp=mdum, &
1188 use_virial=use_virial, rescale_factor=fval)
1191 adiabatic_rescale_factor=fval, nspins=
SIZE(mpe, 1))
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
1199 DEALLOCATE (mpe, mhe)
1201 fval = 2.0_dp*real(nspins, kind=
dp)*0.5_dp
1203 IF (do_sf) fval = fval*2.0_dp
1206 CALL dbcsr_scale(matrix_hfx_asymm(ispin)%matrix, fval)
1210 IF (gapw .OR. gapw_xc)
THEN
1219 IF (admm_env%do_gapw)
THEN
1220 IF (tddfpt_control%admm_xc_correction)
THEN
1232 cpabort(
"HFXSR not implemented")
1236 cpabort(
"HFXLR not implemented")
1240 NULLIFY (matrix_wx1)
1242 cpmos => ex_env%cpmos
1244 IF (nspins == 2) focc = 1.0_dp
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
1260 DO ispin = 1, nspins
1262 IF (nactive(ispin) == norb(ispin))
THEN
1264 DO ia = 1, nactive(ispin)
1265 cpassert(ia == gs_mos(ispin)%index_active(ia))
1272 IF (.NOT. do_sf)
THEN
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
1281 CALL cp_fm_create(cpscr, gs_mos(ispin)%mos_active%matrix_struct,
"cpscr", set_zero=.true.)
1283 CALL cp_fm_get_info(gs_mos(ispin)%mos_occ, matrix_struct=fm_struct, nrow_global=nao)
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))
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")
1293 ALLOCATE (matrix_wx1(ispin)%matrix)
1294 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
1296 CALL dbcsr_set(matrix_wx1(ispin)%matrix, 0.0_dp)
1299 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
1301 cpscr, nactive(ispin), alpha=focc, beta=1.0_dp)
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)
1311 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1318 IF (.NOT. (do_sf .AND. (ispin == 2)))
THEN
1321 cpscr, nactive(ispin), alpha=focc, beta=1.0_dp)
1324 IF (.NOT. (do_sf .AND. (ispin == 1)))
THEN
1327 norb(ispin), alpha=1.0_dp, beta=0.0_dp)
1329 CALL parallel_gemm(
"T",
"N", nactive(spin), norb(ispin), nao, 1.0_dp, &
1330 mosa, vcvec, 0.0_dp, avcmat)
1332 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), nactive(spin), 1.0_dp, &
1333 evect(spin), avcmat, 0.0_dp, vcvec)
1336 norb(ispin), alpha=-focc, beta=1.0_dp)
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)
1347 cpmos(ispin), norb(ispin), alpha=focc, beta=1.0_dp)
1351 alpha=1.0_dp, beta=0.0_dp)
1353 CALL parallel_gemm(
"T",
"N", norb(ispin), norb(ispin), nao, 1.0_dp, gs_mos(ispin)%mos_occ, vcvec, 0.0_dp, cvcmat)
1355 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), norb(ispin), 1.0_dp, gs_mos(ispin)%mos_occ, cvcmat, 0.0_dp, vcvec)
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)
1364 IF (.NOT. (do_sf .AND. (ispin == 2)))
THEN
1367 cpscr, nactive(spin), alpha=focc, beta=1.0_dp)
1370 cpscr, nactive(spin), alpha=focc, beta=1.0_dp)
1374 IF (.NOT. (do_sf .AND. (ispin == 1)))
THEN
1377 alpha=1.0_dp, beta=0.0_dp)
1380 alpha=1.0_dp, beta=1.0_dp)
1382 CALL parallel_gemm(
"T",
"N", nactive(spin), norb(ispin), nao, 1.0_dp, &
1383 mosa, vcvec, 0.0_dp, avcmat)
1385 CALL parallel_gemm(
"N",
"N", nao, norb(ispin), nactive(spin), 1.0_dp, &
1386 evect(spin), avcmat, 0.0_dp, vcvec)
1389 norb(ispin), alpha=-focc, beta=1.0_dp)
1393 ncol=norb(ispin), alpha=2.0_dp, symmetry_mode=1)
1398 DO ia = 1, nactive(ispin)
1399 ib = gs_mos(ispin)%index_active(ia)
1403 CALL cp_fm_geadd(1.0_dp,
"N", cpscr, 1.0_dp, cpmos(ispin))
1414 IF (.NOT. (is_rks_triplets .OR. do_sf))
THEN
1418 ex_env%matrix_wx1 => matrix_wx1
1428 CALL timestop(handle)
1442 SUBROUTINE stda_force(qs_env, ex_env, gs_mos, stda_env, sub_env, work, debug_forces)
1451 LOGICAL,
INTENT(IN) :: debug_forces
1453 CHARACTER(len=*),
PARAMETER :: routinen =
'stda_force'
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, &
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
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
1480 TYPE(
dbcsr_p_type),
DIMENSION(:),
POINTER :: gamma_matrix, matrix_plo, matrix_s, &
1489 POINTER :: n_list, sab_orb
1492 TYPE(
qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
1498 CALL timeset(routinen, handle)
1500 cpassert(
ASSOCIATED(ex_env))
1501 cpassert(
ASSOCIATED(gs_mos))
1504 IF (logger%para_env%is_source())
THEN
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)
1518 nactive(:) = stda_env%nactive(:)
1521 IF (nspins == 2) spinfac = 1.0_dp
1522 NULLIFY (matrix_wx1)
1524 NULLIFY (matrix_plo)
1527 IF (nspins == 1 .AND. is_rks_triplets)
THEN
1528 do_coulomb = .false.
1532 do_ewald = stda_control%do_ewald
1534 CALL get_qs_env(qs_env, para_env=para_env, force=force)
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)
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)
1547 ALLOCATE (xtransformed(nspins))
1548 DO ispin = 1, nspins
1550 ct => work%ctransformed(ispin)
1552 CALL cp_fm_create(matrix=xtransformed(ispin), matrix_struct=fmstruct, name=
"XTRANSFORMED")
1556 ALLOCATE (tcharge(natom), gtcharge(natom, 4))
1558 cpmos => ex_env%cpmos
1560 DO ispin = 1, nspins
1561 ct => work%ctransformed(ispin)
1562 CALL cp_fm_get_info(ct, matrix_struct=fmstruct, nrow_global=nsgf)
1567 ALLOCATE (matrix_wx1(ispin)%matrix)
1568 CALL dbcsr_create(matrix=matrix_wx1(ispin)%matrix, template=matrix_s(1)%matrix)
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)
1574 CALL dbcsr_set(matrix_plo(ispin)%matrix, 0.0_dp)
1578 IF (do_coulomb)
THEN
1580 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1583 DO jspin = 1, nspins
1584 ctjspin => work%ctransformed(jspin)
1586 CALL cp_fm_get_info(ctjspin, matrix_struct=fmstructjspin, nrow_global=nsgf)
1595 DO is = first_sgf(ia), last_sgf(ia)
1596 tcharge(ia) = tcharge(ia) + tv(is)
1606 NULLIFY (gamma_matrix)
1607 CALL setup_gamma(qs_env, stda_env, sub_env, gamma_matrix, ndim=4)
1608 tempmat => gamma_matrix(1)%matrix
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)
1619 row=iatom, col=jatom, block=gab, found=found)
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)
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)
1640 gtcharge, tcharge, calculate_forces, virial, use_virial)
1642 IF (para_env%is_source())
THEN
1643 gtcharge(:, 1) = gtcharge(:, 1) - 2._dp*alpha*
oorootpi*tcharge(:)
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
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
1663 CALL para_env%sum(gtcharge(:, 1))
1668 DO is = first_sgf(ia), last_sgf(ia)
1669 tv(is) = gtcharge(ia, 1)
1674 ikind = kind_of(iatom)
1675 atom_i = atom_of_kind(iatom)
1677 fij(i) = spinfac*spinfac*gtcharge(iatom, i + 1)*tcharge(iatom)
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)
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
1689 norb = nactive(ispin)
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")
1698 ct => work%ctransformed(ispin)
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)
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)
1715 CALL parallel_gemm(
'N',
'N', nsgf, nsgf, nsgf, spinfac, work%S_eigenvectors, t1matrix, &
1718 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1720 DEALLOCATE (ucmatrix)
1722 DEALLOCATE (uxmatrix)
1731 ct => work%ctransformed(ispin)
1735 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1739 ncol_global=norb, para_env=fmstruct%para_env)
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)
1745 nactive(ispin), alpha=-2.0_dp*spinfac, beta=1.0_dp)
1749 matrix_g=vcvec, ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
1756 IF (stda_env%do_exchange)
THEN
1758 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1760 norb = nactive(ispin)
1762 tempmat => work%shalf
1763 CALL dbcsr_create(pdens, template=tempmat, matrix_type=dbcsr_type_no_symmetry)
1765 ct => work%ctransformed(ispin)
1768 1.0_dp, keep_sparsity=.false.)
1772 bp = stda_env%beta_param
1773 hfx = stda_env%hfx_fraction
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
1785 IF (hfx > 0.0_dp)
THEN
1786 gabr = (1._dp/(rbeta + (hfx*eta)**(-bp)))**(1._dp/bp)
1788 IF (dr < 1.0e-6_dp)
THEN
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
1802 dgabr = -1.0_dp/dr**3
1803 dgabr = sum(pblock**2)*dgabr
1805 atom_i = atom_of_kind(iatom)
1806 atom_j = atom_of_kind(jatom)
1808 fij(i) = dgabr*rij(i)
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)
1818 pblock = gabr*pblock
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")
1834 ct => work%ctransformed(ispin)
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)
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)
1848 CALL parallel_gemm(
'N',
'N', nsgf, nsgf, nsgf, -1.0_dp, work%S_eigenvectors, t1matrix, &
1851 matrix_g=work%S_eigenvectors, ncol=nsgf, alpha=2.0_dp, symmetry_mode=1)
1853 DEALLOCATE (ucmatrix)
1855 DEALLOCATE (uxmatrix)
1863 alpha=-xfac, beta=1.0_dp)
1865 CALL cp_fm_get_info(cvec, matrix_struct=fmstruct, nrow_global=nao)
1871 ncol_global=norb, para_env=fmstruct%para_env)
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)
1877 norb, alpha=xfac, beta=1.0_dp)
1879 IF (nspins == 2)
THEN
1886 ncol=norb, alpha=2.0_dp*alpha, symmetry_mode=1)
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
1906 DEALLOCATE (tcharge, gtcharge)
1907 DEALLOCATE (first_sgf, last_sgf)
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)
1916 IF (debug_forces) fodeb(1:3) = force(1)%overlap(1:3, 1)
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)
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
1931 ex_env%matrix_wx1 => matrix_wx1
1933 CALL timestop(handle)