810 SUBROUTINE response_force(qs_env, vh_rspace, vxc_rspace, vtau_rspace, vadmm_rspace, &
811 matrix_hz, matrix_pz, matrix_pz_admm, matrix_wz, &
812 zehartree, zexc, zexc_aux_fit, rhopz_r, p_env, ex_env, debug)
815 TYPE(
pw_r3d_rs_type),
DIMENSION(:),
POINTER :: vxc_rspace, vtau_rspace, vadmm_rspace
816 TYPE(dbcsr_p_type),
DIMENSION(:),
POINTER :: matrix_hz, matrix_pz, matrix_pz_admm, &
818 REAL(kind=
dp),
OPTIONAL :: zehartree, zexc, zexc_aux_fit
820 INTENT(INOUT),
OPTIONAL :: rhopz_r
823 LOGICAL,
INTENT(IN),
OPTIONAL :: debug
825 CHARACTER(LEN=*),
PARAMETER :: routinen =
'response_force'
827 CHARACTER(LEN=default_string_length) :: basis_type
828 INTEGER :: handle, iounit, ispin, mspin, myfun, &
829 n_rep_hf, nao, nao_aux, natom, nder, &
830 nimages, nocc, nspins
831 INTEGER,
DIMENSION(:, :, :),
POINTER :: cell_to_index
832 LOGICAL :: debug_forces, debug_stress, distribute_fock_matrix, do_ex, do_hfx, gapw, gapw_xc, &
833 hfx_treat_lsd_in_core, resp_only, s_mstruct_changed, use_virial
834 REAL(kind=
dp) :: eh1, ehartree, ekin_mol, eps_filter, &
835 eps_ppnl, exc, exc_aux_fit, fconv, &
836 focc, hartree_gs, hartree_t
837 REAL(kind=
dp),
ALLOCATABLE,
DIMENSION(:, :) :: ftot1, ftot2, ftot3
838 REAL(kind=
dp),
DIMENSION(2) :: total_rho_gs, total_rho_t
839 REAL(kind=
dp),
DIMENSION(3) :: fodeb
840 REAL(kind=
dp),
DIMENSION(3, 3) :: h_stress, pv_loc, stdeb, sttot, sttot2
845 TYPE(dbcsr_distribution_type),
POINTER :: dbcsr_dist
846 TYPE(dbcsr_p_type),
DIMENSION(:),
POINTER :: matrix_ht, matrix_pd, matrix_pza, &
848 TYPE(dbcsr_p_type),
DIMENSION(:, :),
POINTER :: matrix_h, matrix_p, mhd, mhx, mhy, mhz, &
850 TYPE(dbcsr_type),
POINTER :: dbwork
853 TYPE(
hfx_type),
DIMENSION(:, :),
POINTER :: x_data
855 TYPE(
local_rho_type),
POINTER :: local_rho_set_f, local_rho_set_gs, &
856 local_rho_set_t, local_rho_set_vxc, &
861 POINTER :: sab_aux_fit, sab_orb, sac_ae, sac_ppl, &
865 TYPE(
pw_c1d_gs_type) :: rho_tot_gspace, rho_tot_gspace_gs, rho_tot_gspace_t, &
866 rhoz_tot_gspace, v_hartree_gspace_gs, v_hartree_gspace_t, zv_hartree_gspace
867 TYPE(
pw_c1d_gs_type),
DIMENSION(:),
POINTER :: rho_g_aux, rho_g_gs, rho_g_t, rhoz_g, &
868 rhoz_g_aux, rhoz_g_xc
873 TYPE(
pw_r3d_rs_type) :: v_hartree_rspace_gs, v_hartree_rspace_t, &
874 vhxc_rspace, zv_hartree_rspace
875 TYPE(
pw_r3d_rs_type),
DIMENSION(:),
POINTER :: rho_r_aux, rho_r_gs, rho_r_t, rhoz_r, &
876 rhoz_r_aux, rhoz_r_xc, tau_r_aux, &
877 tauz_r, tauz_r_xc, v_xc, v_xc_tau
879 TYPE(
qs_kind_type),
DIMENSION(:),
POINTER :: qs_kind_set
881 TYPE(
qs_rho_type),
POINTER :: rho, rho_aux_fit, rho_xc
886 CALL timeset(routinen, handle)
888 IF (
PRESENT(debug))
THEN
892 debug_forces = .false.
893 debug_stress = .false.
898 IF (logger%para_env%is_source())
THEN
905 IF (
PRESENT(ex_env)) do_ex = .true.
907 cpassert(
PRESENT(p_env))
910 NULLIFY (ks_env, sab_orb, sac_ae, sac_ppl, sap_ppnl, virial)
915 dft_control=dft_control, &
922 nspins = dft_control%nspins
923 gapw = dft_control%qs_control%gapw
924 gapw_xc = dft_control%qs_control%gapw_xc
926 IF (debug_forces)
THEN
927 CALL get_qs_env(qs_env, natom=natom, atomic_kind_set=atomic_kind_set)
928 ALLOCATE (ftot1(3, natom))
933 use_virial = virial%pv_availability .AND. (.NOT. virial%pv_numer)
935 IF (use_virial .AND. do_ex)
THEN
936 CALL cp_abort(__location__,
"Stress Tensor not available for TDDFT calculations.")
939 fconv = 1.0e-9_dp*
pascal/cell%deth
940 IF (debug_stress .AND. use_virial)
THEN
941 sttot = virial%pv_virial
951 ALLOCATE (mpa(ispin)%matrix)
952 CALL dbcsr_create(mpa(ispin)%matrix, template=p_env%p1(ispin)%matrix)
953 CALL dbcsr_copy(mpa(ispin)%matrix, p_env%p1(ispin)%matrix)
954 CALL dbcsr_add(mpa(ispin)%matrix, ex_env%matrix_pe(ispin)%matrix, 1.0_dp, 1.0_dp)
955 CALL dbcsr_set(matrix_hz(ispin)%matrix, 0.0_dp)
960 ALLOCATE (matrix_ht(ispin)%matrix)
961 CALL dbcsr_create(matrix_ht(ispin)%matrix, template=matrix_hz(ispin)%matrix)
962 CALL dbcsr_copy(matrix_ht(ispin)%matrix, matrix_hz(ispin)%matrix)
963 CALL dbcsr_set(matrix_ht(ispin)%matrix, 0.0_dp)
971 IF (nspins == 2)
THEN
972 CALL dbcsr_add(mpa(1)%matrix, mpa(2)%matrix, 1.0_dp, 1.0_dp)
978 IF (debug_forces) fodeb(1:3) = force(1)%kinetic(1:3, 1)
979 IF (debug_stress .AND. use_virial) stdeb = virial%pv_ekinetic
981 matrix_name=
"KINETIC ENERGY MATRIX", &
983 sab_nl=sab_orb, calculate_forces=.true., &
984 matrix_p=mpa(1)%matrix)
985 IF (debug_forces)
THEN
986 fodeb(1:3) = force(1)%kinetic(1:3, 1) - fodeb(1:3)
987 CALL para_env%sum(fodeb)
988 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*dT ", fodeb
990 IF (debug_stress .AND. use_virial)
THEN
991 stdeb = fconv*(virial%pv_ekinetic - stdeb)
992 CALL para_env%sum(stdeb)
993 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
997 IF (nspins == 2)
THEN
998 CALL dbcsr_add(mpa(1)%matrix, mpa(2)%matrix, 1.0_dp, -1.0_dp)
1003 CALL get_qs_env(qs_env=qs_env, matrix_s=matrix_s)
1005 DO ispin = 1, nspins
1006 ALLOCATE (scrm(ispin)%matrix)
1007 CALL dbcsr_create(scrm(ispin)%matrix, template=matrix_s(1)%matrix)
1008 CALL dbcsr_copy(scrm(ispin)%matrix, matrix_s(1)%matrix)
1009 CALL dbcsr_set(scrm(ispin)%matrix, 0.0_dp)
1012 CALL get_qs_env(qs_env, qs_kind_set=qs_kind_set, particle_set=particle_set, &
1013 atomic_kind_set=atomic_kind_set)
1015 NULLIFY (cell_to_index)
1016 ALLOCATE (matrix_p(nspins, 1), matrix_h(nspins, 1))
1017 DO ispin = 1, nspins
1018 matrix_p(ispin, 1)%matrix => mpa(ispin)%matrix
1019 matrix_h(ispin, 1)%matrix => scrm(ispin)%matrix
1021 matrix_h(1, 1)%matrix => scrm(1)%matrix
1023 IF (
ASSOCIATED(sac_ae))
THEN
1025 IF (debug_forces) fodeb(1:3) = force(1)%all_potential(1:3, 1)
1026 IF (debug_stress .AND. use_virial) stdeb = virial%pv_ppl
1027 CALL build_core_ae(matrix_h, matrix_p, force, virial, .true., use_virial, nder, &
1028 qs_kind_set, atomic_kind_set, particle_set, sab_orb, sac_ae, &
1029 nimages, cell_to_index)
1030 IF (debug_forces)
THEN
1031 fodeb(1:3) = force(1)%all_potential(1:3, 1) - fodeb(1:3)
1032 CALL para_env%sum(fodeb)
1033 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*dHae ", fodeb
1035 IF (debug_stress .AND. use_virial)
THEN
1036 stdeb = fconv*(virial%pv_ppl - stdeb)
1037 CALL para_env%sum(stdeb)
1038 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1043 IF (
ASSOCIATED(sac_ppl))
THEN
1045 IF (debug_forces) fodeb(1:3) = force(1)%gth_ppl(1:3, 1)
1046 IF (debug_stress .AND. use_virial) stdeb = virial%pv_ppl
1048 virial, .true., use_virial, nder, &
1049 qs_kind_set, atomic_kind_set, particle_set, &
1050 sab_orb, sac_ppl, nimages, cell_to_index,
"ORB")
1051 IF (debug_forces)
THEN
1052 fodeb(1:3) = force(1)%gth_ppl(1:3, 1) - fodeb(1:3)
1053 CALL para_env%sum(fodeb)
1054 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*dHppl ", fodeb
1056 IF (debug_stress .AND. use_virial)
THEN
1057 stdeb = fconv*(virial%pv_ppl - stdeb)
1058 CALL para_env%sum(stdeb)
1059 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1063 eps_ppnl = dft_control%qs_control%eps_ppnl
1064 IF (
ASSOCIATED(sap_ppnl))
THEN
1066 IF (debug_forces) fodeb(1:3) = force(1)%gth_ppnl(1:3, 1)
1067 IF (debug_stress .AND. use_virial) stdeb = virial%pv_ppnl
1069 virial, .true., use_virial, nder, &
1070 qs_kind_set, atomic_kind_set, particle_set, &
1071 sab_orb, sap_ppnl, eps_ppnl, nimages, cell_to_index,
"ORB")
1072 IF (debug_forces)
THEN
1073 fodeb(1:3) = force(1)%gth_ppnl(1:3, 1) - fodeb(1:3)
1074 CALL para_env%sum(fodeb)
1075 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*dHppnl ", fodeb
1077 IF (debug_stress .AND. use_virial)
THEN
1078 stdeb = fconv*(virial%pv_ppnl - stdeb)
1079 CALL para_env%sum(stdeb)
1080 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1087 IF (dft_control%qs_control%do_kg)
THEN
1089 CALL get_qs_env(qs_env=qs_env, kg_env=kg_env, dbcsr_dist=dbcsr_dist)
1091 IF (use_virial)
THEN
1092 pv_loc = virial%pv_virial
1095 IF (debug_forces) fodeb(1:3) = force(1)%kinetic(1:3, 1)
1096 IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
1097 CALL build_tnadd_mat(kg_env=kg_env, matrix_p=matrix_p, force=force, virial=virial, &
1098 calculate_forces=.true., use_virial=use_virial, &
1099 qs_kind_set=qs_kind_set, atomic_kind_set=atomic_kind_set, &
1100 particle_set=particle_set, sab_orb=sab_orb, dbcsr_dist=dbcsr_dist)
1101 IF (debug_forces)
THEN
1102 fodeb(1:3) = force(1)%kinetic(1:3, 1) - fodeb(1:3)
1103 CALL para_env%sum(fodeb)
1104 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*dTnadd ", fodeb
1106 IF (debug_stress .AND. use_virial)
THEN
1107 stdeb = fconv*(virial%pv_virial - stdeb)
1108 CALL para_env%sum(stdeb)
1109 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1114 IF (use_virial)
THEN
1115 virial%pv_ekinetic = virial%pv_ekinetic + (virial%pv_virial - pv_loc)
1121 DEALLOCATE (matrix_h)
1122 DEALLOCATE (matrix_p)
1130 DO ispin = 1, nspins
1131 ALLOCATE (scrm(ispin)%matrix)
1132 CALL dbcsr_create(scrm(ispin)%matrix, template=matrix_pz(1)%matrix)
1133 CALL dbcsr_copy(scrm(ispin)%matrix, matrix_pz(ispin)%matrix)
1134 CALL dbcsr_set(scrm(ispin)%matrix, 0.0_dp)
1137 IF (debug_forces)
THEN
1138 ALLOCATE (ftot2(3, natom))
1140 fodeb(1:3) = ftot2(1:3, 1) - ftot1(1:3, 1)
1141 CALL para_env%sum(fodeb)
1142 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*dHcore", fodeb
1144 IF (debug_stress .AND. use_virial)
THEN
1145 stdeb = fconv*(virial%pv_virial - sttot)
1146 CALL para_env%sum(stdeb)
1147 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1150 sttot2 = virial%pv_virial
1158 CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool, poisson_env=poisson_env)
1160 IF (dft_control%do_admm)
THEN
1162 xc_section => admm_env%xc_section_primary
1169 IF (gapw .OR. gapw_xc)
THEN
1170 NULLIFY (oce, sab_orb)
1171 CALL get_qs_env(qs_env=qs_env, oce=oce, sab_orb=sab_orb)
1173 NULLIFY (local_rho_set_gs)
1178 qs_kind_set, dft_control, para_env)
1179 CALL init_rho0(local_rho_set_gs, qs_env, dft_control%qs_control%gapw_control)
1182 qs_kind_set, oce, sab_orb, para_env)
1185 NULLIFY (local_rho_set_t)
1188 qs_kind_set, dft_control, para_env)
1189 CALL init_rho0(local_rho_set_t, qs_env, dft_control%qs_control%gapw_control, &
1193 qs_kind_set, oce, sab_orb, para_env)
1197 ALLOCATE (rho_r_gs(nspins), rho_g_gs(nspins))
1198 DO ispin = 1, nspins
1199 CALL auxbas_pw_pool%create_pw(rho_r_gs(ispin))
1200 CALL auxbas_pw_pool%create_pw(rho_g_gs(ispin))
1202 CALL auxbas_pw_pool%create_pw(rho_tot_gspace_gs)
1204 total_rho_gs = 0.0_dp
1205 CALL pw_zero(rho_tot_gspace_gs)
1206 DO ispin = 1, nspins
1208 rho=rho_r_gs(ispin), &
1209 rho_gspace=rho_g_gs(ispin), &
1210 soft_valid=(gapw .OR. gapw_xc), &
1211 total_rho=total_rho_gs(ispin))
1212 CALL pw_axpy(rho_g_gs(ispin), rho_tot_gspace_gs)
1217 CALL pw_axpy(local_rho_set_gs%rho0_mpole%rho0_s_gs, rho_tot_gspace_gs)
1218 IF (dft_control%qs_control%gapw_control%nopaw_as_gpw)
THEN
1219 CALL get_qs_env(qs_env=qs_env, rho_core=rho_core)
1220 CALL pw_axpy(rho_core, rho_tot_gspace_gs)
1223 CALL auxbas_pw_pool%create_pw(v_hartree_gspace_gs)
1224 CALL auxbas_pw_pool%create_pw(v_hartree_rspace_gs)
1225 NULLIFY (hartree_local_gs)
1228 CALL pw_poisson_solve(poisson_env, rho_tot_gspace_gs, hartree_gs, v_hartree_gspace_gs)
1229 CALL pw_transfer(v_hartree_gspace_gs, v_hartree_rspace_gs)
1230 CALL pw_scale(v_hartree_rspace_gs, v_hartree_rspace_gs%pw_grid%dvol)
1237 cpassert(.NOT. use_virial)
1238 IF (debug_forces) fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1)
1239 CALL vh_1c_gg_integrals(qs_env, hartree_gs, hartree_local_gs%ecoul_1c, local_rho_set_t, para_env, tddft=.true., &
1240 local_rho_set_2nd=local_rho_set_gs, core_2nd=.false.)
1243 local_rho_set=local_rho_set_t, local_rho_set_2nd=local_rho_set_gs)
1244 IF (debug_forces)
THEN
1245 fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1) - fodeb(1:3)
1246 CALL para_env%sum(fodeb)
1247 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: (T+Dz)*dVh[D^GS]PAWg0", fodeb
1250 IF (gapw .OR. gapw_xc)
THEN
1253 NULLIFY (local_rho_set_vxc)
1256 qs_kind_set, dft_control, para_env)
1258 qs_kind_set, oce, sab_orb, para_env)
1261 CALL calculate_vxc_atom(qs_env, .false., exc1=hartree_gs, xc_section_external=xc_section, &
1262 rho_atom_set_external=local_rho_set_vxc%rho_atom_set)
1266 CALL auxbas_pw_pool%create_pw(vhxc_rspace)
1270 IF (use_virial)
THEN
1271 pv_loc = virial%pv_virial
1274 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1275 IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
1276 IF (gapw .OR. gapw_xc)
THEN
1278 DO ispin = 1, nspins
1281 CALL pw_transfer(v_hartree_rspace_gs, vhxc_rspace)
1282 ELSEIF (gapw_xc)
THEN
1285 CALL integrate_v_rspace(v_rspace=vhxc_rspace, &
1286 hmat=scrm(ispin), pmat=mpa(ispin), &
1287 qs_env=qs_env, gapw=gapw, &
1288 calculate_forces=.true.)
1291 DO ispin = 1, nspins
1293 CALL pw_axpy(vxc_rspace(ispin), vhxc_rspace)
1294 CALL integrate_v_rspace(v_rspace=vhxc_rspace, &
1295 hmat=scrm(ispin), pmat=mpa(ispin), &
1296 qs_env=qs_env, gapw=(gapw .OR. gapw_xc), &
1297 calculate_forces=.true.)
1301 DO ispin = 1, nspins
1303 CALL pw_axpy(vxc_rspace(ispin), vhxc_rspace)
1304 CALL integrate_v_rspace(v_rspace=vhxc_rspace, &
1305 hmat=scrm(ispin), pmat=mpa(ispin), &
1306 qs_env=qs_env, gapw=gapw, calculate_forces=.true.)
1310 IF (debug_forces)
THEN
1311 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1312 CALL para_env%sum(fodeb)
1313 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: (T+Dz)*dVhxc[D^GS] ", fodeb
1315 IF (debug_stress .AND. use_virial)
THEN
1316 stdeb = fconv*(virial%pv_virial - pv_loc)
1317 CALL para_env%sum(stdeb)
1318 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1322 IF (gapw .OR. gapw_xc)
THEN
1325 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
1326 IF (gapw)
CALL update_ks_atom(qs_env, scrm, mpa, forces=.true., tddft=.false., &
1327 rho_atom_external=local_rho_set_gs%rho_atom_set)
1329 rho_atom_external=local_rho_set_vxc%rho_atom_set)
1330 IF (debug_forces)
THEN
1331 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
1332 CALL para_env%sum(fodeb)
1333 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: (T+Dz)*dVhxc[D^GS]PAW ", fodeb
1342 CALL auxbas_pw_pool%give_back_pw(v_hartree_gspace_gs)
1343 CALL auxbas_pw_pool%give_back_pw(v_hartree_rspace_gs)
1345 CALL auxbas_pw_pool%give_back_pw(rho_tot_gspace_gs)
1346 IF (
ASSOCIATED(rho_r_gs))
THEN
1347 DO ispin = 1, nspins
1348 CALL auxbas_pw_pool%give_back_pw(rho_r_gs(ispin))
1350 DEALLOCATE (rho_r_gs)
1352 IF (
ASSOCIATED(rho_g_gs))
THEN
1353 DO ispin = 1, nspins
1354 CALL auxbas_pw_pool%give_back_pw(rho_g_gs(ispin))
1356 DEALLOCATE (rho_g_gs)
1360 IF (
ASSOCIATED(vtau_rspace))
THEN
1361 cpassert(.NOT. (gapw .OR. gapw_xc))
1362 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1363 IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
1364 DO ispin = 1, nspins
1365 CALL integrate_v_rspace(v_rspace=vtau_rspace(ispin), &
1366 hmat=scrm(ispin), pmat=mpa(ispin), &
1367 qs_env=qs_env, gapw=(gapw .OR. gapw_xc), &
1368 calculate_forces=.true., compute_tau=.true.)
1370 IF (debug_forces)
THEN
1371 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1372 CALL para_env%sum(fodeb)
1373 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*dVxc_tau ", fodeb
1375 IF (debug_stress .AND. use_virial)
THEN
1376 stdeb = fconv*(virial%pv_virial - pv_loc)
1377 CALL para_env%sum(stdeb)
1378 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1382 CALL auxbas_pw_pool%give_back_pw(vhxc_rspace)
1385 IF (use_virial)
THEN
1386 virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
1391 IF (dft_control%qs_control%do_kg)
THEN
1396 IF (use_virial)
THEN
1397 pv_loc = virial%pv_virial
1400 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1403 ekin_mol=ekin_mol, &
1404 calc_force=.true., &
1405 do_kernel=.false., &
1407 IF (debug_forces)
THEN
1408 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1409 CALL para_env%sum(fodeb)
1410 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*dVkg ", fodeb
1412 IF (debug_stress .AND. use_virial)
THEN
1415 stdeb = 1.0_dp*fconv*ekin_mol
1416 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1419 stdeb = fconv*(virial%pv_virial - pv_loc)
1420 CALL para_env%sum(stdeb)
1421 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1424 stdeb = fconv*virial%pv_xc
1425 CALL para_env%sum(stdeb)
1426 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1429 IF (use_virial)
THEN
1431 virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
1442 ALLOCATE (rhoz_r(nspins), rhoz_g(nspins))
1443 DO ispin = 1, nspins
1444 CALL auxbas_pw_pool%create_pw(rhoz_r(ispin))
1445 CALL auxbas_pw_pool%create_pw(rhoz_g(ispin))
1447 CALL auxbas_pw_pool%create_pw(rhoz_tot_gspace)
1448 CALL auxbas_pw_pool%create_pw(zv_hartree_rspace)
1449 CALL auxbas_pw_pool%create_pw(zv_hartree_gspace)
1452 DO ispin = 1, nspins
1454 rho=rhoz_r(ispin), rho_gspace=rhoz_g(ispin), &
1456 CALL pw_axpy(rhoz_g(ispin), rhoz_tot_gspace)
1460 ALLOCATE (rhoz_r_xc(nspins), rhoz_g_xc(nspins))
1461 DO ispin = 1, nspins
1462 CALL auxbas_pw_pool%create_pw(rhoz_r_xc(ispin))
1463 CALL auxbas_pw_pool%create_pw(rhoz_g_xc(ispin))
1465 DO ispin = 1, nspins
1467 rho=rhoz_r_xc(ispin), rho_gspace=rhoz_g_xc(ispin), &
1472 IF (
ASSOCIATED(vtau_rspace))
THEN
1473 cpassert(.NOT. (gapw .OR. gapw_xc))
1476 ALLOCATE (tauz_r(nspins))
1477 CALL auxbas_pw_pool%create_pw(work_g)
1478 DO ispin = 1, nspins
1479 CALL auxbas_pw_pool%create_pw(tauz_r(ispin))
1481 rho=tauz_r(ispin), rho_gspace=work_g, &
1484 CALL auxbas_pw_pool%give_back_pw(work_g)
1489 IF (
PRESENT(rhopz_r))
THEN
1490 DO ispin = 1, nspins
1491 CALL pw_copy(rhoz_r(ispin), rhopz_r(ispin))
1498 IF (use_virial)
THEN
1501 CALL auxbas_pw_pool%create_pw(rho_tot_gspace)
1506 h_stress(:, :) = 0.0_dp
1514 density=rhoz_tot_gspace, &
1515 ehartree=ehartree, &
1516 vhartree=zv_hartree_gspace, &
1517 h_stress=h_stress, &
1518 aux_density=rho_tot_gspace)
1520 CALL auxbas_pw_pool%give_back_pw(rho_tot_gspace)
1523 virial%pv_ehartree = virial%pv_ehartree + 2.0_dp*h_stress/real(para_env%num_pe,
dp)
1524 virial%pv_virial = virial%pv_virial + 2.0_dp*h_stress/real(para_env%num_pe,
dp)
1526 IF (debug_stress)
THEN
1527 stdeb = -1.0_dp*fconv*ehartree
1528 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1530 stdeb = -1.0_dp*fconv*ehartree
1531 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1533 stdeb = fconv*(h_stress/real(para_env%num_pe,
dp))
1534 CALL para_env%sum(stdeb)
1535 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1537 stdeb = fconv*(h_stress/real(para_env%num_pe,
dp))
1538 CALL para_env%sum(stdeb)
1539 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1546 DO ispin = 1, nspins
1548 vxc_rspace(ispin)%pw_grid%dvol
1550 IF (
ASSOCIATED(vtau_rspace))
THEN
1551 DO ispin = 1, nspins
1553 vtau_rspace(ispin)%pw_grid%dvol
1558 IF (dft_control%qs_control%do_kg)
THEN
1561 exc = exc - ekin_mol
1565 IF (debug_stress)
THEN
1566 stdeb = -1.0_dp*fconv*exc
1567 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1576 CALL pw_axpy(local_rho_set_t%rho0_mpole%rho0_s_gs, rhoz_tot_gspace)
1578 CALL pw_poisson_solve(poisson_env, rhoz_tot_gspace, ehartree, zv_hartree_gspace)
1581 IF (gapw .OR. gapw_xc)
THEN
1585 IF (debug_forces) fodeb(1:3) = force(1)%rho_core(1:3, 1)
1586 IF (debug_stress .AND. use_virial) stdeb = virial%pv_ehartree
1587 CALL pw_transfer(zv_hartree_gspace, zv_hartree_rspace)
1588 CALL pw_scale(zv_hartree_rspace, zv_hartree_rspace%pw_grid%dvol)
1590 CALL integrate_v_core_rspace(zv_hartree_rspace, qs_env)
1591 IF (debug_forces)
THEN
1592 fodeb(1:3) = force(1)%rho_core(1:3, 1) - fodeb(1:3)
1593 CALL para_env%sum(fodeb)
1594 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Vh(rhoz)*dncore ", fodeb
1596 IF (debug_stress .AND. use_virial)
THEN
1597 stdeb = fconv*(virial%pv_ehartree - stdeb)
1598 CALL para_env%sum(stdeb)
1599 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1605 CALL get_qs_env(qs_env=qs_env, rho_xc=rho_xc)
1609 IF (dft_control%do_admm)
THEN
1611 xc_section => admm_env%xc_section_primary
1616 IF (use_virial)
THEN
1617 virial%pv_xc = 0.0_dp
1620 NULLIFY (v_xc, v_xc_tau)
1623 rho=rho_xc, rho1_r=rhoz_r_xc, rho1_g=rhoz_g_xc, tau1_r=tauz_r_xc, &
1624 xc_section=xc_section, compute_virial=use_virial, virial_xc=virial%pv_xc)
1627 rho=rho, rho1_r=rhoz_r, rho1_g=rhoz_g, tau1_r=tauz_r, &
1628 xc_section=xc_section, compute_virial=use_virial, virial_xc=virial%pv_xc)
1631 IF (gapw .OR. gapw_xc)
THEN
1633 NULLIFY (local_rho_set_t)
1636 qs_kind_set, dft_control, para_env)
1637 CALL init_rho0(local_rho_set_t, qs_env, dft_control%qs_control%gapw_control, &
1641 qs_kind_set, oce, sab_orb, para_env)
1643 NULLIFY (local_rho_set_gs)
1646 qs_kind_set, dft_control, para_env)
1647 CALL init_rho0(local_rho_set_gs, qs_env, dft_control%qs_control%gapw_control)
1650 qs_kind_set, oce, sab_orb, para_env)
1653 ALLOCATE (rho_r_t(nspins), rho_g_t(nspins))
1654 DO ispin = 1, nspins
1655 CALL auxbas_pw_pool%create_pw(rho_r_t(ispin))
1656 CALL auxbas_pw_pool%create_pw(rho_g_t(ispin))
1658 CALL auxbas_pw_pool%create_pw(rho_tot_gspace_t)
1659 total_rho_t = 0.0_dp
1660 CALL pw_zero(rho_tot_gspace_t)
1661 DO ispin = 1, nspins
1663 rho=rho_r_t(ispin), &
1664 rho_gspace=rho_g_t(ispin), &
1666 total_rho=total_rho_t(ispin))
1667 CALL pw_axpy(rho_g_t(ispin), rho_tot_gspace_t)
1671 CALL pw_axpy(local_rho_set_t%rho0_mpole%rho0_s_gs, rho_tot_gspace_t)
1673 CALL auxbas_pw_pool%create_pw(v_hartree_gspace_t)
1674 CALL auxbas_pw_pool%create_pw(v_hartree_rspace_t)
1675 NULLIFY (hartree_local_t)
1678 CALL pw_poisson_solve(poisson_env, rho_tot_gspace_t, hartree_t, v_hartree_gspace_t)
1679 CALL pw_transfer(v_hartree_gspace_t, v_hartree_rspace_t)
1680 CALL pw_scale(v_hartree_rspace_t, v_hartree_rspace_t%pw_grid%dvol)
1682 IF (debug_forces) fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1)
1683 CALL vh_1c_gg_integrals(qs_env, hartree_t, hartree_local_t%ecoul_1c, local_rho_set_gs, para_env, tddft=.false., &
1684 local_rho_set_2nd=local_rho_set_t, core_2nd=.true.)
1686 local_rho_set=local_rho_set_gs, local_rho_set_2nd=local_rho_set_t)
1687 IF (debug_forces)
THEN
1688 fodeb(1:3) = force(1)%g0s_Vh_elec(1:3, 1) - fodeb(1:3)
1689 CALL para_env%sum(fodeb)
1690 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Vh(T)*dncore PAWg0", fodeb
1695 IF (gapw .OR. gapw_xc)
THEN
1699 NULLIFY (local_rho_set_f)
1702 qs_kind_set, dft_control, para_env)
1704 qs_kind_set, oce, sab_orb, para_env)
1708 local_rho_set_f%rho_atom_set, &
1709 qs_env, xc_section, para_env, &
1710 do_tddft=.false., do_triplet=.false.)
1715 IF (use_virial)
THEN
1716 virial%pv_exc = virial%pv_exc + virial%pv_xc
1717 virial%pv_virial = virial%pv_virial + virial%pv_xc
1720 IF (debug_stress .AND. use_virial)
THEN
1721 stdeb = 1.0_dp*fconv*virial%pv_xc
1722 CALL para_env%sum(stdeb)
1723 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1728 IF (use_virial)
THEN
1729 pv_loc = virial%pv_virial
1734 IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
1736 DO ispin = 1, nspins
1737 CALL pw_scale(v_xc(ispin), v_xc(ispin)%pw_grid%dvol)
1739 IF ((.NOT. (gapw)) .AND. (.NOT. gapw_xc))
THEN
1740 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1741 DO ispin = 1, nspins
1742 CALL pw_axpy(zv_hartree_rspace, v_xc(ispin))
1743 CALL integrate_v_rspace(qs_env=qs_env, &
1744 v_rspace=v_xc(ispin), &
1745 hmat=matrix_hz(ispin), &
1746 pmat=matrix_p(ispin, 1), &
1748 calculate_forces=.true.)
1750 IF (debug_forces)
THEN
1751 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1752 CALL para_env%sum(fodeb)
1753 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pin*dKhxc*rhoz ", fodeb
1756 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1758 DO ispin = 1, nspins
1759 CALL integrate_v_rspace(qs_env=qs_env, &
1760 v_rspace=v_xc(ispin), &
1761 hmat=matrix_hz(ispin), &
1762 pmat=matrix_p(ispin, 1), &
1764 calculate_forces=.true.)
1768 DO ispin = 1, nspins
1771 CALL pw_axpy(v_hartree_rspace_t, v_xc(ispin))
1772 ELSEIF (gapw_xc)
THEN
1773 CALL pw_axpy(zv_hartree_rspace, v_xc(ispin))
1775 CALL integrate_v_rspace(qs_env=qs_env, &
1776 v_rspace=v_xc(ispin), &
1777 hmat=matrix_ht(ispin), &
1778 pmat=matrix_p(ispin, 1), &
1780 calculate_forces=.true.)
1782 IF (debug_forces)
THEN
1783 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1784 CALL para_env%sum(fodeb)
1785 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pin*dKhxc*rhoz ", fodeb
1789 IF (gapw .OR. gapw_xc)
THEN
1792 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
1793 CALL update_ks_atom(qs_env, matrix_hz, matrix_p, forces=.true., tddft=.false., &
1794 rho_atom_external=local_rho_set_f%rho_atom_set)
1795 IF (debug_forces)
THEN
1796 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
1797 CALL para_env%sum(fodeb)
1798 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: P^GS*dKxc*(Dz+T) PAW", fodeb
1803 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
1804 CALL update_ks_atom(qs_env, matrix_ht, matrix_p, forces=.true., tddft=.false., &
1805 rho_atom_external=local_rho_set_t%rho_atom_set)
1806 IF (debug_forces)
THEN
1807 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
1808 CALL para_env%sum(fodeb)
1809 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: P^GS*dKh*(Dz+T) PAW", fodeb
1813 DO ispin = 1, nspins
1814 CALL dbcsr_add(matrix_hz(ispin)%matrix, matrix_ht(ispin)%matrix, 1.0_dp, 1.0_dp)
1825 CALL auxbas_pw_pool%give_back_pw(v_hartree_gspace_t)
1826 CALL auxbas_pw_pool%give_back_pw(v_hartree_rspace_t)
1828 CALL auxbas_pw_pool%give_back_pw(rho_tot_gspace_t)
1829 DO ispin = 1, nspins
1830 CALL auxbas_pw_pool%give_back_pw(rho_r_t(ispin))
1831 CALL auxbas_pw_pool%give_back_pw(rho_g_t(ispin))
1833 DEALLOCATE (rho_r_t, rho_g_t)
1836 IF (debug_stress .AND. use_virial)
THEN
1837 stdeb = fconv*(virial%pv_virial - stdeb)
1838 CALL para_env%sum(stdeb)
1839 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1843 IF (
ASSOCIATED(v_xc_tau))
THEN
1844 cpassert(.NOT. (gapw .OR. gapw_xc))
1845 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1846 IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
1847 DO ispin = 1, nspins
1848 CALL pw_scale(v_xc_tau(ispin), v_xc_tau(ispin)%pw_grid%dvol)
1849 CALL integrate_v_rspace(qs_env=qs_env, &
1850 v_rspace=v_xc_tau(ispin), &
1851 hmat=matrix_hz(ispin), &
1852 pmat=matrix_p(ispin, 1), &
1853 compute_tau=.true., &
1854 gapw=(gapw .OR. gapw_xc), &
1855 calculate_forces=.true.)
1857 IF (debug_forces)
THEN
1858 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1859 CALL para_env%sum(fodeb)
1860 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pin*dKtau*tauz ", fodeb
1863 IF (debug_stress .AND. use_virial)
THEN
1864 stdeb = fconv*(virial%pv_virial - stdeb)
1865 CALL para_env%sum(stdeb)
1866 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1870 IF (use_virial)
THEN
1871 virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
1876 IF (dft_control%qs_control%do_kg)
THEN
1879 IF (use_virial)
THEN
1880 pv_loc = virial%pv_virial
1883 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
1884 IF (use_virial) virial%pv_xc = 0.0_dp
1886 ks_matrix=matrix_hz, &
1887 ekin_mol=ekin_mol, &
1888 calc_force=.true., &
1892 IF (debug_forces)
THEN
1893 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
1894 CALL para_env%sum(fodeb)
1895 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pin*d(Kkg)*rhoz ", fodeb
1897 IF (debug_stress .AND. use_virial)
THEN
1898 stdeb = fconv*(virial%pv_virial - pv_loc)
1899 CALL para_env%sum(stdeb)
1900 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1903 stdeb = fconv*(virial%pv_xc)
1904 CALL para_env%sum(stdeb)
1905 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
1910 IF (use_virial)
THEN
1912 virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
1915 virial%pv_exc = virial%pv_exc - virial%pv_xc
1916 virial%pv_virial = virial%pv_virial - virial%pv_xc
1917 virial%pv_xc = 0.0_dp
1921 CALL auxbas_pw_pool%give_back_pw(rhoz_tot_gspace)
1922 CALL auxbas_pw_pool%give_back_pw(zv_hartree_gspace)
1923 CALL auxbas_pw_pool%give_back_pw(zv_hartree_rspace)
1924 DO ispin = 1, nspins
1925 CALL auxbas_pw_pool%give_back_pw(rhoz_r(ispin))
1926 CALL auxbas_pw_pool%give_back_pw(rhoz_g(ispin))
1927 CALL auxbas_pw_pool%give_back_pw(v_xc(ispin))
1929 DEALLOCATE (rhoz_r, rhoz_g, v_xc)
1931 DO ispin = 1, nspins
1932 CALL auxbas_pw_pool%give_back_pw(rhoz_r_xc(ispin))
1933 CALL auxbas_pw_pool%give_back_pw(rhoz_g_xc(ispin))
1935 DEALLOCATE (rhoz_r_xc, rhoz_g_xc)
1937 IF (
ASSOCIATED(v_xc_tau))
THEN
1938 DO ispin = 1, nspins
1939 CALL auxbas_pw_pool%give_back_pw(tauz_r(ispin))
1940 CALL auxbas_pw_pool%give_back_pw(v_xc_tau(ispin))
1942 DEALLOCATE (tauz_r, v_xc_tau)
1944 IF (debug_forces)
THEN
1945 ALLOCATE (ftot3(3, natom))
1947 fodeb(1:3) = ftot3(1:3, 1) - ftot2(1:3, 1)
1948 CALL para_env%sum(fodeb)
1949 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pin*V(rhoz)", fodeb
1958 IF (dft_control%do_admm)
THEN
1960 exc_aux_fit = 0.0_dp
1964 NULLIFY (mpz, mhz, mhx, mhy)
1968 CALL get_admm_env(admm_env, rho_aux_fit=rho_aux_fit, matrix_s_aux_fit=scrm, &
1969 task_list_aux_fit=task_list_aux_fit)
1971 NULLIFY (mpz, mhz, mhx, mhy)
1975 DO ispin = 1, nspins
1976 ALLOCATE (mhx(ispin, 1)%matrix)
1977 CALL dbcsr_create(mhx(ispin, 1)%matrix, template=scrm(1)%matrix)
1978 CALL dbcsr_copy(mhx(ispin, 1)%matrix, scrm(1)%matrix)
1979 CALL dbcsr_set(mhx(ispin, 1)%matrix, 0.0_dp)
1980 ALLOCATE (mhy(ispin, 1)%matrix)
1981 CALL dbcsr_create(mhy(ispin, 1)%matrix, template=scrm(1)%matrix)
1982 CALL dbcsr_copy(mhy(ispin, 1)%matrix, scrm(1)%matrix)
1983 CALL dbcsr_set(mhy(ispin, 1)%matrix, 0.0_dp)
1984 ALLOCATE (mpz(ispin, 1)%matrix)
1986 CALL dbcsr_create(mpz(ispin, 1)%matrix, template=p_env%p1_admm(ispin)%matrix)
1987 CALL dbcsr_copy(mpz(ispin, 1)%matrix, p_env%p1_admm(ispin)%matrix)
1988 CALL dbcsr_add(mpz(ispin, 1)%matrix, ex_env%matrix_pe_admm(ispin)%matrix, &
1991 CALL dbcsr_create(mpz(ispin, 1)%matrix, template=matrix_pz_admm(ispin)%matrix)
1992 CALL dbcsr_copy(mpz(ispin, 1)%matrix, matrix_pz_admm(ispin)%matrix)
1996 xc_section => admm_env%xc_section_aux
1999 IF (use_virial)
THEN
2000 pv_loc = virial%pv_virial
2003 basis_type =
"AUX_FIT"
2004 task_list => task_list_aux_fit
2005 IF (admm_env%do_gapw)
THEN
2006 basis_type =
"AUX_FIT_SOFT"
2007 task_list => admm_env%admm_gapw_env%task_list
2010 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
2011 IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
2012 DO ispin = 1, nspins
2013 CALL integrate_v_rspace(v_rspace=vadmm_rspace(ispin), &
2014 hmat=mhx(ispin, 1), pmat=mpz(ispin, 1), &
2015 qs_env=qs_env, calculate_forces=.true., &
2016 basis_type=basis_type, task_list_external=task_list)
2018 IF (debug_forces)
THEN
2019 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
2020 CALL para_env%sum(fodeb)
2021 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*Vxc(rho_admm)", fodeb
2023 IF (debug_stress .AND. use_virial)
THEN
2024 stdeb = fconv*(virial%pv_virial - pv_loc)
2025 CALL para_env%sum(stdeb)
2026 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
2030 IF (use_virial)
THEN
2031 virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
2034 IF (admm_env%do_gapw)
THEN
2036 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
2037 CALL update_ks_atom(qs_env, mhx(:, 1), mpz(:, 1), forces=.true., tddft=.false., &
2038 rho_atom_external=admm_env%admm_gapw_env%local_rho_set%rho_atom_set, &
2039 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
2040 oce_external=admm_env%admm_gapw_env%oce, &
2041 sab_external=sab_aux_fit)
2042 IF (debug_forces)
THEN
2043 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
2044 CALL para_env%sum(fodeb)
2045 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*Vxc(rho_admm)PAW", fodeb
2049 NULLIFY (rho_g_aux, rho_r_aux, tau_r_aux)
2050 CALL qs_rho_get(rho_aux_fit, rho_r=rho_r_aux, rho_g=rho_g_aux, tau_r=tau_r_aux)
2052 NULLIFY (rhoz_g_aux, rhoz_r_aux)
2053 ALLOCATE (rhoz_r_aux(nspins), rhoz_g_aux(nspins))
2054 DO ispin = 1, nspins
2055 CALL auxbas_pw_pool%create_pw(rhoz_r_aux(ispin))
2056 CALL auxbas_pw_pool%create_pw(rhoz_g_aux(ispin))
2058 DO ispin = 1, nspins
2060 rho=rhoz_r_aux(ispin), rho_gspace=rhoz_g_aux(ispin), &
2061 basis_type=basis_type, task_list_external=task_list)
2065 IF (use_virial)
THEN
2069 DO ispin = 1, nspins
2070 exc_aux_fit = exc_aux_fit +
pw_integral_ab(rhoz_r_aux(ispin), vadmm_rspace(ispin))/ &
2071 vadmm_rspace(ispin)%pw_grid%dvol
2074 IF (debug_stress)
THEN
2075 stdeb = -1.0_dp*fconv*exc_aux_fit
2076 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T43,2(1X,ES19.11))") &
2084 IF (use_virial) virial%pv_xc = 0.0_dp
2090 rho1_r=rhoz_r_aux, &
2091 rho1_g=rhoz_g_aux, &
2093 xc_section=xc_section, &
2094 compute_virial=use_virial, &
2095 virial_xc=virial%pv_xc)
2098 IF (use_virial)
THEN
2099 virial%pv_exc = virial%pv_exc + virial%pv_xc
2100 virial%pv_virial = virial%pv_virial + virial%pv_xc
2103 IF (debug_stress .AND. use_virial)
THEN
2104 stdeb = 1.0_dp*fconv*virial%pv_xc
2105 CALL para_env%sum(stdeb)
2106 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
2110 CALL qs_rho_get(rho_aux_fit, rho_ao_kp=matrix_p)
2112 IF (use_virial)
THEN
2113 virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
2115 IF (debug_forces) fodeb(1:3) = force(1)%rho_elec(1:3, 1)
2116 IF (debug_stress .AND. use_virial) stdeb = virial%pv_virial
2117 DO ispin = 1, nspins
2118 CALL dbcsr_set(mhy(ispin, 1)%matrix, 0.0_dp)
2119 CALL pw_scale(v_xc(ispin), v_xc(ispin)%pw_grid%dvol)
2120 CALL integrate_v_rspace(qs_env=qs_env, v_rspace=v_xc(ispin), &
2121 hmat=mhy(ispin, 1), pmat=matrix_p(ispin, 1), &
2122 calculate_forces=.true., &
2123 basis_type=basis_type, task_list_external=task_list)
2125 IF (debug_forces)
THEN
2126 fodeb(1:3) = force(1)%rho_elec(1:3, 1) - fodeb(1:3)
2127 CALL para_env%sum(fodeb)
2128 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pin*dK*rhoz_admm ", fodeb
2130 IF (debug_stress .AND. use_virial)
THEN
2131 stdeb = fconv*(virial%pv_virial - pv_loc)
2132 CALL para_env%sum(stdeb)
2133 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
2137 IF (use_virial)
THEN
2138 virial%pv_ehartree = virial%pv_ehartree + (virial%pv_virial - pv_loc)
2140 DO ispin = 1, nspins
2141 CALL auxbas_pw_pool%give_back_pw(v_xc(ispin))
2142 CALL auxbas_pw_pool%give_back_pw(rhoz_r_aux(ispin))
2143 CALL auxbas_pw_pool%give_back_pw(rhoz_g_aux(ispin))
2145 DEALLOCATE (v_xc, rhoz_r_aux, rhoz_g_aux)
2147 IF (admm_env%do_gapw)
THEN
2150 admm_env%admm_gapw_env%admm_kind_set, dft_control, para_env)
2152 admm_env%admm_gapw_env%admm_kind_set, &
2153 admm_env%admm_gapw_env%oce, sab_aux_fit, para_env)
2155 do_rho0=.false., kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
2158 local_rhoz_set_admm%rho_atom_set, &
2159 qs_env, xc_section, para_env, do_tddft=.false., do_triplet=.false., &
2160 kind_set_external=admm_env%admm_gapw_env%admm_kind_set)
2162 IF (debug_forces) fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1)
2163 CALL update_ks_atom(qs_env, mhy(:, 1), matrix_p(:, 1), forces=.true., tddft=.false., &
2164 rho_atom_external=local_rhoz_set_admm%rho_atom_set, &
2165 kind_set_external=admm_env%admm_gapw_env%admm_kind_set, &
2166 oce_external=admm_env%admm_gapw_env%oce, &
2167 sab_external=sab_aux_fit)
2168 IF (debug_forces)
THEN
2169 fodeb(1:3) = force(1)%Vhxc_atom(1:3, 1) - fodeb(1:3)
2170 CALL para_env%sum(fodeb)
2171 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pin*dK*rhoz_admm[PAW] ", fodeb
2176 nao = admm_env%nao_orb
2177 nao_aux = admm_env%nao_aux_fit
2179 CALL dbcsr_create(dbwork, template=matrix_hz(1)%matrix)
2180 DO ispin = 1, nspins
2182 admm_env%work_aux_orb, nao)
2184 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
2185 admm_env%work_orb_orb)
2186 CALL dbcsr_copy(dbwork, matrix_hz(ispin)%matrix)
2187 CALL dbcsr_set(dbwork, 0.0_dp)
2189 CALL dbcsr_add(matrix_hz(ispin)%matrix, dbwork, 1.0_dp, 1.0_dp)
2191 CALL dbcsr_release(dbwork)
2206 cpassert(n_rep_hf == 1)
2210 IF (hfx_treat_lsd_in_core) mspin = nspins
2211 IF (use_virial) virial%pv_fock_4c = 0.0_dp
2213 CALL get_qs_env(qs_env=qs_env, rho=rho, x_data=x_data, &
2214 s_mstruct_changed=s_mstruct_changed)
2215 distribute_fock_matrix = .true.
2220 IF (dft_control%do_admm)
THEN
2221 CALL get_qs_env(qs_env=qs_env, admm_env=admm_env)
2222 CALL get_admm_env(admm_env, matrix_s_aux_fit=scrm, rho_aux_fit=rho_aux_fit)
2223 CALL qs_rho_get(rho_aux_fit, rho_ao_kp=matrix_p)
2224 NULLIFY (mpz, mhz, mpd, mhd)
2229 DO ispin = 1, nspins
2230 ALLOCATE (mhz(ispin, 1)%matrix, mhd(ispin, 1)%matrix)
2231 CALL dbcsr_create(mhz(ispin, 1)%matrix, template=scrm(1)%matrix)
2232 CALL dbcsr_create(mhd(ispin, 1)%matrix, template=scrm(1)%matrix)
2233 CALL dbcsr_copy(mhz(ispin, 1)%matrix, scrm(1)%matrix)
2234 CALL dbcsr_copy(mhd(ispin, 1)%matrix, scrm(1)%matrix)
2235 CALL dbcsr_set(mhz(ispin, 1)%matrix, 0.0_dp)
2236 CALL dbcsr_set(mhd(ispin, 1)%matrix, 0.0_dp)
2237 ALLOCATE (mpz(ispin, 1)%matrix)
2239 CALL dbcsr_create(mpz(ispin, 1)%matrix, template=scrm(1)%matrix)
2240 CALL dbcsr_copy(mpz(ispin, 1)%matrix, p_env%p1_admm(ispin)%matrix)
2241 CALL dbcsr_add(mpz(ispin, 1)%matrix, ex_env%matrix_pe_admm(ispin)%matrix, &
2244 CALL dbcsr_create(mpz(ispin, 1)%matrix, template=scrm(1)%matrix)
2245 CALL dbcsr_copy(mpz(ispin, 1)%matrix, matrix_pz_admm(ispin)%matrix)
2247 mpd(ispin, 1)%matrix => matrix_p(ispin, 1)%matrix
2250 IF (x_data(1, 1)%do_hfx_ri)
THEN
2253 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhz, eh1, rho_ao=mpz, &
2254 geometry_did_change=s_mstruct_changed, nspins=nspins, &
2255 hf_fraction=x_data(1, 1)%general_parameter%fraction)
2258 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhd, eh1, rho_ao=mpd, &
2259 geometry_did_change=s_mstruct_changed, nspins=nspins, &
2260 hf_fraction=x_data(1, 1)%general_parameter%fraction)
2266 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
2272 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
2278 cpassert(
ASSOCIATED(admm_env%work_aux_orb))
2279 cpassert(
ASSOCIATED(admm_env%work_orb_orb))
2280 nao = admm_env%nao_orb
2281 nao_aux = admm_env%nao_aux_fit
2283 CALL dbcsr_create(dbwork, template=matrix_hz(1)%matrix)
2284 DO ispin = 1, nspins
2286 admm_env%work_aux_orb, nao)
2288 1.0_dp, admm_env%A, admm_env%work_aux_orb, 0.0_dp, &
2289 admm_env%work_orb_orb)
2290 CALL dbcsr_copy(dbwork, matrix_hz(ispin)%matrix)
2291 CALL dbcsr_set(dbwork, 0.0_dp)
2293 CALL dbcsr_add(matrix_hz(ispin)%matrix, dbwork, 1.0_dp, 1.0_dp)
2295 CALL dbcsr_release(dbwork)
2298 IF (debug_forces) fodeb(1:3) = force(1)%overlap_admm(1:3, 1)
2299 IF (
ASSOCIATED(mhx) .AND.
ASSOCIATED(mhy))
THEN
2300 DO ispin = 1, nspins
2301 CALL dbcsr_add(mhd(ispin, 1)%matrix, mhx(ispin, 1)%matrix, 1.0_dp, 1.0_dp)
2302 CALL dbcsr_add(mhz(ispin, 1)%matrix, mhy(ispin, 1)%matrix, 1.0_dp, 1.0_dp)
2308 IF (debug_forces)
THEN
2309 fodeb(1:3) = force(1)%overlap_admm(1:3, 1) - fodeb(1:3)
2310 CALL para_env%sum(fodeb)
2311 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*hfx*S' ", fodeb
2316 IF (
ASSOCIATED(mhx) .AND.
ASSOCIATED(mhy))
THEN
2325 ALLOCATE (mpz(nspins, 1), mhz(nspins, 1))
2326 DO ispin = 1, nspins
2327 mhz(ispin, 1)%matrix => matrix_hz(ispin)%matrix
2328 mpz(ispin, 1)%matrix => mpa(ispin)%matrix
2331 IF (x_data(1, 1)%do_hfx_ri)
THEN
2334 CALL hfx_ri_update_ks(qs_env, x_data(1, 1)%ri_data, mhz, eh1, rho_ao=mpz, &
2335 geometry_did_change=s_mstruct_changed, nspins=nspins, &
2336 hf_fraction=x_data(1, 1)%general_parameter%fraction)
2341 para_env, s_mstruct_changed, 1, distribute_fock_matrix, &
2345 DEALLOCATE (mhz, mpz)
2353 IF (debug_forces) fodeb(1:3) = force(1)%fock_4c(1:3, 1)
2354 IF (dft_control%do_admm)
THEN
2358 CALL qs_rho_get(rho_aux_fit, rho_ao_kp=matrix_p)
2359 NULLIFY (matrix_pza)
2361 DO ispin = 1, nspins
2362 ALLOCATE (matrix_pza(ispin)%matrix)
2364 CALL dbcsr_create(matrix_pza(ispin)%matrix, template=p_env%p1_admm(ispin)%matrix)
2365 CALL dbcsr_copy(matrix_pza(ispin)%matrix, p_env%p1_admm(ispin)%matrix)
2366 CALL dbcsr_add(matrix_pza(ispin)%matrix, ex_env%matrix_pe_admm(ispin)%matrix, &
2369 CALL dbcsr_create(matrix_pza(ispin)%matrix, template=matrix_pz_admm(ispin)%matrix)
2370 CALL dbcsr_copy(matrix_pza(ispin)%matrix, matrix_pz_admm(ispin)%matrix)
2373 IF (x_data(1, 1)%do_hfx_ri)
THEN
2376 x_data(1, 1)%general_parameter%fraction, &
2377 rho_ao=matrix_p, rho_ao_resp=matrix_pza, &
2378 use_virial=use_virial, resp_only=resp_only)
2381 1, use_virial, resp_only=resp_only)
2389 IF (x_data(1, 1)%do_hfx_ri)
THEN
2392 x_data(1, 1)%general_parameter%fraction, &
2393 rho_ao=matrix_p, rho_ao_resp=mpa, &
2394 use_virial=use_virial, resp_only=resp_only)
2397 1, use_virial, resp_only=resp_only)
2401 IF (use_virial)
THEN
2402 virial%pv_exx = virial%pv_exx - virial%pv_fock_4c
2403 virial%pv_virial = virial%pv_virial - virial%pv_fock_4c
2404 virial%pv_calculate = .false.
2407 IF (debug_forces)
THEN
2408 fodeb(1:3) = force(1)%fock_4c(1:3, 1) - fodeb(1:3)
2409 CALL para_env%sum(fodeb)
2410 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Pz*hfx ", fodeb
2412 IF (debug_stress .AND. use_virial)
THEN
2413 stdeb = -1.0_dp*fconv*virial%pv_fock_4c
2414 CALL para_env%sum(stdeb)
2415 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
2422 IF (use_virial)
THEN
2424 zehartree = zehartree + 2.0_dp*ehartree
2427 IF (dft_control%do_admm)
THEN
2428 zexc_aux_fit = zexc_aux_fit + exc_aux_fit
2435 IF (dft_control%qs_control%do_ls_scf)
THEN
2437 eps_filter = dft_control%qs_control%eps_filter_matrix
2438 CALL calculate_whz_ao_matrix(qs_env, matrix_hz, matrix_wz, eps_filter)
2441 matrix_wz => p_env%w1
2444 IF (nspins == 1) focc = 2.0_dp
2446 DO ispin = 1, nspins
2447 CALL get_mo_set(mo_set=mos(ispin), homo=nocc)
2449 matrix_wz(ispin)%matrix, focc, nocc)
2452 IF (nspins == 2)
THEN
2453 CALL dbcsr_add(matrix_wz(1)%matrix, matrix_wz(2)%matrix, &
2454 alpha_scalar=1.0_dp, beta_scalar=1.0_dp)
2457 IF (debug_forces) fodeb(1:3) = force(1)%overlap(1:3, 1)
2458 IF (debug_stress .AND. use_virial) stdeb = virial%pv_overlap
2461 matrix_name=
"OVERLAP MATRIX", &
2462 basis_type_a=
"ORB", basis_type_b=
"ORB", &
2463 sab_nl=sab_orb, calculate_forces=.true., &
2464 matrix_p=matrix_wz(1)%matrix)
2466 IF (
SIZE(matrix_wz, 1) == 2)
THEN
2467 CALL dbcsr_add(matrix_wz(1)%matrix, matrix_wz(2)%matrix, &
2468 alpha_scalar=1.0_dp, beta_scalar=-1.0_dp)
2471 IF (debug_forces)
THEN
2472 fodeb(1:3) = force(1)%overlap(1:3, 1) - fodeb(1:3)
2473 CALL para_env%sum(fodeb)
2474 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Wz*dS ", fodeb
2476 IF (debug_stress .AND. use_virial)
THEN
2477 stdeb = fconv*(virial%pv_overlap - stdeb)
2478 CALL para_env%sum(stdeb)
2479 IF (iounit > 0)
WRITE (unit=iounit, fmt=
"(T2,A,T41,2(1X,ES19.11))") &
2484 IF (debug_forces)
THEN
2486 fodeb(1:3) = ftot2(1:3, 1) - ftot1(1:3, 1)
2487 CALL para_env%sum(fodeb)
2488 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Response Force", fodeb
2489 fodeb(1:3) = ftot2(1:3, 1)
2490 CALL para_env%sum(fodeb)
2491 IF (iounit > 0)
WRITE (iounit,
"(T3,A,T33,3F16.8)")
"DEBUG:: Total Force ", fodeb
2492 DEALLOCATE (ftot1, ftot2, ftot3)
2500 CALL timestop(handle)