Line data Source code
1 : !--------------------------------------------------------------------------------------------------!
2 : ! CP2K: A general program to perform molecular dynamics simulations !
3 : ! Copyright 2000-2026 CP2K developers group <https://cp2k.org> !
4 : ! !
5 : ! SPDX-License-Identifier: GPL-2.0-or-later !
6 : !--------------------------------------------------------------------------------------------------!
7 :
8 : ! **************************************************************************************************
9 : !> \brief routines that build the integrals of the Vxc potential calculated
10 : !> for the atomic density in the basis set of spherical primitives
11 : ! **************************************************************************************************
12 : MODULE qs_vxc_atom
13 : USE atomic_kind_types, ONLY: atomic_kind_type,&
14 : get_atomic_kind
15 : USE basis_set_types, ONLY: get_gto_basis_set,&
16 : gto_basis_set_type
17 : USE cell_types, ONLY: cell_type,&
18 : pbc
19 : USE cp_array_utils, ONLY: cp_3d_r_cp_type
20 : USE cp_control_types, ONLY: dft_control_type
21 : USE cp_log_handling, ONLY: cp_logger_get_default_io_unit
22 : USE external_potential_types, ONLY: get_potential,&
23 : gth_potential_type,&
24 : sgp_potential_type
25 : USE input_constants, ONLY: cdft_alpha_constraint,&
26 : cdft_beta_constraint,&
27 : cdft_charge_constraint,&
28 : cdft_magnetization_constraint,&
29 : xc_none
30 : USE input_section_types, ONLY: section_get_rval,&
31 : section_vals_get_subs_vals,&
32 : section_vals_type,&
33 : section_vals_val_get
34 : USE kinds, ONLY: dp,&
35 : int_8
36 : USE memory_utilities, ONLY: reallocate
37 : USE message_passing, ONLY: mp_para_env_type
38 : USE orbital_pointers, ONLY: indso,&
39 : nsoset
40 : USE particle_types, ONLY: particle_type
41 : USE paw_basis_types, ONLY: get_paw_basis_info
42 : USE pw_env_types, ONLY: pw_env_get,&
43 : pw_env_type
44 : USE pw_grid_types, ONLY: pw_grid_type
45 : USE pw_methods, ONLY: pw_axpy
46 : USE pw_pool_types, ONLY: pw_pool_type
47 : USE pw_types, ONLY: pw_c1d_gs_type,&
48 : pw_r3d_rs_type
49 : USE qs_cdft_grid, ONLY: cdft_point_context_create,&
50 : cdft_point_context_release,&
51 : cdft_point_context_type,&
52 : cdft_point_weights
53 : USE qs_cdft_types, ONLY: cdft_control_type
54 : USE qs_environment_types, ONLY: get_qs_env,&
55 : qs_environment_type
56 : USE qs_force_types, ONLY: qs_force_type
57 : USE qs_grid_atom, ONLY: grid_atom_type
58 : USE qs_harmonics_atom, ONLY: get_none0_cg_list,&
59 : harmonics_atom_type
60 : USE qs_kind_types, ONLY: get_qs_kind,&
61 : has_nlcc,&
62 : qs_kind_type
63 : USE qs_linres_types, ONLY: nablavks_atom_type
64 : USE qs_rho_atom_methods, ONLY: replicate_rho_atom_radial
65 : USE qs_rho_atom_types, ONLY: get_rho_atom,&
66 : rho_atom_coeff,&
67 : rho_atom_type
68 : USE qs_rho_types, ONLY: qs_rho_get,&
69 : qs_rho_type
70 : USE skala_gpw_features, ONLY: skala_gpw_smooth_partition_derivatives,&
71 : smooth_atom_partition
72 : USE skala_gpw_functional, ONLY: &
73 : build_vxc_from_feature_grads, get_gauxc_section, native_skala_gapw_density_partition, &
74 : skala_gapw_atom_composite_energy, skala_gapw_atom_vxc_of_r, &
75 : skala_gapw_density_partition_hard_minus_soft, skala_gapw_density_partition_hard_only, &
76 : skala_gapw_density_partition_none, skala_gapw_density_partition_soft_only, &
77 : xc_section_uses_gauxc_model, xc_section_uses_native_skala_evaluator
78 : USE spherical_harmonics, ONLY: y_lm
79 : USE util, ONLY: get_limit
80 : USE virial_types, ONLY: virial_type
81 : USE xc_atom, ONLY: fill_rho_set,&
82 : vxc_of_r_epr,&
83 : vxc_of_r_new,&
84 : xc_2nd_deriv_of_r,&
85 : xc_rho_set_atom_update
86 : USE xc_derivative_set_types, ONLY: xc_derivative_set_type,&
87 : xc_dset_create,&
88 : xc_dset_release,&
89 : xc_dset_zero_all
90 : USE xc_derivatives, ONLY: xc_functionals_get_needs
91 : USE xc_input_constants, ONLY: skala_gapw_cp2k_default,&
92 : skala_gapw_paw_one_center,&
93 : skala_gapw_paw_one_center_split
94 : USE xc_rho_cflags_types, ONLY: xc_rho_cflags_type
95 : USE xc_rho_set_types, ONLY: xc_rho_set_create,&
96 : xc_rho_set_get,&
97 : xc_rho_set_release,&
98 : xc_rho_set_type,&
99 : xc_rho_set_update
100 : #include "./base/base_uses.f90"
101 :
102 : IMPLICIT NONE
103 :
104 : PRIVATE
105 :
106 : CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_vxc_atom'
107 :
108 : INTEGER, PARAMETER, PRIVATE :: native_grid_interp_offset_min = -3, &
109 : native_grid_interp_offset_max = 4, &
110 : native_grid_interp_npts = &
111 : native_grid_interp_offset_max - &
112 : native_grid_interp_offset_min + 1
113 :
114 : TYPE tau_basis_cache_type
115 : INTEGER :: maxso = 0, na = 0, nr = 0, nsatbas = 0, &
116 : nset = 0
117 : INTEGER, DIMENSION(:), POINTER :: lmax => NULL(), lmin => NULL(), &
118 : n2oindex => NULL(), npgf => NULL(), &
119 : o2nindex => NULL()
120 : REAL(dp), DIMENSION(:, :), POINTER :: zet => NULL()
121 : REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: grad
122 : END TYPE tau_basis_cache_type
123 :
124 : PUBLIC :: calculate_vxc_atom, &
125 : calculate_vxc_atom_epr, &
126 : calculate_xc_2nd_deriv_atom, &
127 : calc_rho_angular, &
128 : calculate_gfxc_atom, &
129 : gapw_cdft_one_center, &
130 : gfxc_atom_diff, &
131 : gaVxcgb_noGC
132 :
133 : CONTAINS
134 :
135 : ! **************************************************************************************************
136 : !> \brief Evaluate an NLCC density and its first two Cartesian derivatives.
137 : !> \param point evaluation point
138 : !> \param center pseudopotential center
139 : !> \param gth_potential optional GTH potential
140 : !> \param sgp_potential optional separable Gaussian potential
141 : !> \param rho core density
142 : !> \param gradient Cartesian density gradient
143 : !> \param hessian Cartesian density Hessian
144 : ! **************************************************************************************************
145 30000 : SUBROUTINE evaluate_nlcc_primitive_fields(point, center, gth_potential, sgp_potential, &
146 : rho, gradient, hessian)
147 : REAL(dp), DIMENSION(3), INTENT(IN) :: point, center
148 : TYPE(gth_potential_type), INTENT(IN), POINTER :: gth_potential
149 : TYPE(sgp_potential_type), INTENT(IN), POINTER :: sgp_potential
150 : REAL(dp), INTENT(OUT) :: rho
151 : REAL(dp), DIMENSION(3), INTENT(OUT) :: gradient
152 : REAL(dp), DIMENSION(3, 3), INTENT(OUT) :: hessian
153 :
154 : INTEGER :: ic, idir, iexp, jdir, n_nlcc, nexp_nlcc, &
155 : power
156 30000 : INTEGER, DIMENSION(:), POINTER :: nct_nlcc
157 : LOGICAL :: has_sgp_nlcc, nlcc_present
158 : REAL(dp) :: alpha, beta, d2poly, dpoly, exponential, &
159 : poly, r2, rho_x, rho_xx, scaled_r2
160 : REAL(dp), DIMENSION(3) :: displacement
161 30000 : REAL(dp), DIMENSION(:), POINTER :: a_nlcc, alpha_nlcc, c_nlcc
162 30000 : REAL(dp), DIMENSION(:, :), POINTER :: cval_nlcc
163 :
164 30000 : NULLIFY (a_nlcc, alpha_nlcc, c_nlcc, cval_nlcc, nct_nlcc)
165 30000 : rho = 0.0_dp
166 30000 : rho_x = 0.0_dp
167 30000 : rho_xx = 0.0_dp
168 120000 : displacement = point - center
169 120000 : r2 = DOT_PRODUCT(displacement, displacement)
170 :
171 30000 : IF (ASSOCIATED(gth_potential)) THEN
172 : CALL get_potential(gth_potential, nlcc_present=nlcc_present, &
173 : nexp_nlcc=nexp_nlcc, alpha_nlcc=alpha_nlcc, &
174 30000 : nct_nlcc=nct_nlcc, cval_nlcc=cval_nlcc)
175 30000 : IF (nlcc_present) THEN
176 30000 : DO iexp = 1, nexp_nlcc
177 15000 : alpha = alpha_nlcc(iexp)
178 15000 : beta = 0.5_dp/(alpha*alpha)
179 15000 : scaled_r2 = r2/(alpha*alpha)
180 15000 : exponential = EXP(-0.5_dp*scaled_r2)
181 45000 : DO ic = 1, nct_nlcc(iexp)
182 15000 : power = ic - 1
183 15000 : poly = cval_nlcc(ic, iexp)*scaled_r2**power
184 15000 : dpoly = 0.0_dp
185 15000 : IF (power > 0) THEN
186 : dpoly = cval_nlcc(ic, iexp)*REAL(power, dp)* &
187 0 : scaled_r2**(power - 1)/(alpha*alpha)
188 : END IF
189 0 : d2poly = 0.0_dp
190 0 : IF (power > 1) THEN
191 : d2poly = cval_nlcc(ic, iexp)*REAL(power*(power - 1), dp)* &
192 0 : scaled_r2**(power - 2)/(alpha**4)
193 : END IF
194 15000 : rho = rho + exponential*poly
195 15000 : rho_x = rho_x + exponential*(dpoly - beta*poly)
196 30000 : rho_xx = rho_xx + exponential*(d2poly - 2.0_dp*beta*dpoly + beta*beta*poly)
197 : END DO
198 : END DO
199 : END IF
200 0 : ELSE IF (ASSOCIATED(sgp_potential)) THEN
201 : CALL get_potential(sgp_potential, has_nlcc=has_sgp_nlcc, n_nlcc=n_nlcc, &
202 0 : a_nlcc=a_nlcc, c_nlcc=c_nlcc)
203 0 : IF (has_sgp_nlcc) THEN
204 0 : DO iexp = 1, n_nlcc
205 0 : exponential = EXP(-a_nlcc(iexp)*r2)
206 0 : rho = rho + c_nlcc(iexp)*exponential
207 0 : rho_x = rho_x - a_nlcc(iexp)*c_nlcc(iexp)*exponential
208 0 : rho_xx = rho_xx + a_nlcc(iexp)**2*c_nlcc(iexp)*exponential
209 : END DO
210 : END IF
211 : END IF
212 :
213 120000 : gradient = 2.0_dp*rho_x*displacement
214 120000 : DO idir = 1, 3
215 360000 : DO jdir = 1, 3
216 360000 : hessian(idir, jdir) = 4.0_dp*rho_xx*displacement(idir)*displacement(jdir)
217 : END DO
218 120000 : hessian(idir, idir) = hessian(idir, idir) + 2.0_dp*rho_x
219 : END DO
220 30000 : END SUBROUTINE evaluate_nlcc_primitive_fields
221 :
222 : ! **************************************************************************************************
223 : !> \brief ...
224 : !> \param qs_env ...
225 : !> \param energy_only ...
226 : !> \param exc1 the on-body ex energy contribution
227 : !> \param adiabatic_rescale_factor ...
228 : !> \param kind_set_external provides a non-default kind_set to use
229 : !> \param rho_atom_set_external provides a non-default atomic density set to use
230 : !> \param xc_section_external provides an external non-default XC
231 : !> \param calculate_forces ...
232 : !> \param composite_vxc_rho ...
233 : !> \param composite_vxc_tau ...
234 : !> \param composite_reference_active ...
235 : ! **************************************************************************************************
236 32056 : SUBROUTINE calculate_vxc_atom(qs_env, energy_only, exc1, &
237 : adiabatic_rescale_factor, kind_set_external, &
238 : rho_atom_set_external, xc_section_external, calculate_forces, &
239 : composite_vxc_rho, composite_vxc_tau, composite_reference_active)
240 :
241 : TYPE(qs_environment_type), POINTER :: qs_env
242 : LOGICAL, INTENT(IN) :: energy_only
243 : REAL(dp), INTENT(INOUT) :: exc1
244 : REAL(dp), INTENT(IN), OPTIONAL :: adiabatic_rescale_factor
245 : TYPE(qs_kind_type), DIMENSION(:), OPTIONAL, &
246 : POINTER :: kind_set_external
247 : TYPE(rho_atom_type), DIMENSION(:), OPTIONAL, &
248 : POINTER :: rho_atom_set_external
249 : TYPE(section_vals_type), OPTIONAL, POINTER :: xc_section_external
250 : LOGICAL, INTENT(IN), OPTIONAL :: calculate_forces
251 : TYPE(pw_r3d_rs_type), DIMENSION(:), OPTIONAL, &
252 : POINTER :: composite_vxc_rho, composite_vxc_tau
253 : LOGICAL, INTENT(OUT), OPTIONAL :: composite_reference_active
254 :
255 : CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_vxc_atom'
256 :
257 : INTEGER :: atom_composite_components, bo(2), composite_local_atom, composite_local_natom, &
258 : composite_nflat, composite_pw_nflat, composite_row, cross_last_ir, &
259 : gapw_density_partition, gapw_representation, handle, ia, iat, iatom, icomponent, idir, &
260 : ikind, ir, ispin, iw, jdir, myfun, na, natom, nr, nspins, num_pe, source_atom, &
261 : target_atom, xc_deriv_method_id, xc_rho_smooth_id, zatom
262 32056 : INTEGER(KIND=int_8), ALLOCATABLE, DIMENSION(:) :: composite_atomic_grid_sizes, &
263 32056 : composite_local_grid_sizes
264 32056 : INTEGER, ALLOCATABLE, DIMENSION(:) :: composite_atom_end, composite_atom_kind, &
265 32056 : composite_atom_kind_index, composite_atom_start, composite_local_atoms
266 : INTEGER, DIMENSION(2, 3) :: bounds
267 32056 : INTEGER, DIMENSION(:), POINTER :: atom_list
268 : LOGICAL :: accint, atom_composite_active, atom_composite_diagnostic, &
269 : atom_composite_reference, donlcc, evaluate_hard, evaluate_soft, force_paw_representation, &
270 : gradient_f, lsd, my_calculate_forces, native_grid_diagnostics, nlcc, paw_atom, &
271 : paw_pseudopotentials, rho_g_valid, skala_atom_grid, tau_f, tau_r_valid, use_virial
272 32056 : LOGICAL, ALLOCATABLE, DIMENSION(:) :: composite_partition_included
273 : REAL(dp) :: agr, alpha, atom_composite_exc, atom_composite_nelec, composite_density_max, &
274 : composite_density_min, composite_grad_max, composite_kin_max, composite_kin_min, &
275 : composite_tau_integral, cross_amplitude, cross_cutoff, density_cut, exc_h, exc_s, &
276 : feature_vxc_analytic, feature_vxc_fd, feature_vxc_minus, feature_vxc_plus, &
277 : feature_vxc_step, gradient_cut, my_adiabatic_rescale_factor, nlcc_density, &
278 : nlcc_spin_factor, one_center_density_field_contraction, &
279 : one_center_density_matrix_contraction, one_center_field_contraction, &
280 : one_center_gradient_field_contraction
281 : REAL(dp) :: one_center_gradient_matrix_contraction, one_center_matrix_contraction, &
282 : one_center_rho_grad_field_contraction, one_center_rho_grad_matrix_contraction, &
283 : one_center_tau_field_contraction, one_center_tau_matrix_contraction, &
284 : one_center_tensor_contraction, smooth_grid_contraction, smooth_input_contraction, &
285 : tau_cut, zeff
286 32056 : REAL(dp), ALLOCATABLE, DIMENSION(:) :: composite_atomic_grid_weight_grad, &
287 32056 : composite_atomic_grid_weights, composite_distances, composite_grid_weight_grad, &
288 32056 : composite_grid_weights, composite_partition_weights
289 32056 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: composite_atom_coord_grad, composite_atom_coords, &
290 32056 : composite_cross_density, composite_cross_kin, composite_density, composite_density_grad, &
291 32056 : composite_explicit_force, composite_grid_coord_force, composite_grid_coord_grad, &
292 32056 : composite_grid_coords, composite_kin, composite_kin_grad, composite_local_atom_coords, &
293 32056 : composite_model_atom_force, composite_moving_smooth_force, composite_nlcc_center_force, &
294 64112 : composite_partition_atom_coords, composite_partition_force, smooth_density_adjoint, &
295 32056 : smooth_kin_adjoint
296 32056 : REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: composite_cross_grad, composite_grad, &
297 32056 : composite_grad_grad, composite_int_h, composite_int_s, composite_partition_datom, &
298 64112 : composite_partition_dstrain, cross_tau_coeff, cross_tau_h, cross_tau_s, &
299 32056 : smooth_grad_adjoint
300 : REAL(dp), DIMENSION(1, 1, 1) :: tau_d
301 : REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d
302 : REAL(dp), DIMENSION(2) :: cross_density, cross_kin
303 : REAL(dp), DIMENSION(3) :: composite_point, nlcc_gradient, nlcc_spatial_derivative, &
304 : skala_atom_force_h, skala_atom_force_s, spatial_derivative
305 : REAL(dp), DIMENSION(3, 2) :: cross_grad
306 : REAL(dp), DIMENSION(3, 3) :: composite_explicit_virial, nlcc_hessian, &
307 : skala_atom_virial, &
308 : skala_atom_virial_h, &
309 : skala_atom_virial_s
310 : REAL(dp), DIMENSION(4) :: feature_component_analytic, &
311 : feature_component_fd
312 64112 : REAL(dp), DIMENSION(:, :), POINTER :: rho_nlcc, weight_h, weight_s
313 32056 : REAL(dp), DIMENSION(:, :, :), POINTER :: composite_smooth_rho, composite_smooth_rhoa, &
314 32056 : composite_smooth_rhob, composite_smooth_tau, composite_smooth_tau_a, &
315 96168 : composite_smooth_tau_b, rho_h, rho_s, smooth_rho, smooth_rhoa, smooth_rhob, smooth_tau, &
316 32056 : smooth_tau_a, smooth_tau_b, tau_h, tau_s, vtau_h, vtau_s, vxc_h, vxc_s
317 64112 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s, vxg_h, vxg_s
318 32056 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
319 : TYPE(cell_type), POINTER :: cell
320 224392 : TYPE(cp_3d_r_cp_type), DIMENSION(3) :: composite_smooth_drho, composite_smooth_drhoa, &
321 448784 : composite_smooth_drhob, smooth_drho, smooth_drhoa, smooth_drhob
322 : TYPE(dft_control_type), POINTER :: dft_control
323 : TYPE(grid_atom_type), POINTER :: grid_atom
324 : TYPE(gth_potential_type), POINTER :: gth_potential
325 : TYPE(gto_basis_set_type), POINTER :: basis_1c
326 : TYPE(harmonics_atom_type), POINTER :: harmonics
327 : TYPE(mp_para_env_type), POINTER :: para_env
328 32056 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
329 32056 : TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: smooth_rho_g
330 : TYPE(pw_env_type), POINTER :: pw_env
331 : TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
332 64112 : TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: smooth_rho_r, smooth_tau_r, &
333 32056 : smooth_vxc_rho, smooth_vxc_tau
334 32056 : TYPE(qs_force_type), DIMENSION(:), POINTER :: force
335 32056 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: my_kind_set
336 : TYPE(qs_rho_type), POINTER :: rho_struct
337 32056 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cpc_h, cpc_s, dr_h, dr_s, int_hh, &
338 32056 : int_ss, r_h, r_s
339 32056 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
340 32056 : TYPE(rho_atom_type), DIMENSION(:), POINTER :: my_rho_atom_set
341 : TYPE(rho_atom_type), POINTER :: rho_atom
342 : TYPE(section_vals_type), POINTER :: gauxc_section, input, my_xc_section, &
343 : xc_fun_section
344 : TYPE(sgp_potential_type), POINTER :: sgp_potential
345 32056 : TYPE(tau_basis_cache_type) :: tau_basis_cache
346 : TYPE(virial_type), POINTER :: virial
347 : TYPE(xc_derivative_set_type) :: deriv_set
348 : TYPE(xc_rho_cflags_type) :: needs
349 : TYPE(xc_rho_set_type) :: rho_set_h, rho_set_s, smooth_rho_set
350 :
351 : ! -------------------------------------------------------------------------
352 :
353 32056 : CALL timeset(routineN, handle)
354 :
355 32056 : NULLIFY (atom_list)
356 32056 : NULLIFY (auxbas_pw_pool)
357 32056 : NULLIFY (my_kind_set)
358 32056 : NULLIFY (atomic_kind_set)
359 32056 : NULLIFY (cell)
360 32056 : NULLIFY (grid_atom)
361 32056 : NULLIFY (gth_potential)
362 32056 : NULLIFY (force)
363 32056 : NULLIFY (harmonics)
364 32056 : NULLIFY (input)
365 32056 : NULLIFY (para_env)
366 32056 : NULLIFY (particle_set)
367 32056 : NULLIFY (pw_env)
368 32056 : NULLIFY (rho_atom)
369 32056 : NULLIFY (rho_struct)
370 32056 : NULLIFY (my_rho_atom_set)
371 32056 : NULLIFY (rho_nlcc)
372 32056 : NULLIFY (smooth_rho, smooth_rhoa, smooth_rhob, smooth_tau, smooth_tau_a, smooth_tau_b)
373 32056 : NULLIFY (composite_smooth_rho, composite_smooth_rhoa, composite_smooth_rhob, &
374 32056 : composite_smooth_tau, composite_smooth_tau_a, composite_smooth_tau_b)
375 32056 : NULLIFY (smooth_rho_g, smooth_rho_r, smooth_tau_r)
376 32056 : NULLIFY (smooth_vxc_rho, smooth_vxc_tau)
377 128224 : DO idir = 1, 3
378 96168 : NULLIFY (smooth_drho(idir)%array, smooth_drhoa(idir)%array, smooth_drhob(idir)%array)
379 : NULLIFY (composite_smooth_drho(idir)%array, &
380 96168 : composite_smooth_drhoa(idir)%array, &
381 128224 : composite_smooth_drhob(idir)%array)
382 : END DO
383 32056 : NULLIFY (sgp_potential)
384 32056 : NULLIFY (virial)
385 32056 : my_calculate_forces = .FALSE.
386 32056 : IF (PRESENT(calculate_forces)) my_calculate_forces = calculate_forces
387 32056 : IF (PRESENT(composite_reference_active)) composite_reference_active = .FALSE.
388 :
389 32056 : IF (PRESENT(adiabatic_rescale_factor)) THEN
390 44 : my_adiabatic_rescale_factor = adiabatic_rescale_factor
391 : ELSE
392 32012 : my_adiabatic_rescale_factor = 1.0_dp
393 : END IF
394 :
395 : CALL get_qs_env(qs_env=qs_env, &
396 : dft_control=dft_control, &
397 : cell=cell, &
398 : para_env=para_env, &
399 : atomic_kind_set=atomic_kind_set, &
400 : qs_kind_set=my_kind_set, &
401 : input=input, &
402 : particle_set=particle_set, &
403 : pw_env=pw_env, &
404 : rho=rho_struct, &
405 : virial=virial, &
406 : rho_atom_set=my_rho_atom_set, &
407 32056 : force=force)
408 :
409 32056 : IF (PRESENT(kind_set_external)) my_kind_set => kind_set_external
410 32056 : IF (PRESENT(rho_atom_set_external)) my_rho_atom_set => rho_atom_set_external
411 :
412 32056 : nlcc = has_nlcc(my_kind_set)
413 32056 : accint = dft_control%qs_control%gapw_control%accurate_xcint
414 :
415 32056 : my_xc_section => section_vals_get_subs_vals(input, "DFT%XC")
416 :
417 32056 : IF (PRESENT(xc_section_external)) my_xc_section => xc_section_external
418 :
419 32056 : xc_fun_section => section_vals_get_subs_vals(my_xc_section, "XC_FUNCTIONAL")
420 : CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", &
421 32056 : i_val=myfun)
422 32056 : skala_atom_grid = xc_section_uses_gauxc_model(my_xc_section)
423 32056 : gapw_representation = skala_gapw_cp2k_default
424 32056 : atom_composite_diagnostic = .FALSE.
425 32056 : atom_composite_reference = .FALSE.
426 32056 : paw_pseudopotentials = .FALSE.
427 32056 : native_grid_diagnostics = .FALSE.
428 32056 : atom_composite_components = 1
429 32056 : feature_vxc_step = 3.0E-3_dp
430 32056 : IF (skala_atom_grid) THEN
431 82 : gauxc_section => get_gauxc_section(my_xc_section)
432 82 : CPASSERT(ASSOCIATED(gauxc_section))
433 : CALL section_vals_val_get(gauxc_section, "PSEUDOPOTENTIAL_GAPW_REPRESENTATION", &
434 82 : i_val=gapw_representation)
435 : CALL section_vals_val_get(gauxc_section, "NATIVE_GRID_DIAGNOSTICS", &
436 82 : l_val=native_grid_diagnostics)
437 : END IF
438 : force_paw_representation = gapw_representation == skala_gapw_paw_one_center .OR. &
439 32056 : gapw_representation == skala_gapw_paw_one_center_split
440 32056 : IF (skala_atom_grid) THEN
441 172 : DO ikind = 1, SIZE(my_kind_set)
442 90 : NULLIFY (gth_potential, sgp_potential)
443 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
444 90 : gth_potential=gth_potential, sgp_potential=sgp_potential)
445 : paw_pseudopotentials = paw_pseudopotentials .OR. &
446 : (paw_atom .AND. (ASSOCIATED(gth_potential) .OR. &
447 212 : ASSOCIATED(sgp_potential)))
448 : END DO
449 : END IF
450 82 : IF (skala_atom_grid .AND. xc_section_uses_native_skala_evaluator(my_xc_section)) THEN
451 : CALL section_vals_val_get(gauxc_section, &
452 : "NATIVE_GRID_GAPW_ATOM_COMPOSITE_DIAGNOSTIC", &
453 80 : l_val=atom_composite_diagnostic)
454 : CALL section_vals_val_get(gauxc_section, &
455 : "NATIVE_GRID_GAPW_ATOM_COMPOSITE_REFERENCE", &
456 80 : l_val=atom_composite_reference)
457 : CALL section_vals_val_get(gauxc_section, &
458 : "NATIVE_GRID_GAPW_ATOM_COMPOSITE_COMPONENTS", &
459 80 : i_val=atom_composite_components)
460 : CALL section_vals_val_get(gauxc_section, &
461 : "NATIVE_GRID_GAPW_ATOM_COMPOSITE_FD_STEP", &
462 80 : r_val=feature_vxc_step)
463 : END IF
464 : atom_composite_reference = atom_composite_reference .OR. &
465 : (gapw_representation == skala_gapw_paw_one_center .AND. &
466 32056 : paw_pseudopotentials)
467 32056 : atom_composite_active = atom_composite_diagnostic .OR. atom_composite_reference
468 32056 : IF (PRESENT(composite_reference_active)) composite_reference_active = atom_composite_reference
469 32056 : gapw_density_partition = skala_gapw_density_partition_hard_minus_soft
470 32056 : IF (skala_atom_grid) THEN
471 82 : gapw_density_partition = native_skala_gapw_density_partition(my_xc_section)
472 : END IF
473 32056 : use_virial = ASSOCIATED(virial)
474 32056 : IF (use_virial) use_virial = my_calculate_forces .AND. &
475 32056 : virial%pv_calculate .AND. (.NOT. virial%pv_numer)
476 :
477 32056 : IF (myfun == xc_none) THEN
478 4186 : exc1 = 0.0_dp
479 16378 : my_rho_atom_set(:)%exc_h = 0.0_dp
480 16378 : my_rho_atom_set(:)%exc_s = 0.0_dp
481 : ELSE
482 : CALL section_vals_val_get(my_xc_section, "DENSITY_CUTOFF", &
483 27870 : r_val=density_cut)
484 : CALL section_vals_val_get(my_xc_section, "GRADIENT_CUTOFF", &
485 27870 : r_val=gradient_cut)
486 : CALL section_vals_val_get(my_xc_section, "TAU_CUTOFF", &
487 27870 : r_val=tau_cut)
488 :
489 27870 : lsd = dft_control%lsd
490 27870 : nspins = dft_control%nspins
491 : needs = xc_functionals_get_needs(xc_fun_section, &
492 : lsd=lsd, &
493 27870 : calc_potential=.TRUE.)
494 :
495 27870 : gradient_f = (needs%drho .OR. needs%drho_spin) .OR. skala_atom_grid
496 27870 : tau_f = (needs%tau .OR. needs%tau_spin) .OR. skala_atom_grid
497 :
498 27870 : IF (atom_composite_active) THEN
499 28 : IF (lsd) THEN
500 0 : needs%rho_spin = .TRUE.
501 0 : needs%drho_spin = .TRUE.
502 0 : needs%tau_spin = .TRUE.
503 : ELSE
504 28 : needs%rho = .TRUE.
505 28 : needs%drho = .TRUE.
506 28 : needs%tau = .TRUE.
507 : END IF
508 :
509 : ALLOCATE (composite_atomic_grid_sizes(SIZE(particle_set)), &
510 : composite_atom_kind(SIZE(particle_set)), &
511 : composite_atom_kind_index(SIZE(particle_set)), &
512 : composite_atom_start(SIZE(particle_set)), &
513 : composite_atom_end(SIZE(particle_set)), &
514 : composite_atom_coords(3, SIZE(particle_set)), &
515 : composite_partition_weights(SIZE(particle_set)), &
516 : composite_partition_atom_coords(3, SIZE(particle_set)), &
517 364 : composite_distances(SIZE(particle_set)))
518 28 : composite_atomic_grid_sizes = 0_int_8
519 28 : composite_atom_kind = 0
520 28 : composite_atom_kind_index = 0
521 28 : composite_atom_start = 0
522 28 : composite_atom_end = 0
523 84 : DO iatom = 1, SIZE(particle_set)
524 252 : composite_atom_coords(:, iatom) = particle_set(iatom)%r
525 : END DO
526 60 : DO ikind = 1, SIZE(atomic_kind_set)
527 32 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
528 32 : NULLIFY (gth_potential, sgp_potential)
529 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
530 : gth_potential=gth_potential, grid_atom=grid_atom, &
531 32 : sgp_potential=sgp_potential, zatom=zatom, zeff=zeff)
532 32 : IF (.NOT. paw_atom) CYCLE
533 : IF (.NOT. force_paw_representation .AND. &
534 32 : (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. &
535 : ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE
536 148 : DO iat = 1, natom
537 56 : iatom = atom_list(iat)
538 56 : composite_atomic_grid_sizes(iatom) = INT(grid_atom%nr*grid_atom%ng_sphere, KIND=int_8)
539 56 : composite_atom_kind(iatom) = ikind
540 88 : composite_atom_kind_index(iatom) = iat
541 : END DO
542 : END DO
543 84 : IF (ANY(composite_atomic_grid_sizes <= 0_int_8)) THEN
544 : CALL cp_abort(__LOCATION__, &
545 0 : "The atom-composite diagnostic requires a GAPW one-center grid for every atom.")
546 : END IF
547 :
548 28 : composite_local_natom = 0
549 60 : DO ikind = 1, SIZE(atomic_kind_set)
550 32 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
551 32 : NULLIFY (gth_potential, sgp_potential)
552 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
553 : gth_potential=gth_potential, sgp_potential=sgp_potential, &
554 32 : zatom=zatom, zeff=zeff)
555 32 : IF (.NOT. paw_atom) CYCLE
556 : IF (.NOT. force_paw_representation .AND. &
557 32 : (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. &
558 : ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE
559 32 : bo = get_limit(natom, para_env%num_pe, para_env%mepos)
560 92 : composite_local_natom = composite_local_natom + MAX(0, bo(2) - bo(1) + 1)
561 : END DO
562 : ALLOCATE (composite_local_atoms(composite_local_natom), &
563 : composite_local_grid_sizes(composite_local_natom), &
564 190 : composite_local_atom_coords(3, composite_local_natom))
565 28 : composite_local_atom = 0
566 28 : composite_nflat = 0
567 60 : DO ikind = 1, SIZE(atomic_kind_set)
568 32 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
569 32 : NULLIFY (gth_potential, sgp_potential)
570 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
571 : gth_potential=gth_potential, sgp_potential=sgp_potential, &
572 32 : zatom=zatom, zeff=zeff)
573 32 : IF (.NOT. paw_atom) CYCLE
574 : IF (.NOT. force_paw_representation .AND. &
575 32 : (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. &
576 : ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE
577 32 : bo = get_limit(natom, para_env%num_pe, para_env%mepos)
578 120 : DO iat = bo(1), bo(2)
579 28 : iatom = atom_list(iat)
580 28 : composite_local_atom = composite_local_atom + 1
581 28 : composite_local_atoms(composite_local_atom) = iatom
582 : composite_local_grid_sizes(composite_local_atom) = &
583 28 : composite_atomic_grid_sizes(iatom)
584 : composite_local_atom_coords(:, composite_local_atom) = &
585 112 : composite_atom_coords(:, iatom)
586 28 : composite_atom_start(iatom) = composite_nflat + 1
587 28 : composite_nflat = composite_nflat + INT(composite_atomic_grid_sizes(iatom))
588 60 : composite_atom_end(iatom) = composite_nflat
589 : END DO
590 : END DO
591 28 : CPASSERT(composite_local_atom == composite_local_natom)
592 : ALLOCATE (composite_density(composite_nflat, 2), &
593 : composite_grad(composite_nflat, 3, 2), &
594 : composite_kin(composite_nflat, 2), &
595 : composite_grid_coords(3, composite_nflat), &
596 : composite_grid_weights(composite_nflat), &
597 324 : composite_atomic_grid_weights(composite_nflat))
598 28 : composite_density = 0.0_dp
599 28 : composite_grad = 0.0_dp
600 28 : composite_kin = 0.0_dp
601 28 : composite_grid_coords = 0.0_dp
602 28 : composite_grid_weights = 0.0_dp
603 28 : composite_atomic_grid_weights = 0.0_dp
604 :
605 : CALL qs_rho_get(rho_struct, rho_r=smooth_rho_r, rho_g=smooth_rho_g, &
606 : tau_r=smooth_tau_r, rho_g_valid=rho_g_valid, &
607 28 : tau_r_valid=tau_r_valid)
608 28 : CPASSERT(rho_g_valid)
609 28 : CPASSERT(tau_r_valid)
610 28 : CPASSERT(ASSOCIATED(smooth_rho_r))
611 28 : CPASSERT(ASSOCIATED(smooth_rho_g))
612 28 : CPASSERT(ASSOCIATED(smooth_tau_r))
613 28 : CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool)
614 : CALL section_vals_val_get(my_xc_section, "XC_GRID%XC_DERIV", &
615 28 : i_val=xc_deriv_method_id)
616 : CALL section_vals_val_get(my_xc_section, "XC_GRID%XC_SMOOTH_RHO", &
617 28 : i_val=xc_rho_smooth_id)
618 : CALL xc_rho_set_create(smooth_rho_set, smooth_rho_r(1)%pw_grid%bounds_local, &
619 : rho_cutoff=section_get_rval(my_xc_section, "density_cutoff"), &
620 : drho_cutoff=section_get_rval(my_xc_section, "gradient_cutoff"), &
621 28 : tau_cutoff=section_get_rval(my_xc_section, "tau_cutoff"))
622 : CALL xc_rho_set_update(smooth_rho_set, smooth_rho_r, smooth_rho_g, smooth_tau_r, needs, &
623 28 : xc_deriv_method_id, xc_rho_smooth_id, auxbas_pw_pool)
624 84 : IF (lsd) THEN
625 : CALL xc_rho_set_get(smooth_rho_set, rhoa=smooth_rhoa, rhob=smooth_rhob, &
626 : drhoa=smooth_drhoa, drhob=smooth_drhob, &
627 0 : tau_a=smooth_tau_a, tau_b=smooth_tau_b)
628 : CALL gather_native_grid_field(smooth_rhoa, smooth_rho_r(1)%pw_grid, para_env, &
629 0 : composite_smooth_rhoa)
630 : CALL gather_native_grid_field(smooth_rhob, smooth_rho_r(1)%pw_grid, para_env, &
631 0 : composite_smooth_rhob)
632 : CALL gather_native_grid_field(smooth_tau_a, smooth_rho_r(1)%pw_grid, para_env, &
633 0 : composite_smooth_tau_a)
634 : CALL gather_native_grid_field(smooth_tau_b, smooth_rho_r(1)%pw_grid, para_env, &
635 0 : composite_smooth_tau_b)
636 0 : DO idir = 1, 3
637 : CALL gather_native_grid_field(smooth_drhoa(idir)%array, &
638 : smooth_rho_r(1)%pw_grid, para_env, &
639 0 : composite_smooth_drhoa(idir)%array)
640 : CALL gather_native_grid_field(smooth_drhob(idir)%array, &
641 : smooth_rho_r(1)%pw_grid, para_env, &
642 0 : composite_smooth_drhob(idir)%array)
643 : END DO
644 : ELSE
645 : CALL xc_rho_set_get(smooth_rho_set, rho=smooth_rho, drho=smooth_drho, &
646 28 : tau=smooth_tau)
647 : CALL gather_native_grid_field(smooth_rho, smooth_rho_r(1)%pw_grid, para_env, &
648 28 : composite_smooth_rho)
649 : CALL gather_native_grid_field(smooth_tau, smooth_rho_r(1)%pw_grid, para_env, &
650 28 : composite_smooth_tau)
651 112 : DO idir = 1, 3
652 : CALL gather_native_grid_field(smooth_drho(idir)%array, &
653 : smooth_rho_r(1)%pw_grid, para_env, &
654 112 : composite_smooth_drho(idir)%array)
655 : END DO
656 : END IF
657 : END IF
658 :
659 : ! Initialize energy contribution from the one center XC terms to zero
660 27870 : exc1 = 0.0_dp
661 :
662 : ! Nullify some pointers for work-arrays
663 27870 : NULLIFY (rho_h, drho_h, rho_s, drho_s, weight_h, weight_s)
664 27870 : NULLIFY (vxc_h, vxc_s, vxg_h, vxg_s)
665 27870 : NULLIFY (tau_h, tau_s)
666 27870 : NULLIFY (vtau_h, vtau_s)
667 :
668 : ! Here starts the loop over all the atoms
669 :
670 81956 : DO ikind = 1, SIZE(atomic_kind_set)
671 54086 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
672 54086 : NULLIFY (gth_potential, sgp_potential)
673 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
674 : gth_potential=gth_potential, harmonics=harmonics, &
675 : grid_atom=grid_atom, sgp_potential=sgp_potential, &
676 54086 : zatom=zatom, zeff=zeff)
677 54086 : CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
678 :
679 54086 : IF (.NOT. paw_atom) CYCLE
680 : IF (skala_atom_grid .AND. .NOT. force_paw_representation .AND. &
681 48828 : (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. &
682 : ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE
683 :
684 48812 : nr = grid_atom%nr
685 48812 : na = grid_atom%ng_sphere
686 :
687 : ! Prepare the structures needed to calculate and store the xc derivatives
688 :
689 : ! Array dimension: here anly one dimensional arrays are used,
690 : ! i.e. only the first column of deriv_data is read.
691 : ! The other to dimensions are set to size equal 1
692 488120 : bounds(1:2, 1:3) = 1
693 48812 : bounds(2, 1) = na
694 48812 : bounds(2, 2) = nr
695 :
696 : ! set integration weights
697 48812 : IF (accint) THEN
698 14550 : weight_h => grid_atom%weight
699 14550 : alpha = dft_control%qs_control%gapw_control%aw(ikind)
700 14550 : IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
701 14016 : IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
702 : END IF
703 14550 : IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
704 2136 : ALLOCATE (grid_atom%gapw_weight_s(na, nr))
705 27234 : DO ir = 1, nr
706 26700 : agr = 1.0_dp - EXP(-alpha*grid_atom%rad2(ir))
707 1362234 : grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
708 : END DO
709 534 : grid_atom%gapw_weight_alpha = alpha
710 : END IF
711 14550 : weight_s => grid_atom%gapw_weight_s
712 : ELSE
713 34262 : weight_h => grid_atom%weight
714 34262 : weight_s => grid_atom%weight
715 : END IF
716 :
717 : ! create a place where to put the derivatives
718 48812 : CALL xc_dset_create(deriv_set, local_bounds=bounds)
719 : ! create the place where to store the argument for the functionals
720 : CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
721 48812 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
722 : CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
723 48812 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
724 :
725 : ! allocate the required 3d arrays where to store rho and drho
726 48812 : CALL xc_rho_set_atom_update(rho_set_h, needs, nspins, bounds)
727 48812 : CALL xc_rho_set_atom_update(rho_set_s, needs, nspins, bounds)
728 :
729 48812 : CALL reallocate(rho_h, 1, na, 1, nr, 1, nspins)
730 48812 : CALL reallocate(rho_s, 1, na, 1, nr, 1, nspins)
731 48812 : CALL reallocate(vxc_h, 1, na, 1, nr, 1, nspins)
732 48812 : CALL reallocate(vxc_s, 1, na, 1, nr, 1, nspins)
733 : !
734 48812 : IF (gradient_f) THEN
735 32682 : CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
736 32682 : CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
737 32682 : CALL reallocate(vxg_h, 1, 3, 1, na, 1, nr, 1, nspins)
738 32682 : CALL reallocate(vxg_s, 1, 3, 1, na, 1, nr, 1, nspins)
739 : END IF
740 :
741 48812 : IF (tau_f) THEN
742 1268 : CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
743 1268 : CALL reallocate(tau_h, 1, na, 1, nr, 1, nspins)
744 1268 : CALL reallocate(tau_s, 1, na, 1, nr, 1, nspins)
745 1268 : CALL reallocate(vtau_h, 1, na, 1, nr, 1, nspins)
746 1268 : CALL reallocate(vtau_s, 1, na, 1, nr, 1, nspins)
747 : END IF
748 :
749 : ! NLCC: prepare rho and drho of the core charge for this KIND
750 48812 : donlcc = .FALSE.
751 48812 : IF (nlcc) THEN
752 462 : NULLIFY (rho_nlcc)
753 462 : rho_nlcc => my_kind_set(ikind)%nlcc_pot
754 462 : IF (ASSOCIATED(rho_nlcc)) donlcc = .TRUE.
755 : END IF
756 :
757 : ! Distribute the atoms of this kind
758 :
759 48812 : num_pe = para_env%num_pe
760 48812 : bo = get_limit(natom, para_env%num_pe, para_env%mepos)
761 :
762 87042 : DO iat = bo(1), bo(2)
763 38230 : iatom = atom_list(iat)
764 :
765 38230 : my_rho_atom_set(iatom)%exc_h = 0.0_dp
766 38230 : my_rho_atom_set(iatom)%exc_s = 0.0_dp
767 :
768 38230 : rho_atom => my_rho_atom_set(iatom)
769 123566561 : rho_h = 0.0_dp
770 123566561 : rho_s = 0.0_dp
771 38230 : IF (gradient_f) THEN
772 24866 : NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
773 : CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, &
774 : rho_rad_s=r_s, drho_rad_h=dr_h, &
775 : drho_rad_s=dr_s, rho_rad_h_d=r_h_d, &
776 24866 : rho_rad_s_d=r_s_d)
777 363512178 : drho_h = 0.0_dp
778 363512178 : drho_s = 0.0_dp
779 : ELSE
780 13364 : NULLIFY (r_h, r_s)
781 13364 : CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s)
782 13364 : rho_d = 0.0_dp
783 : END IF
784 38230 : IF (tau_f) THEN
785 : !compute tau on the grid all at once
786 895 : CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
787 : ELSE
788 37335 : tau_d = 0.0_dp
789 : END IF
790 :
791 2120170 : DO ir = 1, nr
792 : CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
793 : ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
794 2081940 : r_h_d, r_s_d, drho_h, drho_s)
795 2120170 : IF (donlcc) THEN
796 : CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
797 8700 : ir, rho_nlcc(:, 1), rho_h, rho_s, rho_nlcc(:, 2), drho_h, drho_s)
798 : END IF
799 : END DO
800 :
801 38230 : IF (atom_composite_active) THEN
802 28 : composite_row = composite_atom_start(iatom) - 1
803 1428 : DO ir = 1, nr
804 71428 : DO ia = 1, na
805 70000 : composite_row = composite_row + 1
806 : composite_point(1) = particle_set(iatom)%r(1) + grid_atom%rad(ir)* &
807 70000 : grid_atom%sin_pol(ia)*grid_atom%cos_azi(ia)
808 : composite_point(2) = particle_set(iatom)%r(2) + grid_atom%rad(ir)* &
809 70000 : grid_atom%sin_pol(ia)*grid_atom%sin_azi(ia)
810 : composite_point(3) = particle_set(iatom)%r(3) + &
811 70000 : grid_atom%rad(ir)*grid_atom%cos_pol(ia)
812 280000 : composite_grid_coords(:, composite_row) = composite_point
813 : CALL smooth_atom_partition( &
814 : composite_point, composite_atom_coords, cell, &
815 : composite_partition_weights, composite_partition_atom_coords, &
816 70000 : composite_distances)
817 70000 : composite_atomic_grid_weights(composite_row) = grid_atom%weight(ia, ir)
818 : composite_grid_weights(composite_row) = grid_atom%weight(ia, ir)* &
819 70000 : composite_partition_weights(iatom)
820 70000 : IF (lsd) THEN
821 0 : DO ispin = 1, 2
822 0 : IF (ispin == 1) THEN
823 : composite_density(composite_row, ispin) = &
824 : interpolate_native_grid(composite_smooth_rhoa, &
825 : smooth_rho_r(1)%pw_grid, &
826 0 : cell, composite_point)
827 : composite_kin(composite_row, ispin) = &
828 : interpolate_native_grid(composite_smooth_tau_a, &
829 : smooth_rho_r(1)%pw_grid, &
830 0 : cell, composite_point)
831 0 : DO idir = 1, 3
832 : composite_grad(composite_row, idir, ispin) = &
833 : interpolate_native_grid(composite_smooth_drhoa(idir)%array, &
834 : smooth_rho_r(1)%pw_grid, cell, &
835 0 : composite_point)
836 : END DO
837 : ELSE
838 : composite_density(composite_row, ispin) = &
839 : interpolate_native_grid(composite_smooth_rhob, &
840 : smooth_rho_r(1)%pw_grid, &
841 0 : cell, composite_point)
842 : composite_kin(composite_row, ispin) = &
843 : interpolate_native_grid(composite_smooth_tau_b, &
844 : smooth_rho_r(1)%pw_grid, &
845 0 : cell, composite_point)
846 0 : DO idir = 1, 3
847 : composite_grad(composite_row, idir, ispin) = &
848 : interpolate_native_grid(composite_smooth_drhob(idir)%array, &
849 : smooth_rho_r(1)%pw_grid, cell, &
850 0 : composite_point)
851 : END DO
852 : END IF
853 0 : IF (atom_composite_components <= 2) THEN
854 : composite_density(composite_row, ispin) = &
855 : composite_density(composite_row, ispin) + &
856 0 : rho_h(ia, ir, ispin) - rho_s(ia, ir, ispin)
857 0 : DO idir = 1, 3
858 : composite_grad(composite_row, idir, ispin) = &
859 : composite_grad(composite_row, idir, ispin) + &
860 0 : drho_h(idir, ia, ir, ispin) - drho_s(idir, ia, ir, ispin)
861 : END DO
862 : END IF
863 0 : IF (atom_composite_components == 1 .OR. &
864 0 : atom_composite_components == 3) THEN
865 : composite_kin(composite_row, ispin) = &
866 : composite_kin(composite_row, ispin) + &
867 0 : tau_h(ia, ir, ispin) - tau_s(ia, ir, ispin)
868 : END IF
869 : END DO
870 : ELSE
871 : composite_density(composite_row, :) = 0.5_dp* &
872 : interpolate_native_grid(composite_smooth_rho, &
873 : smooth_rho_r(1)%pw_grid, &
874 210000 : cell, composite_point)
875 : composite_kin(composite_row, :) = 0.5_dp* &
876 : interpolate_native_grid(composite_smooth_tau, &
877 : smooth_rho_r(1)%pw_grid, &
878 210000 : cell, composite_point)
879 280000 : DO idir = 1, 3
880 : composite_grad(composite_row, idir, :) = 0.5_dp* &
881 : interpolate_native_grid(composite_smooth_drho(idir)%array, &
882 : smooth_rho_r(1)%pw_grid, cell, &
883 700000 : composite_point)
884 : END DO
885 70000 : IF (atom_composite_components <= 2) THEN
886 : composite_density(composite_row, :) = &
887 : composite_density(composite_row, :) + &
888 210000 : 0.5_dp*(rho_h(ia, ir, 1) - rho_s(ia, ir, 1))
889 280000 : DO idir = 1, 3
890 : composite_grad(composite_row, idir, :) = &
891 : composite_grad(composite_row, idir, :) + &
892 : 0.5_dp*(drho_h(idir, ia, ir, 1) - &
893 700000 : drho_s(idir, ia, ir, 1))
894 : END DO
895 : END IF
896 70000 : IF (atom_composite_components == 1 .OR. &
897 : atom_composite_components == 3) THEN
898 : composite_kin(composite_row, :) = composite_kin(composite_row, :) + &
899 : 0.5_dp*(tau_h(ia, ir, 1) - &
900 210000 : tau_s(ia, ir, 1))
901 : END IF
902 : END IF
903 71400 : IF (atom_composite_reference .AND. nlcc) THEN
904 10000 : nlcc_spin_factor = MERGE(1.0_dp, 0.5_dp, lsd)
905 30000 : DO source_atom = 1, SIZE(particle_set)
906 20000 : NULLIFY (gth_potential, sgp_potential)
907 : CALL get_qs_kind(my_kind_set(composite_atom_kind(source_atom)), &
908 : gth_potential=gth_potential, &
909 20000 : sgp_potential=sgp_potential)
910 : CALL evaluate_nlcc_primitive_fields( &
911 : composite_point, particle_set(source_atom)%r, &
912 : gth_potential, sgp_potential, nlcc_density, &
913 20000 : nlcc_gradient, nlcc_hessian)
914 : composite_density(composite_row, :) = &
915 : composite_density(composite_row, :) + &
916 60000 : nlcc_spin_factor*nlcc_density
917 90000 : DO idir = 1, 3
918 : composite_grad(composite_row, idir, :) = &
919 : composite_grad(composite_row, idir, :) + &
920 200000 : nlcc_spin_factor*nlcc_gradient(idir)
921 : END DO
922 : END DO
923 : END IF
924 : END DO
925 : END DO
926 28 : CPASSERT(composite_row == composite_atom_end(iatom))
927 : END IF
928 :
929 2120170 : DO ir = 1, nr
930 2120170 : IF (tau_f) THEN
931 46050 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
932 46050 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
933 2035890 : ELSE IF (gradient_f) THEN
934 1214590 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_d, na, ir)
935 1214590 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_d, na, ir)
936 : ELSE
937 821300 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, rho_d, tau_d, na, ir)
938 821300 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, rho_d, tau_d, na, ir)
939 : END IF
940 : END DO
941 :
942 38230 : evaluate_hard = .TRUE.
943 38230 : evaluate_soft = .TRUE.
944 38230 : skala_atom_force_h = 0.0_dp
945 38230 : skala_atom_force_s = 0.0_dp
946 38230 : skala_atom_virial_h = 0.0_dp
947 38230 : skala_atom_virial_s = 0.0_dp
948 38230 : IF (skala_atom_grid) THEN
949 : SELECT CASE (gapw_density_partition)
950 : CASE (skala_gapw_density_partition_hard_minus_soft)
951 0 : CONTINUE
952 : CASE (skala_gapw_density_partition_hard_only)
953 0 : evaluate_soft = .FALSE.
954 : CASE (skala_gapw_density_partition_soft_only)
955 0 : evaluate_hard = .FALSE.
956 : CASE (skala_gapw_density_partition_none)
957 0 : evaluate_hard = .FALSE.
958 0 : evaluate_soft = .FALSE.
959 : CASE DEFAULT
960 : CALL cp_abort(__LOCATION__, &
961 46 : "Unknown GAUXC%NATIVE_GRID_GAPW_DENSITY_PARTITION value.")
962 : END SELECT
963 : END IF
964 38230 : IF (atom_composite_reference) THEN
965 28 : evaluate_hard = .FALSE.
966 28 : evaluate_soft = .FALSE.
967 : END IF
968 :
969 : !-------------------!
970 : ! hard atom density !
971 : !-------------------!
972 38230 : CALL xc_dset_zero_all(deriv_set)
973 38230 : IF (.NOT. evaluate_hard) THEN
974 28 : exc_h = 0.0_dp
975 28 : IF (.NOT. energy_only) THEN
976 71456 : vxc_h = 0.0_dp
977 281456 : IF (ASSOCIATED(vxg_h)) vxg_h = 0.0_dp
978 71456 : IF (ASSOCIATED(vtau_h)) vtau_h = 0.0_dp
979 : END IF
980 38202 : ELSE IF (skala_atom_grid) THEN
981 : CALL skala_gapw_atom_vxc_of_r( &
982 : my_xc_section, grid_atom, para_env, particle_set(iatom)%r, &
983 : rho_h, drho_h, tau_h, weight_h, lsd, nspins, na, nr, &
984 : exc_h, vxc_h, vxg_h, vtau_h, energy_only=energy_only, &
985 18 : atom_force=skala_atom_force_h, atom_virial=skala_atom_virial_h)
986 : ELSE
987 : CALL vxc_of_r_new(xc_fun_section, rho_set_h, deriv_set, 1, needs, weight_h, &
988 : lsd, na, nr, exc_h, vxc_h, vxg_h, vtau_h, energy_only=energy_only, &
989 38184 : adiabatic_rescale_factor=my_adiabatic_rescale_factor)
990 : END IF
991 38230 : rho_atom%exc_h = rho_atom%exc_h + exc_h
992 :
993 : !-------------------!
994 : ! soft atom density !
995 : !-------------------!
996 38230 : CALL xc_dset_zero_all(deriv_set)
997 38230 : IF (.NOT. evaluate_soft) THEN
998 28 : exc_s = 0.0_dp
999 28 : IF (.NOT. energy_only) THEN
1000 71456 : vxc_s = 0.0_dp
1001 281456 : IF (ASSOCIATED(vxg_s)) vxg_s = 0.0_dp
1002 71456 : IF (ASSOCIATED(vtau_s)) vtau_s = 0.0_dp
1003 : END IF
1004 38202 : ELSE IF (skala_atom_grid) THEN
1005 : CALL skala_gapw_atom_vxc_of_r( &
1006 : my_xc_section, grid_atom, para_env, particle_set(iatom)%r, &
1007 : rho_s, drho_s, tau_s, weight_s, lsd, nspins, na, nr, &
1008 : exc_s, vxc_s, vxg_s, vtau_s, energy_only=energy_only, &
1009 18 : atom_force=skala_atom_force_s, atom_virial=skala_atom_virial_s)
1010 : ELSE
1011 : CALL vxc_of_r_new(xc_fun_section, rho_set_s, deriv_set, 1, needs, weight_s, &
1012 : lsd, na, nr, exc_s, vxc_s, vxg_s, vtau_s, energy_only=energy_only, &
1013 38184 : adiabatic_rescale_factor=my_adiabatic_rescale_factor)
1014 : END IF
1015 38230 : rho_atom%exc_s = rho_atom%exc_s + exc_s
1016 :
1017 : ! Add contributions to the exc energy
1018 :
1019 38230 : exc1 = exc1 + rho_atom%exc_h - rho_atom%exc_s
1020 38230 : IF (skala_atom_grid .AND. my_calculate_forces .AND. ASSOCIATED(force)) THEN
1021 : force(ikind)%rho_elec(:, iat) = force(ikind)%rho_elec(:, iat) + &
1022 48 : skala_atom_force_h - skala_atom_force_s
1023 : END IF
1024 38230 : IF (skala_atom_grid .AND. use_virial) THEN
1025 104 : skala_atom_virial = skala_atom_virial_h - skala_atom_virial_s
1026 32 : DO idir = 1, 3
1027 104 : DO jdir = 1, 3
1028 : virial%pv_gapw(idir, jdir) = virial%pv_gapw(idir, jdir) + &
1029 72 : skala_atom_virial(idir, jdir)
1030 : virial%pv_virial(idir, jdir) = virial%pv_virial(idir, jdir) + &
1031 96 : skala_atom_virial(idir, jdir)
1032 : END DO
1033 : END DO
1034 : END IF
1035 :
1036 : ! Integration to get the matrix elements relative to the vxc_atom
1037 : ! here the products with the primitives is done: gaVxcgb
1038 : ! internal transformation to get the integral in cartesian Gaussians
1039 :
1040 38230 : IF (.NOT. energy_only) THEN
1041 36615 : NULLIFY (int_hh, int_ss)
1042 36615 : CALL get_rho_atom(rho_atom=rho_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
1043 36615 : IF (gradient_f) THEN
1044 : CALL gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
1045 23415 : grid_atom, basis_1c, harmonics, nspins)
1046 : ELSE
1047 : CALL gaVxcgb_noGC(vxc_h, vxc_s, int_hh, int_ss, &
1048 13200 : grid_atom, basis_1c, harmonics, nspins)
1049 : END IF
1050 36615 : IF (tau_f) THEN
1051 : CALL dgaVtaudgb(vtau_h, vtau_s, int_hh, int_ss, &
1052 895 : tau_basis_cache, nspins)
1053 : END IF
1054 : END IF ! energy_only
1055 87042 : NULLIFY (r_h, r_s, dr_h, dr_s)
1056 : END DO ! iat
1057 :
1058 48812 : IF (tau_f) CALL release_tau_basis_cache(tau_basis_cache)
1059 :
1060 : ! Release the xc structure used to store the xc derivatives
1061 48812 : CALL xc_dset_release(deriv_set)
1062 48812 : CALL xc_rho_set_release(rho_set_h)
1063 179580 : CALL xc_rho_set_release(rho_set_s)
1064 : END DO ! ikind
1065 :
1066 27870 : IF (atom_composite_active) THEN
1067 : ALLOCATE (composite_cross_density(composite_nflat, 2), &
1068 : composite_cross_grad(composite_nflat, 3, 2), &
1069 190 : composite_cross_kin(composite_nflat, 2))
1070 28 : composite_cross_density = 0.0_dp
1071 28 : composite_cross_grad = 0.0_dp
1072 28 : composite_cross_kin = 0.0_dp
1073 60 : DO ikind = 1, SIZE(atomic_kind_set)
1074 32 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
1075 32 : NULLIFY (gth_potential, sgp_potential)
1076 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
1077 : gth_potential=gth_potential, harmonics=harmonics, &
1078 : grid_atom=grid_atom, sgp_potential=sgp_potential, &
1079 32 : zatom=zatom, zeff=zeff)
1080 32 : CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
1081 32 : IF (.NOT. paw_atom) CYCLE
1082 : IF (.NOT. force_paw_representation .AND. &
1083 32 : (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. &
1084 : ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE
1085 :
1086 : CALL replicate_rho_atom_radial( &
1087 32 : para_env, my_rho_atom_set, my_kind_set(ikind), atom_list, natom, nspins)
1088 32 : nr = grid_atom%nr
1089 32 : na = grid_atom%ng_sphere
1090 32 : CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
1091 0 : ALLOCATE (cross_tau_h(na, nr, nspins), cross_tau_s(na, nr, nspins), &
1092 384 : cross_tau_coeff(nr, harmonics%max_iso_not0, nspins))
1093 :
1094 : ! The one-center density matrices are already globally reduced. Distribute the
1095 : ! overlap work by target atom so that every rank constructs only its model rows.
1096 88 : DO iat = 1, natom
1097 56 : source_atom = atom_list(iat)
1098 56 : rho_atom => my_rho_atom_set(source_atom)
1099 56 : NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
1100 : CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s, &
1101 : drho_rad_h=dr_h, drho_rad_s=dr_s, &
1102 56 : rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
1103 56 : CALL calc_tau_atom(cross_tau_h, cross_tau_s, rho_atom, tau_basis_cache, nspins)
1104 56 : cross_tau_coeff = 0.0_dp
1105 112 : DO ispin = 1, nspins
1106 2912 : DO ir = 1, nr
1107 26456 : DO ia = 1, harmonics%max_iso_not0
1108 : cross_tau_coeff(ir, ia, ispin) = &
1109 : DOT_PRODUCT(grid_atom%wa, &
1110 : (cross_tau_h(:, ir, ispin) - &
1111 1206400 : cross_tau_s(:, ir, ispin))*harmonics%slm(:, ia))
1112 : END DO
1113 : END DO
1114 : END DO
1115 :
1116 56 : cross_last_ir = 0
1117 56 : DO ir = nr, 1, -1
1118 584 : cross_amplitude = MAXVAL(ABS(cross_tau_coeff(ir, :, :)))
1119 112 : DO ispin = 1, nspins
1120 : cross_amplitude = MAX(cross_amplitude, &
1121 : MAXVAL(ABS(r_h(ispin)%r_coef(ir, :) - &
1122 : r_s(ispin)%r_coef(ir, :))), &
1123 : MAXVAL(ABS(dr_h(ispin)%r_coef(ir, :) - &
1124 1000 : dr_s(ispin)%r_coef(ir, :))))
1125 280 : DO idir = 1, 3
1126 : cross_amplitude = MAX(cross_amplitude, &
1127 : MAXVAL(ABS(r_h_d(idir, ispin)%r_coef(ir, :) - &
1128 1640 : r_s_d(idir, ispin)%r_coef(ir, :))))
1129 : END DO
1130 : END DO
1131 56 : IF (cross_amplitude > 1.0E-12_dp) THEN
1132 : cross_last_ir = ir
1133 : EXIT
1134 : END IF
1135 : END DO
1136 56 : IF (cross_last_ir == 0) CYCLE
1137 56 : cross_cutoff = grid_atom%rad(MIN(nr, cross_last_ir + 2))
1138 :
1139 144 : DO composite_local_atom = 1, composite_local_natom
1140 56 : target_atom = composite_local_atoms(composite_local_atom)
1141 56 : IF (target_atom == source_atom) CYCLE
1142 70028 : DO composite_row = composite_atom_start(target_atom), &
1143 84 : composite_atom_end(target_atom)
1144 : CALL evaluate_gapw_atom_delta( &
1145 : grid_atom, harmonics, r_h, r_s, dr_h, dr_s, r_h_d, r_s_d, &
1146 : cross_tau_coeff, nspins, cross_cutoff, particle_set(source_atom)%r, &
1147 : composite_grid_coords(:, composite_row), cell, &
1148 70000 : cross_density, cross_grad, cross_kin)
1149 70056 : IF (lsd) THEN
1150 0 : IF (atom_composite_components <= 2) THEN
1151 : composite_cross_density(composite_row, 1:2) = &
1152 0 : composite_cross_density(composite_row, 1:2) + cross_density(1:2)
1153 : composite_cross_grad(composite_row, :, 1:2) = &
1154 0 : composite_cross_grad(composite_row, :, 1:2) + cross_grad(:, 1:2)
1155 : END IF
1156 0 : IF (atom_composite_components == 1 .OR. &
1157 : atom_composite_components == 3) THEN
1158 : composite_cross_kin(composite_row, 1:2) = &
1159 0 : composite_cross_kin(composite_row, 1:2) + cross_kin(1:2)
1160 : END IF
1161 : ELSE
1162 70000 : IF (atom_composite_components <= 2) THEN
1163 : composite_cross_density(composite_row, :) = &
1164 210000 : composite_cross_density(composite_row, :) + 0.5_dp*cross_density(1)
1165 280000 : DO idir = 1, 3
1166 : composite_cross_grad(composite_row, idir, :) = &
1167 : composite_cross_grad(composite_row, idir, :) + &
1168 700000 : 0.5_dp*cross_grad(idir, 1)
1169 : END DO
1170 : END IF
1171 70000 : IF (atom_composite_components == 1 .OR. &
1172 : atom_composite_components == 3) THEN
1173 : composite_cross_kin(composite_row, :) = &
1174 210000 : composite_cross_kin(composite_row, :) + 0.5_dp*cross_kin(1)
1175 : END IF
1176 : END IF
1177 : END DO
1178 : END DO
1179 : END DO
1180 :
1181 32 : DEALLOCATE (cross_tau_coeff, cross_tau_h, cross_tau_s)
1182 92 : CALL release_tau_basis_cache(tau_basis_cache)
1183 : END DO
1184 :
1185 140084 : composite_density(:, :) = composite_density(:, :) + composite_cross_density(:, :)
1186 420252 : composite_grad(:, :, :) = composite_grad(:, :, :) + composite_cross_grad(:, :, :)
1187 140084 : composite_kin(:, :) = composite_kin(:, :) + composite_cross_kin(:, :)
1188 28 : DEALLOCATE (composite_cross_density, composite_cross_grad, composite_cross_kin)
1189 :
1190 70028 : CPASSERT(ALL(composite_grid_weights >= 0.0_dp))
1191 : atom_composite_nelec = SUM(composite_grid_weights* &
1192 70028 : (composite_density(:, 1) + composite_density(:, 2)))
1193 28 : CALL para_env%sum(atom_composite_nelec)
1194 28 : IF (atom_composite_reference .AND. my_calculate_forces) THEN
1195 : CALL skala_gapw_atom_composite_energy( &
1196 : my_xc_section, para_env, composite_density, composite_grad, composite_kin, &
1197 : composite_grid_coords, composite_grid_weights, composite_atomic_grid_weights, &
1198 : composite_local_grid_sizes, composite_local_atom_coords, atom_composite_exc, &
1199 : composite_density_grad, composite_grad_grad, composite_kin_grad, &
1200 : composite_grid_coord_grad, composite_grid_weight_grad, &
1201 4 : composite_atomic_grid_weight_grad, composite_atom_coord_grad)
1202 0 : ALLOCATE (composite_explicit_force(3, SIZE(particle_set)), &
1203 0 : composite_grid_coord_force(3, SIZE(particle_set)), &
1204 0 : composite_model_atom_force(3, SIZE(particle_set)), &
1205 0 : composite_moving_smooth_force(3, SIZE(particle_set)), &
1206 0 : composite_nlcc_center_force(3, SIZE(particle_set)), &
1207 0 : composite_partition_force(3, SIZE(particle_set)), &
1208 0 : composite_partition_included(SIZE(particle_set)), &
1209 0 : composite_partition_datom(3, SIZE(particle_set), SIZE(particle_set)), &
1210 60 : composite_partition_dstrain(3, 3, SIZE(particle_set)))
1211 4 : composite_model_atom_force = 0.0_dp
1212 4 : composite_grid_coord_force = 0.0_dp
1213 4 : composite_moving_smooth_force = 0.0_dp
1214 4 : composite_nlcc_center_force = 0.0_dp
1215 4 : composite_partition_force = 0.0_dp
1216 8 : DO composite_local_atom = 1, composite_local_natom
1217 4 : iatom = composite_local_atoms(composite_local_atom)
1218 : composite_model_atom_force(:, iatom) = &
1219 16 : composite_atom_coord_grad(:, composite_local_atom)
1220 10008 : DO composite_row = composite_atom_start(iatom), composite_atom_end(iatom)
1221 : composite_grid_coord_force(:, iatom) = &
1222 : composite_grid_coord_force(:, iatom) + &
1223 40000 : composite_grid_coord_grad(:, composite_row)
1224 10000 : IF (lsd) THEN
1225 : spatial_derivative = &
1226 : composite_density_grad(composite_row, 1)* &
1227 : interpolate_native_grid_gradient( &
1228 : composite_smooth_rhoa, smooth_rho_r(1)%pw_grid, cell, &
1229 : composite_grid_coords(:, composite_row)) + &
1230 : composite_density_grad(composite_row, 2)* &
1231 : interpolate_native_grid_gradient( &
1232 : composite_smooth_rhob, smooth_rho_r(1)%pw_grid, cell, &
1233 : composite_grid_coords(:, composite_row)) + &
1234 : composite_kin_grad(composite_row, 1)* &
1235 : interpolate_native_grid_gradient( &
1236 : composite_smooth_tau_a, smooth_rho_r(1)%pw_grid, cell, &
1237 : composite_grid_coords(:, composite_row)) + &
1238 : composite_kin_grad(composite_row, 2)* &
1239 : interpolate_native_grid_gradient( &
1240 : composite_smooth_tau_b, smooth_rho_r(1)%pw_grid, cell, &
1241 0 : composite_grid_coords(:, composite_row))
1242 0 : DO idir = 1, 3
1243 : spatial_derivative = spatial_derivative + &
1244 : composite_grad_grad(composite_row, idir, 1)* &
1245 : interpolate_native_grid_gradient( &
1246 : composite_smooth_drhoa(idir)%array, &
1247 : smooth_rho_r(1)%pw_grid, cell, &
1248 : composite_grid_coords(:, composite_row)) + &
1249 : composite_grad_grad(composite_row, idir, 2)* &
1250 : interpolate_native_grid_gradient( &
1251 : composite_smooth_drhob(idir)%array, &
1252 : smooth_rho_r(1)%pw_grid, cell, &
1253 0 : composite_grid_coords(:, composite_row))
1254 : END DO
1255 : ELSE
1256 : spatial_derivative = 0.5_dp*SUM( &
1257 : composite_density_grad(composite_row, :))* &
1258 : interpolate_native_grid_gradient( &
1259 : composite_smooth_rho, smooth_rho_r(1)%pw_grid, cell, &
1260 : composite_grid_coords(:, composite_row)) + &
1261 : 0.5_dp*SUM(composite_kin_grad(composite_row, :))* &
1262 : interpolate_native_grid_gradient( &
1263 : composite_smooth_tau, smooth_rho_r(1)%pw_grid, cell, &
1264 80000 : composite_grid_coords(:, composite_row))
1265 40000 : DO idir = 1, 3
1266 : spatial_derivative = spatial_derivative + 0.5_dp*SUM( &
1267 : composite_grad_grad(composite_row, idir, :))* &
1268 : interpolate_native_grid_gradient( &
1269 : composite_smooth_drho(idir)%array, &
1270 : smooth_rho_r(1)%pw_grid, &
1271 190000 : cell, composite_grid_coords(:, composite_row))
1272 : END DO
1273 : END IF
1274 10000 : IF (nlcc) THEN
1275 5000 : nlcc_spin_factor = MERGE(1.0_dp, 0.5_dp, lsd)
1276 15000 : DO source_atom = 1, SIZE(particle_set)
1277 10000 : NULLIFY (gth_potential, sgp_potential)
1278 : CALL get_qs_kind(my_kind_set(composite_atom_kind(source_atom)), &
1279 : gth_potential=gth_potential, &
1280 10000 : sgp_potential=sgp_potential)
1281 : CALL evaluate_nlcc_primitive_fields( &
1282 : composite_grid_coords(:, composite_row), &
1283 : particle_set(source_atom)%r, gth_potential, sgp_potential, &
1284 10000 : nlcc_density, nlcc_gradient, nlcc_hessian)
1285 10000 : nlcc_spatial_derivative = 0.0_dp
1286 30000 : DO ispin = 1, 2
1287 : nlcc_spatial_derivative = nlcc_spatial_derivative + &
1288 : nlcc_spin_factor*composite_density_grad(composite_row, ispin)* &
1289 80000 : nlcc_gradient
1290 90000 : DO idir = 1, 3
1291 260000 : DO jdir = 1, 3
1292 : nlcc_spatial_derivative(jdir) = &
1293 : nlcc_spatial_derivative(jdir) + nlcc_spin_factor* &
1294 : composite_grad_grad(composite_row, idir, ispin)* &
1295 240000 : nlcc_hessian(idir, jdir)
1296 : END DO
1297 : END DO
1298 : END DO
1299 40000 : spatial_derivative = spatial_derivative + nlcc_spatial_derivative
1300 : composite_nlcc_center_force(:, source_atom) = &
1301 45000 : composite_nlcc_center_force(:, source_atom) - nlcc_spatial_derivative
1302 : END DO
1303 : END IF
1304 : composite_moving_smooth_force(:, iatom) = &
1305 40000 : composite_moving_smooth_force(:, iatom) + spatial_derivative
1306 : CALL skala_gpw_smooth_partition_derivatives( &
1307 : composite_grid_coords(:, composite_row), composite_atom_coords, cell, &
1308 : composite_partition_weights, composite_partition_included, &
1309 10000 : composite_partition_datom, composite_partition_dstrain)
1310 30000 : DO target_atom = 1, SIZE(particle_set)
1311 : composite_partition_force(:, target_atom) = &
1312 : composite_partition_force(:, target_atom) + &
1313 : composite_grid_weight_grad(composite_row)* &
1314 : composite_atomic_grid_weights(composite_row)* &
1315 90000 : composite_partition_datom(:, target_atom, iatom)
1316 : END DO
1317 : composite_partition_force(:, iatom) = composite_partition_force(:, iatom) - &
1318 : composite_grid_weight_grad(composite_row)* &
1319 : composite_atomic_grid_weights(composite_row)* &
1320 100004 : SUM(composite_partition_datom(:, :, iatom), DIM=2)
1321 : END DO
1322 : END DO
1323 : composite_explicit_force(:, :) = composite_model_atom_force(:, :) + &
1324 : composite_grid_coord_force(:, :) + &
1325 : composite_moving_smooth_force(:, :) + &
1326 : composite_nlcc_center_force(:, :) + &
1327 36 : composite_partition_force(:, :)
1328 : ! CP2K stores +dE/dR in the electronic force components, but the
1329 : ! virial is -dE/dstrain. A cell deformation moves the atom-grid
1330 : ! centers with their atoms while leaving the local radial vectors
1331 : ! unchanged, so the explicit atom-composite contribution is
1332 : ! -SUM_A dE/dR_A outer R_A.
1333 4 : composite_explicit_virial = 0.0_dp
1334 12 : DO iatom = 1, SIZE(particle_set)
1335 36 : DO idir = 1, 3
1336 104 : DO jdir = 1, 3
1337 : composite_explicit_virial(idir, jdir) = &
1338 : composite_explicit_virial(idir, jdir) - &
1339 96 : composite_explicit_force(idir, iatom)*particle_set(iatom)%r(jdir)
1340 : END DO
1341 : END DO
1342 : END DO
1343 4 : IF (ASSOCIATED(force)) THEN
1344 12 : DO iatom = 1, SIZE(particle_set)
1345 8 : ikind = composite_atom_kind(iatom)
1346 8 : iat = composite_atom_kind_index(iatom)
1347 8 : CPASSERT(ikind > 0 .AND. iat > 0)
1348 : force(ikind)%rho_elec(:, iat) = force(ikind)%rho_elec(:, iat) + &
1349 36 : composite_explicit_force(:, iatom)
1350 : END DO
1351 : END IF
1352 4 : IF (use_virial) THEN
1353 0 : virial%pv_xc = 0.0_dp
1354 0 : virial%pv_gapw = virial%pv_gapw + composite_explicit_virial
1355 0 : virial%pv_virial = virial%pv_virial + composite_explicit_virial
1356 : END IF
1357 4 : IF (native_grid_diagnostics) THEN
1358 4 : CALL para_env%sum(composite_model_atom_force)
1359 4 : CALL para_env%sum(composite_grid_coord_force)
1360 4 : CALL para_env%sum(composite_moving_smooth_force)
1361 4 : CALL para_env%sum(composite_nlcc_center_force)
1362 4 : CALL para_env%sum(composite_partition_force)
1363 4 : CALL para_env%sum(composite_explicit_force)
1364 4 : CALL para_env%sum(composite_explicit_virial)
1365 4 : iw = cp_logger_get_default_io_unit()
1366 4 : IF (iw > 0) THEN
1367 6 : DO iatom = 1, SIZE(particle_set)
1368 : WRITE (UNIT=iw, FMT="(T2,A,1X,I0,3(1X,ES20.12))") &
1369 4 : "SKALA_GPW| Atom-composite model-atom force", iatom, &
1370 8 : composite_model_atom_force(:, iatom)
1371 : WRITE (UNIT=iw, FMT="(T2,A,1X,I0,3(1X,ES20.12))") &
1372 4 : "SKALA_GPW| Atom-composite grid-coordinate force", iatom, &
1373 8 : composite_grid_coord_force(:, iatom)
1374 : WRITE (UNIT=iw, FMT="(T2,A,1X,I0,3(1X,ES20.12))") &
1375 4 : "SKALA_GPW| Atom-composite moving-smooth force", iatom, &
1376 8 : composite_moving_smooth_force(:, iatom)
1377 : WRITE (UNIT=iw, FMT="(T2,A,1X,I0,3(1X,ES20.12))") &
1378 4 : "SKALA_GPW| Atom-composite NLCC-center force", iatom, &
1379 8 : composite_nlcc_center_force(:, iatom)
1380 : WRITE (UNIT=iw, FMT="(T2,A,1X,I0,3(1X,ES20.12))") &
1381 4 : "SKALA_GPW| Atom-composite partition force", iatom, &
1382 8 : composite_partition_force(:, iatom)
1383 : WRITE (UNIT=iw, FMT="(T2,A,1X,I0,3(1X,ES20.12))") &
1384 4 : "SKALA_GPW| Atom-composite explicit force", iatom, &
1385 10 : composite_explicit_force(:, iatom)
1386 : END DO
1387 : WRITE (UNIT=iw, FMT="(T2,A)") &
1388 2 : "SKALA_GPW| Atom-composite explicit virial"
1389 8 : DO idir = 1, 3
1390 : WRITE (UNIT=iw, FMT="(T2,A,1X,3ES20.10)") &
1391 8 : "SKALA_GPW|", composite_explicit_virial(idir, :)
1392 : END DO
1393 : END IF
1394 : END IF
1395 0 : DEALLOCATE (composite_atom_coord_grad, composite_atomic_grid_weight_grad, &
1396 0 : composite_explicit_force, composite_grid_coord_force, &
1397 0 : composite_grid_coord_grad, composite_grid_weight_grad, &
1398 0 : composite_model_atom_force, composite_moving_smooth_force, &
1399 0 : composite_nlcc_center_force, &
1400 0 : composite_partition_datom, composite_partition_dstrain, &
1401 4 : composite_partition_force, composite_partition_included)
1402 : ELSE
1403 : CALL skala_gapw_atom_composite_energy( &
1404 : my_xc_section, para_env, composite_density, composite_grad, composite_kin, &
1405 : composite_grid_coords, composite_grid_weights, composite_atomic_grid_weights, &
1406 : composite_local_grid_sizes, composite_local_atom_coords, atom_composite_exc, &
1407 24 : composite_density_grad, composite_grad_grad, composite_kin_grad)
1408 : END IF
1409 112 : composite_pw_nflat = PRODUCT(smooth_rho_r(1)%pw_grid%npts)
1410 0 : ALLOCATE (smooth_density_adjoint(composite_pw_nflat, 2), &
1411 0 : smooth_grad_adjoint(composite_pw_nflat, 3, 2), &
1412 196 : smooth_kin_adjoint(composite_pw_nflat, 2))
1413 28 : smooth_density_adjoint = 0.0_dp
1414 28 : smooth_grad_adjoint = 0.0_dp
1415 28 : smooth_kin_adjoint = 0.0_dp
1416 28 : smooth_input_contraction = 0.0_dp
1417 70028 : DO composite_row = 1, composite_nflat
1418 210028 : DO ispin = 1, 2
1419 : CALL add_native_grid_interpolation_adjoint( &
1420 : smooth_density_adjoint(:, ispin), smooth_rho_r(1)%pw_grid, cell, &
1421 : composite_grid_coords(:, composite_row), &
1422 140000 : composite_density_grad(composite_row, ispin))
1423 : CALL add_native_grid_interpolation_adjoint( &
1424 : smooth_kin_adjoint(:, ispin), smooth_rho_r(1)%pw_grid, cell, &
1425 : composite_grid_coords(:, composite_row), &
1426 140000 : composite_kin_grad(composite_row, ispin))
1427 560000 : DO idir = 1, 3
1428 : CALL add_native_grid_interpolation_adjoint( &
1429 : smooth_grad_adjoint(:, idir, ispin), smooth_rho_r(1)%pw_grid, cell, &
1430 : composite_grid_coords(:, composite_row), &
1431 560000 : composite_grad_grad(composite_row, idir, ispin))
1432 : END DO
1433 210000 : IF (lsd) THEN
1434 0 : IF (ispin == 1) THEN
1435 : smooth_input_contraction = smooth_input_contraction + &
1436 : composite_density_grad(composite_row, ispin)* &
1437 : interpolate_native_grid(composite_smooth_rhoa, &
1438 : smooth_rho_r(1)%pw_grid, cell, &
1439 : composite_grid_coords(:, composite_row)) + &
1440 : composite_kin_grad(composite_row, ispin)* &
1441 : interpolate_native_grid(composite_smooth_tau_a, &
1442 : smooth_rho_r(1)%pw_grid, cell, &
1443 0 : composite_grid_coords(:, composite_row))
1444 0 : DO idir = 1, 3
1445 : smooth_input_contraction = smooth_input_contraction + &
1446 : composite_grad_grad(composite_row, idir, ispin)* &
1447 : interpolate_native_grid(composite_smooth_drhoa(idir)%array, &
1448 : smooth_rho_r(1)%pw_grid, cell, &
1449 0 : composite_grid_coords(:, composite_row))
1450 : END DO
1451 : ELSE
1452 : smooth_input_contraction = smooth_input_contraction + &
1453 : composite_density_grad(composite_row, ispin)* &
1454 : interpolate_native_grid(composite_smooth_rhob, &
1455 : smooth_rho_r(1)%pw_grid, cell, &
1456 : composite_grid_coords(:, composite_row)) + &
1457 : composite_kin_grad(composite_row, ispin)* &
1458 : interpolate_native_grid(composite_smooth_tau_b, &
1459 : smooth_rho_r(1)%pw_grid, cell, &
1460 0 : composite_grid_coords(:, composite_row))
1461 0 : DO idir = 1, 3
1462 : smooth_input_contraction = smooth_input_contraction + &
1463 : composite_grad_grad(composite_row, idir, ispin)* &
1464 : interpolate_native_grid(composite_smooth_drhob(idir)%array, &
1465 : smooth_rho_r(1)%pw_grid, cell, &
1466 0 : composite_grid_coords(:, composite_row))
1467 : END DO
1468 : END IF
1469 : ELSE
1470 : smooth_input_contraction = smooth_input_contraction + 0.5_dp*( &
1471 : composite_density_grad(composite_row, ispin)* &
1472 : interpolate_native_grid( &
1473 : composite_smooth_rho, smooth_rho_r(1)%pw_grid, cell, &
1474 : composite_grid_coords(:, composite_row)) + &
1475 : composite_kin_grad(composite_row, ispin)* &
1476 : interpolate_native_grid( &
1477 : composite_smooth_tau, smooth_rho_r(1)%pw_grid, cell, &
1478 140000 : composite_grid_coords(:, composite_row)))
1479 560000 : DO idir = 1, 3
1480 : smooth_input_contraction = smooth_input_contraction + 0.5_dp* &
1481 : composite_grad_grad(composite_row, idir, ispin)* &
1482 : interpolate_native_grid( &
1483 : composite_smooth_drho(idir)%array, &
1484 : smooth_rho_r(1)%pw_grid, cell, &
1485 560000 : composite_grid_coords(:, composite_row))
1486 : END DO
1487 : END IF
1488 : END DO
1489 : END DO
1490 : ! The interpolation transpose still uses CP2K's global FFT-grid layout. Reduce only
1491 : ! this PW adjoint; atom-grid feature rows and their model derivatives stay rank-local.
1492 28 : CALL para_env%sum(smooth_density_adjoint)
1493 28 : CALL para_env%sum(smooth_grad_adjoint)
1494 28 : CALL para_env%sum(smooth_kin_adjoint)
1495 28 : CALL para_env%sum(smooth_input_contraction)
1496 : CALL build_vxc_from_feature_grads( &
1497 : smooth_vxc_rho, smooth_vxc_tau, smooth_rho_r, auxbas_pw_pool, &
1498 : smooth_density_adjoint, smooth_grad_adjoint, smooth_kin_adjoint, &
1499 28 : xc_deriv_method_id, global_grid_layout=.TRUE.)
1500 28 : smooth_grid_contraction = 0.0_dp
1501 56 : DO ispin = 1, nspins
1502 : smooth_grid_contraction = smooth_grid_contraction + smooth_rho_r(1)%pw_grid%dvol* &
1503 : (SUM(smooth_vxc_rho(ispin)%array* &
1504 : smooth_rho_r(ispin)%array) + &
1505 : SUM(smooth_vxc_tau(ispin)%array* &
1506 1268488 : smooth_tau_r(ispin)%array))
1507 28 : IF (atom_composite_reference) THEN
1508 28 : CPASSERT(PRESENT(composite_vxc_rho))
1509 28 : CPASSERT(PRESENT(composite_vxc_tau))
1510 28 : CPASSERT(ASSOCIATED(composite_vxc_rho))
1511 28 : CPASSERT(ASSOCIATED(composite_vxc_tau))
1512 28 : CPASSERT(SIZE(composite_vxc_rho) == nspins)
1513 28 : CPASSERT(SIZE(composite_vxc_tau) == nspins)
1514 28 : CALL pw_axpy(smooth_vxc_rho(ispin), composite_vxc_rho(ispin), 1.0_dp)
1515 28 : CALL pw_axpy(smooth_vxc_tau(ispin), composite_vxc_tau(ispin), 1.0_dp)
1516 : END IF
1517 28 : CALL auxbas_pw_pool%give_back_pw(smooth_vxc_rho(ispin))
1518 56 : CALL auxbas_pw_pool%give_back_pw(smooth_vxc_tau(ispin))
1519 : END DO
1520 28 : CALL para_env%sum(smooth_grid_contraction)
1521 28 : DEALLOCATE (smooth_vxc_rho, smooth_vxc_tau)
1522 :
1523 28 : one_center_field_contraction = 0.0_dp
1524 28 : one_center_matrix_contraction = 0.0_dp
1525 28 : one_center_density_field_contraction = 0.0_dp
1526 28 : one_center_density_matrix_contraction = 0.0_dp
1527 28 : one_center_gradient_field_contraction = 0.0_dp
1528 28 : one_center_gradient_matrix_contraction = 0.0_dp
1529 28 : one_center_rho_grad_field_contraction = 0.0_dp
1530 28 : one_center_rho_grad_matrix_contraction = 0.0_dp
1531 28 : one_center_tau_field_contraction = 0.0_dp
1532 28 : one_center_tau_matrix_contraction = 0.0_dp
1533 60 : DO ikind = 1, SIZE(atomic_kind_set)
1534 32 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
1535 32 : NULLIFY (gth_potential, sgp_potential)
1536 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
1537 : gth_potential=gth_potential, harmonics=harmonics, &
1538 : grid_atom=grid_atom, sgp_potential=sgp_potential, &
1539 32 : zatom=zatom, zeff=zeff)
1540 32 : CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
1541 32 : IF (.NOT. paw_atom) CYCLE
1542 : IF (.NOT. force_paw_representation .AND. &
1543 32 : (ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential)) .AND. &
1544 : ABS(zeff - REAL(zatom, dp)) <= 1.0E-10_dp) CYCLE
1545 :
1546 32 : nr = grid_atom%nr
1547 32 : na = grid_atom%ng_sphere
1548 32 : CALL reallocate(rho_h, 1, na, 1, nr, 1, nspins)
1549 32 : CALL reallocate(rho_s, 1, na, 1, nr, 1, nspins)
1550 32 : CALL reallocate(vxc_h, 1, na, 1, nr, 1, nspins)
1551 32 : CALL reallocate(vxc_s, 1, na, 1, nr, 1, nspins)
1552 32 : CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
1553 32 : CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
1554 32 : CALL reallocate(vxg_h, 1, 3, 1, na, 1, nr, 1, nspins)
1555 32 : CALL reallocate(vxg_s, 1, 3, 1, na, 1, nr, 1, nspins)
1556 32 : CALL reallocate(tau_h, 1, na, 1, nr, 1, nspins)
1557 32 : CALL reallocate(tau_s, 1, na, 1, nr, 1, nspins)
1558 32 : CALL reallocate(vtau_h, 1, na, 1, nr, 1, nspins)
1559 32 : CALL reallocate(vtau_s, 1, na, 1, nr, 1, nspins)
1560 32 : CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
1561 :
1562 32 : bo = get_limit(natom, para_env%num_pe, para_env%mepos)
1563 60 : DO iat = bo(1), bo(2)
1564 28 : iatom = atom_list(iat)
1565 28 : rho_atom => my_rho_atom_set(iatom)
1566 28 : NULLIFY (cpc_h, cpc_s, r_h, r_s, dr_h, dr_s, r_h_d, r_s_d, int_hh, int_ss)
1567 : CALL get_rho_atom(rho_atom=rho_atom, cpc_h=cpc_h, cpc_s=cpc_s, &
1568 : rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
1569 : drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d, &
1570 28 : ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
1571 71456 : rho_h = 0.0_dp
1572 71456 : rho_s = 0.0_dp
1573 351456 : drho_h = 0.0_dp
1574 351456 : drho_s = 0.0_dp
1575 28 : CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
1576 1428 : DO ir = 1, nr
1577 : CALL calc_rho_angular(grid_atom, harmonics, nspins, .TRUE., &
1578 : ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
1579 1428 : r_h_d, r_s_d, drho_h, drho_s)
1580 : END DO
1581 :
1582 71456 : vxc_h = 0.0_dp
1583 71456 : vxc_s = 0.0_dp
1584 281456 : vxg_h = 0.0_dp
1585 281456 : vxg_s = 0.0_dp
1586 71456 : vtau_h = 0.0_dp
1587 71456 : vtau_s = 0.0_dp
1588 28 : composite_row = composite_atom_start(iatom) - 1
1589 1428 : DO ir = 1, nr
1590 71428 : DO ia = 1, na
1591 70000 : composite_row = composite_row + 1
1592 71400 : IF (lsd) THEN
1593 0 : IF (atom_composite_components <= 2) THEN
1594 0 : vxc_h(ia, ir, 1:2) = composite_density_grad(composite_row, 1:2)
1595 0 : vxc_s(ia, ir, 1:2) = composite_density_grad(composite_row, 1:2)
1596 0 : DO idir = 1, 3
1597 : vxg_h(idir, ia, ir, 1:2) = &
1598 0 : composite_grad_grad(composite_row, idir, 1:2)
1599 : vxg_s(idir, ia, ir, 1:2) = &
1600 0 : composite_grad_grad(composite_row, idir, 1:2)
1601 : END DO
1602 : END IF
1603 0 : IF (atom_composite_components == 1 .OR. &
1604 : atom_composite_components == 3) THEN
1605 0 : vtau_h(ia, ir, 1:2) = composite_kin_grad(composite_row, 1:2)
1606 0 : vtau_s(ia, ir, 1:2) = composite_kin_grad(composite_row, 1:2)
1607 : END IF
1608 : ELSE
1609 70000 : IF (atom_composite_components <= 2) THEN
1610 : vxc_h(ia, ir, 1) = 0.5_dp* &
1611 210000 : SUM(composite_density_grad(composite_row, :))
1612 70000 : vxc_s(ia, ir, 1) = vxc_h(ia, ir, 1)
1613 280000 : DO idir = 1, 3
1614 : vxg_h(idir, ia, ir, 1) = 0.5_dp* &
1615 : SUM(composite_grad_grad( &
1616 630000 : composite_row, idir, :))
1617 280000 : vxg_s(idir, ia, ir, 1) = vxg_h(idir, ia, ir, 1)
1618 : END DO
1619 : END IF
1620 70000 : IF (atom_composite_components == 1 .OR. &
1621 : atom_composite_components == 3) THEN
1622 : vtau_h(ia, ir, 1) = 0.5_dp* &
1623 210000 : SUM(composite_kin_grad(composite_row, :))
1624 70000 : vtau_s(ia, ir, 1) = vtau_h(ia, ir, 1)
1625 : END IF
1626 : END IF
1627 : END DO
1628 : END DO
1629 28 : CPASSERT(composite_row == composite_atom_end(iatom))
1630 :
1631 : one_center_rho_grad_field_contraction = &
1632 : one_center_rho_grad_field_contraction + SUM(vxc_h*(rho_h - rho_s)) + &
1633 352884 : SUM(vxg_h*(drho_h(1:3, :, :, :) - drho_s(1:3, :, :, :)))
1634 : one_center_density_field_contraction = one_center_density_field_contraction + &
1635 71456 : SUM(vxc_h*(rho_h - rho_s))
1636 : one_center_gradient_field_contraction = one_center_gradient_field_contraction + &
1637 : SUM(vxg_h*(drho_h(1:3, :, :, :) - &
1638 281456 : drho_s(1:3, :, :, :)))
1639 : one_center_tau_field_contraction = one_center_tau_field_contraction + &
1640 71456 : SUM(vtau_h*(tau_h - tau_s))
1641 :
1642 0 : ALLOCATE (composite_int_h(SIZE(int_hh(1)%r_coef, 1), &
1643 : SIZE(int_hh(1)%r_coef, 2), nspins), &
1644 0 : composite_int_s(SIZE(int_ss(1)%r_coef, 1), &
1645 252 : SIZE(int_ss(1)%r_coef, 2), nspins))
1646 56 : DO ispin = 1, nspins
1647 9296 : composite_int_h(:, :, ispin) = int_hh(ispin)%r_coef
1648 9296 : composite_int_s(:, :, ispin) = int_ss(ispin)%r_coef
1649 9296 : int_hh(ispin)%r_coef = 0.0_dp
1650 9324 : int_ss(ispin)%r_coef = 0.0_dp
1651 : END DO
1652 : CALL gaVxcgb_noGC(vxc_h, vxc_s, int_hh, int_ss, &
1653 28 : grid_atom, basis_1c, harmonics, nspins)
1654 56 : DO ispin = 1, nspins
1655 : one_center_density_matrix_contraction = &
1656 : one_center_density_matrix_contraction + &
1657 : contract_one_center_matrix(cpc_h(ispin)%r_coef, &
1658 : int_hh(ispin)%r_coef, &
1659 : tau_basis_cache%n2oindex) - &
1660 : contract_one_center_matrix(cpc_s(ispin)%r_coef, &
1661 : int_ss(ispin)%r_coef, &
1662 28 : tau_basis_cache%n2oindex)
1663 9296 : int_hh(ispin)%r_coef = 0.0_dp
1664 9324 : int_ss(ispin)%r_coef = 0.0_dp
1665 : END DO
1666 : CALL gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
1667 28 : grid_atom, basis_1c, harmonics, nspins)
1668 56 : DO ispin = 1, nspins
1669 : one_center_rho_grad_matrix_contraction = &
1670 : one_center_rho_grad_matrix_contraction + &
1671 : contract_one_center_matrix(cpc_h(ispin)%r_coef, &
1672 : int_hh(ispin)%r_coef, &
1673 : tau_basis_cache%n2oindex) - &
1674 : contract_one_center_matrix(cpc_s(ispin)%r_coef, &
1675 : int_ss(ispin)%r_coef, &
1676 56 : tau_basis_cache%n2oindex)
1677 : END DO
1678 28 : CALL dgaVtaudgb(vtau_h, vtau_s, int_hh, int_ss, tau_basis_cache, nspins)
1679 56 : DO ispin = 1, nspins
1680 : one_center_matrix_contraction = one_center_matrix_contraction + &
1681 : contract_one_center_matrix(cpc_h(ispin)%r_coef, &
1682 : int_hh(ispin)%r_coef, &
1683 : tau_basis_cache%n2oindex) - &
1684 : contract_one_center_matrix(cpc_s(ispin)%r_coef, &
1685 : int_ss(ispin)%r_coef, &
1686 28 : tau_basis_cache%n2oindex)
1687 56 : IF (.NOT. atom_composite_reference) THEN
1688 0 : int_hh(ispin)%r_coef = composite_int_h(:, :, ispin)
1689 0 : int_ss(ispin)%r_coef = composite_int_s(:, :, ispin)
1690 : END IF
1691 : END DO
1692 60 : DEALLOCATE (composite_int_h, composite_int_s)
1693 : END DO
1694 92 : CALL release_tau_basis_cache(tau_basis_cache)
1695 : END DO
1696 28 : CALL para_env%sum(one_center_density_field_contraction)
1697 28 : CALL para_env%sum(one_center_density_matrix_contraction)
1698 28 : CALL para_env%sum(one_center_gradient_field_contraction)
1699 28 : CALL para_env%sum(one_center_matrix_contraction)
1700 28 : CALL para_env%sum(one_center_rho_grad_field_contraction)
1701 28 : CALL para_env%sum(one_center_rho_grad_matrix_contraction)
1702 28 : CALL para_env%sum(one_center_tau_field_contraction)
1703 : one_center_field_contraction = one_center_rho_grad_field_contraction + &
1704 28 : one_center_tau_field_contraction
1705 : one_center_gradient_matrix_contraction = one_center_rho_grad_matrix_contraction - &
1706 28 : one_center_density_matrix_contraction
1707 : one_center_tau_matrix_contraction = one_center_matrix_contraction - &
1708 28 : one_center_rho_grad_matrix_contraction
1709 140084 : feature_component_analytic(1) = SUM(composite_density_grad*composite_density)
1710 420252 : feature_component_analytic(2) = SUM(composite_grad_grad*composite_grad)
1711 140084 : feature_component_analytic(3) = SUM(composite_kin_grad*composite_kin)
1712 112 : feature_component_analytic(4) = SUM(feature_component_analytic(1:3))
1713 28 : CALL para_env%sum(feature_component_analytic)
1714 : one_center_tensor_contraction = feature_component_analytic(4) - &
1715 28 : smooth_input_contraction
1716 28 : IF (atom_composite_diagnostic) THEN
1717 0 : DO icomponent = 1, 4
1718 0 : SELECT CASE (icomponent)
1719 : CASE (1)
1720 0 : composite_density = (1.0_dp + feature_vxc_step)*composite_density
1721 : CASE (2)
1722 0 : composite_grad = (1.0_dp + feature_vxc_step)*composite_grad
1723 : CASE (3)
1724 0 : composite_kin = (1.0_dp + feature_vxc_step)*composite_kin
1725 : CASE (4)
1726 0 : composite_density = (1.0_dp + feature_vxc_step)*composite_density
1727 0 : composite_grad = (1.0_dp + feature_vxc_step)*composite_grad
1728 0 : composite_kin = (1.0_dp + feature_vxc_step)*composite_kin
1729 : END SELECT
1730 : CALL skala_gapw_atom_composite_energy( &
1731 : my_xc_section, para_env, composite_density, composite_grad, composite_kin, &
1732 : composite_grid_coords, composite_grid_weights, composite_atomic_grid_weights, &
1733 0 : composite_local_grid_sizes, composite_local_atom_coords, feature_vxc_plus)
1734 0 : SELECT CASE (icomponent)
1735 : CASE (1)
1736 : composite_density = ((1.0_dp - feature_vxc_step)/ &
1737 0 : (1.0_dp + feature_vxc_step))*composite_density
1738 : CASE (2)
1739 : composite_grad = ((1.0_dp - feature_vxc_step)/ &
1740 0 : (1.0_dp + feature_vxc_step))*composite_grad
1741 : CASE (3)
1742 : composite_kin = ((1.0_dp - feature_vxc_step)/ &
1743 0 : (1.0_dp + feature_vxc_step))*composite_kin
1744 : CASE (4)
1745 : composite_density = ((1.0_dp - feature_vxc_step)/ &
1746 0 : (1.0_dp + feature_vxc_step))*composite_density
1747 : composite_grad = ((1.0_dp - feature_vxc_step)/ &
1748 0 : (1.0_dp + feature_vxc_step))*composite_grad
1749 : composite_kin = ((1.0_dp - feature_vxc_step)/ &
1750 0 : (1.0_dp + feature_vxc_step))*composite_kin
1751 : END SELECT
1752 : CALL skala_gapw_atom_composite_energy( &
1753 : my_xc_section, para_env, composite_density, composite_grad, composite_kin, &
1754 : composite_grid_coords, composite_grid_weights, composite_atomic_grid_weights, &
1755 0 : composite_local_grid_sizes, composite_local_atom_coords, feature_vxc_minus)
1756 0 : SELECT CASE (icomponent)
1757 : CASE (1)
1758 0 : composite_density = composite_density/(1.0_dp - feature_vxc_step)
1759 : CASE (2)
1760 0 : composite_grad = composite_grad/(1.0_dp - feature_vxc_step)
1761 : CASE (3)
1762 0 : composite_kin = composite_kin/(1.0_dp - feature_vxc_step)
1763 : CASE (4)
1764 0 : composite_density = composite_density/(1.0_dp - feature_vxc_step)
1765 0 : composite_grad = composite_grad/(1.0_dp - feature_vxc_step)
1766 0 : composite_kin = composite_kin/(1.0_dp - feature_vxc_step)
1767 : END SELECT
1768 : feature_component_fd(icomponent) = &
1769 0 : (feature_vxc_plus - feature_vxc_minus)/(2.0_dp*feature_vxc_step)
1770 : END DO
1771 0 : feature_vxc_analytic = feature_component_analytic(4)
1772 0 : feature_vxc_fd = feature_component_fd(4)
1773 0 : iw = cp_logger_get_default_io_unit()
1774 0 : IF (iw > 0) THEN
1775 : WRITE (UNIT=iw, FMT="(T2,A,1X,I0)") &
1776 0 : "SKALA_GPW| Atom-composite reference components", atom_composite_components
1777 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1778 0 : "SKALA_GPW| Atom-composite reference electrons", atom_composite_nelec
1779 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1780 0 : "SKALA_GPW| Atom-composite reference XC energy", atom_composite_exc
1781 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1782 0 : "SKALA_GPW| Atom-composite feature VXC contraction", feature_vxc_analytic
1783 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1784 0 : "SKALA_GPW| Atom-composite feature finite difference", feature_vxc_fd
1785 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1786 0 : "SKALA_GPW| Atom-composite feature VXC error", &
1787 0 : feature_vxc_analytic - feature_vxc_fd
1788 : WRITE (UNIT=iw, FMT="(T2,A,3(1X,ES24.16))") &
1789 0 : "SKALA_GPW| Atom-composite smooth PW adjoint", smooth_input_contraction, &
1790 0 : smooth_grid_contraction, smooth_grid_contraction - smooth_input_contraction
1791 : WRITE (UNIT=iw, FMT="(T2,A,4(1X,ES24.16))") &
1792 0 : "SKALA_GPW| Atom-composite one-center adjoint", one_center_tensor_contraction, &
1793 0 : one_center_field_contraction, one_center_matrix_contraction, &
1794 0 : one_center_matrix_contraction - one_center_tensor_contraction
1795 : WRITE (UNIT=iw, FMT="(T2,A,4(1X,ES24.16))") &
1796 0 : "SKALA_GPW| Atom-composite one-center channels", &
1797 0 : one_center_rho_grad_field_contraction, one_center_rho_grad_matrix_contraction, &
1798 0 : one_center_tau_field_contraction, one_center_tau_matrix_contraction
1799 : WRITE (UNIT=iw, FMT="(T2,A,4(1X,ES24.16))") &
1800 0 : "SKALA_GPW| Atom-composite one-center rho-gradient", &
1801 0 : one_center_density_field_contraction, one_center_density_matrix_contraction, &
1802 0 : one_center_gradient_field_contraction, one_center_gradient_matrix_contraction
1803 0 : DO icomponent = 1, 3
1804 : WRITE (UNIT=iw, FMT="(T2,A,1X,I0,3(1X,ES24.16))") &
1805 0 : "SKALA_GPW| Atom-composite component VXC", icomponent, &
1806 0 : feature_component_analytic(icomponent), feature_component_fd(icomponent), &
1807 0 : feature_component_analytic(icomponent) - feature_component_fd(icomponent)
1808 : END DO
1809 : END IF
1810 : END IF
1811 28 : IF (atom_composite_reference) THEN
1812 28 : exc1 = atom_composite_exc
1813 28 : IF (native_grid_diagnostics) THEN
1814 28 : IF (composite_nflat > 0) THEN
1815 140078 : composite_density_min = MINVAL(composite_density)
1816 140078 : composite_density_max = MAXVAL(composite_density)
1817 140078 : composite_kin_min = MINVAL(composite_kin)
1818 140078 : composite_kin_max = MAXVAL(composite_kin)
1819 420234 : composite_grad_max = MAXVAL(ABS(composite_grad))
1820 : ELSE
1821 2 : composite_density_min = HUGE(1.0_dp)
1822 2 : composite_density_max = -HUGE(1.0_dp)
1823 2 : composite_kin_min = HUGE(1.0_dp)
1824 2 : composite_kin_max = -HUGE(1.0_dp)
1825 2 : composite_grad_max = 0.0_dp
1826 : END IF
1827 : composite_tau_integral = &
1828 210028 : SUM(composite_grid_weights*SUM(composite_kin, DIM=2))
1829 28 : CALL para_env%min(composite_density_min)
1830 28 : CALL para_env%max(composite_density_max)
1831 28 : CALL para_env%min(composite_kin_min)
1832 28 : CALL para_env%max(composite_kin_max)
1833 28 : CALL para_env%max(composite_grad_max)
1834 28 : CALL para_env%sum(composite_tau_integral)
1835 : END IF
1836 28 : iw = cp_logger_get_default_io_unit()
1837 28 : IF (iw > 0) THEN
1838 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1839 14 : "SKALA_GPW| Active atom-composite XC energy", atom_composite_exc
1840 14 : IF (native_grid_diagnostics) THEN
1841 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1842 14 : "SKALA_GPW| Active atom-composite electrons", atom_composite_nelec
1843 : WRITE (UNIT=iw, FMT="(T2,A,2(1X,ES24.16))") &
1844 14 : "SKALA_GPW| Active atom-composite density range", &
1845 28 : composite_density_min, composite_density_max
1846 : WRITE (UNIT=iw, FMT="(T2,A,2(1X,ES24.16))") &
1847 14 : "SKALA_GPW| Active atom-composite tau range", &
1848 28 : composite_kin_min, composite_kin_max
1849 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1850 14 : "SKALA_GPW| Active atom-composite tau integral", &
1851 28 : composite_tau_integral
1852 : WRITE (UNIT=iw, FMT="(T2,A,1X,ES24.16)") &
1853 14 : "SKALA_GPW| Active atom-composite max gradient", &
1854 28 : composite_grad_max
1855 : END IF
1856 : END IF
1857 : END IF
1858 28 : CALL xc_rho_set_release(smooth_rho_set, pw_pool=auxbas_pw_pool)
1859 0 : DEALLOCATE (composite_atomic_grid_sizes, composite_atom_kind, &
1860 0 : composite_atom_kind_index, composite_atom_start, composite_atom_end, &
1861 0 : composite_atom_coords, composite_local_atoms, composite_local_grid_sizes, &
1862 0 : composite_local_atom_coords, &
1863 0 : composite_partition_weights, composite_partition_atom_coords, &
1864 0 : composite_distances, composite_density, composite_grad, composite_kin, &
1865 0 : composite_density_grad, composite_grad_grad, composite_kin_grad, &
1866 0 : smooth_density_adjoint, smooth_grad_adjoint, smooth_kin_adjoint, &
1867 0 : composite_grid_coords, composite_grid_weights, &
1868 28 : composite_atomic_grid_weights)
1869 28 : IF (lsd) THEN
1870 0 : DEALLOCATE (composite_smooth_rhoa, composite_smooth_rhob, &
1871 0 : composite_smooth_tau_a, composite_smooth_tau_b)
1872 0 : DO idir = 1, 3
1873 0 : DEALLOCATE (composite_smooth_drhoa(idir)%array, &
1874 0 : composite_smooth_drhob(idir)%array)
1875 : END DO
1876 : ELSE
1877 28 : DEALLOCATE (composite_smooth_rho, composite_smooth_tau)
1878 112 : DO idir = 1, 3
1879 112 : DEALLOCATE (composite_smooth_drho(idir)%array)
1880 : END DO
1881 : END IF
1882 : END IF
1883 :
1884 27870 : IF (.NOT. atom_composite_reference) CALL para_env%sum(exc1)
1885 :
1886 27870 : IF (ASSOCIATED(rho_h)) DEALLOCATE (rho_h)
1887 27870 : IF (ASSOCIATED(rho_s)) DEALLOCATE (rho_s)
1888 27870 : IF (ASSOCIATED(vxc_h)) DEALLOCATE (vxc_h)
1889 27870 : IF (ASSOCIATED(vxc_s)) DEALLOCATE (vxc_s)
1890 :
1891 27870 : IF (gradient_f) THEN
1892 19134 : IF (ASSOCIATED(drho_h)) DEALLOCATE (drho_h)
1893 19134 : IF (ASSOCIATED(drho_s)) DEALLOCATE (drho_s)
1894 19134 : IF (ASSOCIATED(vxg_h)) DEALLOCATE (vxg_h)
1895 19134 : IF (ASSOCIATED(vxg_s)) DEALLOCATE (vxg_s)
1896 : END IF
1897 :
1898 27870 : IF (tau_f) THEN
1899 752 : IF (ASSOCIATED(tau_h)) DEALLOCATE (tau_h)
1900 752 : IF (ASSOCIATED(tau_s)) DEALLOCATE (tau_s)
1901 752 : IF (ASSOCIATED(vtau_h)) DEALLOCATE (vtau_h)
1902 752 : IF (ASSOCIATED(vtau_s)) DEALLOCATE (vtau_s)
1903 : END IF
1904 :
1905 : END IF !xc_none
1906 :
1907 32056 : CALL timestop(handle)
1908 :
1909 1859248 : END SUBROUTINE calculate_vxc_atom
1910 :
1911 : ! **************************************************************************************************
1912 : !> \brief Add the GAPW one-center correction to CDFT values and operators.
1913 : !> \param qs_env Quickstep environment
1914 : !> \param energy_only skip construction of the CDFT one-center operator
1915 : !> \param calculate_forces evaluate explicit derivatives of the partition weights
1916 : !> \param values constraint values from the hard-minus-soft one-center densities
1917 : !> \param electronic_charge optional one-center corrections to atomic populations
1918 : !> \param operator_group optional group for which to build the unscaled weight operator
1919 : !> \param rho_atom_operator_set optional destination for the one-center operator integrals
1920 : ! **************************************************************************************************
1921 424 : SUBROUTINE gapw_cdft_one_center(qs_env, energy_only, calculate_forces, values, &
1922 424 : electronic_charge, operator_group, rho_atom_operator_set)
1923 : TYPE(qs_environment_type), POINTER :: qs_env
1924 : LOGICAL, INTENT(IN) :: energy_only, calculate_forces
1925 : REAL(KIND=dp), DIMENSION(:), INTENT(OUT) :: values
1926 : REAL(KIND=dp), DIMENSION(:, :), INTENT(OUT), &
1927 : OPTIONAL :: electronic_charge
1928 : INTEGER, INTENT(IN), OPTIONAL :: operator_group
1929 : TYPE(rho_atom_type), DIMENSION(:), POINTER, &
1930 : OPTIONAL :: rho_atom_operator_set
1931 :
1932 : INTEGER :: atom, channel, ia, iat, igroup, ikind, &
1933 : ir, natom, natom_kind, nspins
1934 : INTEGER, DIMENSION(2) :: atom_bounds
1935 424 : INTEGER, DIMENSION(:), POINTER :: atom_list
1936 : LOGICAL :: lsd, paw_atom
1937 : REAL(KIND=dp) :: delta_density, point_factor, spin_factor
1938 424 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:) :: atomic_weights, group_weights
1939 424 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :) :: explicit_derivative, &
1940 424 : group_point_derivative
1941 424 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :) :: group_atom_derivative
1942 : REAL(KIND=dp), DIMENSION(3) :: point
1943 424 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: rho_h, rho_s
1944 424 : REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s
1945 424 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: vlocal_h, vlocal_s
1946 424 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
1947 : TYPE(cdft_control_type), POINTER :: cdft_control
1948 424 : TYPE(cdft_point_context_type) :: context
1949 : TYPE(dft_control_type), POINTER :: dft_control
1950 : TYPE(grid_atom_type), POINTER :: grid_atom
1951 : TYPE(gto_basis_set_type), POINTER :: basis_1c
1952 : TYPE(harmonics_atom_type), POINTER :: harmonics
1953 : TYPE(mp_para_env_type), POINTER :: para_env
1954 424 : TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
1955 424 : TYPE(qs_force_type), DIMENSION(:), POINTER :: force
1956 424 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
1957 424 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s, int_hh, int_ss, r_h, r_s
1958 424 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
1959 424 : TYPE(rho_atom_type), DIMENSION(:), POINTER :: operator_atom_set, rho_atom_set
1960 : TYPE(rho_atom_type), POINTER :: operator_atom, rho_atom
1961 :
1962 424 : NULLIFY (atom_list, atomic_kind_set, basis_1c, cdft_control, dft_control, force, &
1963 424 : grid_atom, harmonics, int_hh, int_ss, para_env, particle_set, r_h, r_s, &
1964 424 : dr_h, dr_s, r_h_d, r_s_d, rho_h, rho_s, drho_h, drho_s, &
1965 424 : operator_atom, operator_atom_set, rho_atom, rho_atom_set, qs_kind_set, &
1966 424 : vlocal_h, vlocal_s)
1967 : CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, dft_control=dft_control, &
1968 : force=force, natom=natom, para_env=para_env, particle_set=particle_set, &
1969 424 : qs_kind_set=qs_kind_set, rho_atom_set=rho_atom_set)
1970 424 : CPASSERT(ASSOCIATED(atomic_kind_set))
1971 424 : CPASSERT(ASSOCIATED(dft_control))
1972 424 : CPASSERT(ASSOCIATED(para_env))
1973 424 : CPASSERT(ASSOCIATED(particle_set))
1974 424 : CPASSERT(ASSOCIATED(qs_kind_set))
1975 424 : CPASSERT(ASSOCIATED(rho_atom_set))
1976 424 : operator_atom_set => rho_atom_set
1977 424 : IF (PRESENT(rho_atom_operator_set)) operator_atom_set => rho_atom_operator_set
1978 424 : CPASSERT(ASSOCIATED(operator_atom_set))
1979 424 : cdft_control => dft_control%qs_control%cdft_control
1980 424 : CPASSERT(ASSOCIATED(cdft_control))
1981 424 : nspins = dft_control%nspins
1982 424 : lsd = dft_control%lsd
1983 424 : CPASSERT(SIZE(values) == SIZE(cdft_control%group))
1984 424 : IF (PRESENT(operator_group)) THEN
1985 4 : CPASSERT(operator_group >= 1 .AND. operator_group <= SIZE(cdft_control%group))
1986 : END IF
1987 424 : IF (PRESENT(electronic_charge)) THEN
1988 76 : CPASSERT(SIZE(electronic_charge, 1) == natom)
1989 76 : CPASSERT(SIZE(electronic_charge, 2) == nspins)
1990 : END IF
1991 :
1992 424 : CALL cdft_point_context_create(qs_env, context, calculate_forces)
1993 : ALLOCATE (group_weights(context%ngroup), group_point_derivative(3, context%ngroup), &
1994 : group_atom_derivative(3, natom, context%ngroup), &
1995 4240 : explicit_derivative(3, natom))
1996 576 : IF (PRESENT(electronic_charge)) ALLOCATE (atomic_weights(natom))
1997 920 : values = 0.0_dp
1998 424 : explicit_derivative = 0.0_dp
1999 972 : IF (PRESENT(electronic_charge)) electronic_charge = 0.0_dp
2000 :
2001 988 : DO ikind = 1, SIZE(atomic_kind_set)
2002 564 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom_kind)
2003 : CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom, grid_atom=grid_atom, &
2004 564 : harmonics=harmonics)
2005 564 : IF (.NOT. paw_atom) CYCLE
2006 564 : CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
2007 564 : CPASSERT(ASSOCIATED(grid_atom))
2008 564 : CPASSERT(ASSOCIATED(harmonics))
2009 564 : CPASSERT(ASSOCIATED(basis_1c))
2010 : ALLOCATE (vlocal_h(grid_atom%ng_sphere, grid_atom%nr, nspins), &
2011 5076 : vlocal_s(grid_atom%ng_sphere, grid_atom%nr, nspins))
2012 :
2013 564 : atom_bounds = get_limit(natom_kind, para_env%num_pe, para_env%mepos)
2014 1043 : DO iat = atom_bounds(1), atom_bounds(2)
2015 479 : atom = atom_list(iat)
2016 479 : rho_atom => rho_atom_set(atom)
2017 479 : NULLIFY (r_h, r_s)
2018 479 : CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s)
2019 479 : CALL reallocate(rho_h, 1, grid_atom%ng_sphere, 1, grid_atom%nr, 1, nspins)
2020 479 : CALL reallocate(rho_s, 1, grid_atom%ng_sphere, 1, grid_atom%nr, 1, nspins)
2021 1668833 : rho_h = 0.0_dp
2022 1668833 : rho_s = 0.0_dp
2023 24429 : DO ir = 1, grid_atom%nr
2024 : CALL calc_rho_angular(grid_atom, harmonics, nspins, .FALSE., ir, r_h, r_s, &
2025 24429 : rho_h, rho_s, dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s)
2026 : END DO
2027 1668833 : vlocal_h = 0.0_dp
2028 1668833 : vlocal_s = 0.0_dp
2029 :
2030 24429 : DO ir = 1, grid_atom%nr
2031 1221929 : DO ia = 1, grid_atom%ng_sphere
2032 : point(1) = particle_set(atom)%r(1) + grid_atom%rad(ir)* &
2033 1197500 : grid_atom%sin_pol(ia)*grid_atom%cos_azi(ia)
2034 : point(2) = particle_set(atom)%r(2) + grid_atom%rad(ir)* &
2035 1197500 : grid_atom%sin_pol(ia)*grid_atom%sin_azi(ia)
2036 1197500 : point(3) = particle_set(atom)%r(3) + grid_atom%rad(ir)*grid_atom%cos_pol(ia)
2037 1197500 : IF (PRESENT(electronic_charge)) THEN
2038 : CALL cdft_point_weights(context, point, group_weights, &
2039 : group_point_derivative, group_atom_derivative, &
2040 247500 : atomic_weights)
2041 : ELSE
2042 : CALL cdft_point_weights(context, point, group_weights, &
2043 950000 : group_point_derivative, group_atom_derivative)
2044 : END IF
2045 2856450 : DO channel = 1, nspins
2046 1635000 : delta_density = rho_h(ia, ir, channel) - rho_s(ia, ir, channel)
2047 1635000 : IF (PRESENT(electronic_charge)) THEN
2048 : electronic_charge(:, channel) = electronic_charge(:, channel) + &
2049 : grid_atom%weight(ia, ir)*atomic_weights* &
2050 1830000 : delta_density
2051 : END IF
2052 1635000 : point_factor = 0.0_dp
2053 3630000 : DO igroup = 1, context%ngroup
2054 : spin_factor = cdft_spin_factor( &
2055 1995000 : cdft_control%group(igroup)%constraint_type, channel, lsd)
2056 1995000 : IF (PRESENT(operator_group)) THEN
2057 10000 : IF (igroup == operator_group) THEN
2058 10000 : point_factor = point_factor + group_weights(igroup)
2059 : END IF
2060 : ELSE
2061 : point_factor = point_factor + cdft_control%strength(igroup)* &
2062 1985000 : group_weights(igroup)*spin_factor
2063 : END IF
2064 : values(igroup) = values(igroup) + grid_atom%weight(ia, ir)* &
2065 1995000 : group_weights(igroup)*delta_density*spin_factor
2066 3630000 : IF (calculate_forces) THEN
2067 : explicit_derivative(:, :) = &
2068 : explicit_derivative + grid_atom%weight(ia, ir)* &
2069 : cdft_control%strength(igroup)*delta_density* &
2070 367500 : spin_factor*group_atom_derivative(:, :, igroup)
2071 : explicit_derivative(:, atom) = explicit_derivative(:, atom) + &
2072 : grid_atom%weight(ia, ir)* &
2073 : cdft_control%strength(igroup)*delta_density* &
2074 150000 : spin_factor*group_point_derivative(:, igroup)
2075 : END IF
2076 : END DO
2077 1635000 : vlocal_h(ia, ir, channel) = grid_atom%weight(ia, ir)*point_factor
2078 2832500 : vlocal_s(ia, ir, channel) = vlocal_h(ia, ir, channel)
2079 : END DO
2080 : END DO
2081 : END DO
2082 :
2083 1043 : IF (.NOT. energy_only) THEN
2084 360 : NULLIFY (int_hh, int_ss)
2085 360 : operator_atom => operator_atom_set(atom)
2086 360 : CALL get_rho_atom(rho_atom=operator_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
2087 : CALL gaVxcgb_noGC(vlocal_h, vlocal_s, int_hh, int_ss, grid_atom, &
2088 360 : basis_1c, harmonics, nspins)
2089 : END IF
2090 : END DO
2091 1552 : DEALLOCATE (vlocal_h, vlocal_s)
2092 : END DO
2093 :
2094 1416 : CALL para_env%sum(values)
2095 424 : CALL para_env%sum(explicit_derivative)
2096 1520 : IF (PRESENT(electronic_charge)) CALL para_env%sum(electronic_charge)
2097 424 : IF (calculate_forces .AND. ASSOCIATED(force) .AND. para_env%is_source()) THEN
2098 9 : DO ikind = 1, SIZE(atomic_kind_set)
2099 5 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom_kind)
2100 18 : DO iat = 1, natom_kind
2101 9 : atom = atom_list(iat)
2102 : force(ikind)%rho_elec(:, iat) = force(ikind)%rho_elec(:, iat) + &
2103 41 : explicit_derivative(:, atom)
2104 : END DO
2105 : END DO
2106 : END IF
2107 :
2108 424 : IF (ASSOCIATED(rho_h)) DEALLOCATE (rho_h)
2109 424 : IF (ASSOCIATED(rho_s)) DEALLOCATE (rho_s)
2110 424 : IF (ALLOCATED(atomic_weights)) DEALLOCATE (atomic_weights)
2111 424 : DEALLOCATE (explicit_derivative, group_atom_derivative, group_point_derivative, group_weights)
2112 848 : CALL cdft_point_context_release(context)
2113 :
2114 : CONTAINS
2115 :
2116 : ! **************************************************************************************************
2117 : !> \brief ...
2118 : !> \param constraint_type ...
2119 : !> \param channel ...
2120 : !> \param lsd ...
2121 : !> \return ...
2122 : ! **************************************************************************************************
2123 1995000 : FUNCTION cdft_spin_factor(constraint_type, channel, lsd) RESULT(factor)
2124 : INTEGER, INTENT(IN) :: constraint_type, channel
2125 : LOGICAL, INTENT(IN) :: lsd
2126 : REAL(KIND=dp) :: factor
2127 :
2128 1995000 : SELECT CASE (constraint_type)
2129 : CASE (cdft_charge_constraint)
2130 0 : factor = 1.0_dp
2131 : CASE (cdft_magnetization_constraint)
2132 0 : CPASSERT(lsd)
2133 0 : factor = MERGE(1.0_dp, -1.0_dp, channel == 1)
2134 : CASE (cdft_alpha_constraint)
2135 360000 : CPASSERT(lsd)
2136 360000 : factor = MERGE(1.0_dp, 0.0_dp, channel == 1)
2137 : CASE (cdft_beta_constraint)
2138 360000 : CPASSERT(lsd)
2139 360000 : factor = MERGE(1.0_dp, 0.0_dp, channel == 2)
2140 : CASE DEFAULT
2141 1995000 : CPABORT("Unknown CDFT constraint type.")
2142 : END SELECT
2143 1995000 : END FUNCTION cdft_spin_factor
2144 :
2145 : END SUBROUTINE gapw_cdft_one_center
2146 :
2147 : ! **************************************************************************************************
2148 : !> \brief Contract a compact one-center density matrix with an integral in the padded old basis.
2149 : !> \param density_matrix ...
2150 : !> \param integral_matrix ...
2151 : !> \param new_to_old ...
2152 : !> \return ...
2153 : ! **************************************************************************************************
2154 168 : FUNCTION contract_one_center_matrix(density_matrix, integral_matrix, new_to_old) RESULT(value)
2155 : REAL(KIND=dp), DIMENSION(:, :), INTENT(IN) :: density_matrix, integral_matrix
2156 : INTEGER, DIMENSION(:), INTENT(IN) :: new_to_old
2157 : REAL(KIND=dp) :: value
2158 :
2159 : INTEGER :: ibas, jbas, nbas
2160 :
2161 168 : nbas = SIZE(density_matrix, 1)
2162 168 : CPASSERT(SIZE(density_matrix, 2) == nbas)
2163 168 : CPASSERT(SIZE(new_to_old) >= nbas)
2164 1644 : CPASSERT(MINVAL(new_to_old(1:nbas)) >= 1)
2165 1644 : CPASSERT(MAXVAL(new_to_old(1:nbas)) <= SIZE(integral_matrix, 1))
2166 1644 : CPASSERT(MAXVAL(new_to_old(1:nbas)) <= SIZE(integral_matrix, 2))
2167 :
2168 168 : value = 0.0_dp
2169 1644 : DO jbas = 1, nbas
2170 21576 : DO ibas = 1, nbas
2171 : value = value + density_matrix(ibas, jbas)* &
2172 21408 : integral_matrix(new_to_old(ibas), new_to_old(jbas))
2173 : END DO
2174 : END DO
2175 :
2176 168 : END FUNCTION contract_one_center_matrix
2177 :
2178 : ! **************************************************************************************************
2179 : !> \brief Replicate a distributed real-space field for atom-grid interpolation.
2180 : !> \param local_values ...
2181 : !> \param pw_grid ...
2182 : !> \param group ...
2183 : !> \param global_values ...
2184 : ! **************************************************************************************************
2185 140 : SUBROUTINE gather_native_grid_field(local_values, pw_grid, group, global_values)
2186 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN), &
2187 : POINTER :: local_values
2188 : TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
2189 : TYPE(mp_para_env_type), INTENT(IN) :: group
2190 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(OUT), &
2191 : POINTER :: global_values
2192 :
2193 : INTEGER, DIMENSION(2, 3) :: bo
2194 :
2195 140 : CPASSERT(ASSOCIATED(local_values))
2196 140 : CPASSERT(ASSOCIATED(pw_grid))
2197 140 : CPASSERT(.NOT. ASSOCIATED(global_values))
2198 1400 : bo = pw_grid%bounds_local
2199 : ALLOCATE (global_values(pw_grid%bounds(1, 1):pw_grid%bounds(2, 1), &
2200 : pw_grid%bounds(1, 2):pw_grid%bounds(2, 2), &
2201 700 : pw_grid%bounds(1, 3):pw_grid%bounds(2, 3)))
2202 6167480 : global_values = 0.0_dp
2203 : global_values(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), bo(1, 3):bo(2, 3)) = &
2204 6342580 : local_values
2205 12334820 : CALL group%sum(global_values)
2206 :
2207 140 : END SUBROUTINE gather_native_grid_field
2208 :
2209 : ! **************************************************************************************************
2210 : !> \brief Interpolate a replicated native-grid field at a Cartesian point.
2211 : !> \param values ...
2212 : !> \param pw_grid ...
2213 : !> \param cell ...
2214 : !> \param point ...
2215 : !> \return ...
2216 : ! **************************************************************************************************
2217 1050000 : FUNCTION interpolate_native_grid(values, pw_grid, cell, point) RESULT(value)
2218 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: values
2219 : TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
2220 : TYPE(cell_type), INTENT(IN), POINTER :: cell
2221 : REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: point
2222 : REAL(KIND=dp) :: value
2223 :
2224 : INTEGER :: corner_x, corner_y, corner_z, idir
2225 : INTEGER, DIMENSION(3) :: base, index, relative_index
2226 : REAL(KIND=dp) :: coefficient
2227 : REAL(KIND=dp), DIMENSION(3) :: fraction, relative
2228 : REAL(KIND=dp), &
2229 : DIMENSION(native_grid_interp_npts, 3) :: weights
2230 :
2231 1050000 : CPASSERT(ASSOCIATED(pw_grid))
2232 1050000 : CPASSERT(ASSOCIATED(cell))
2233 4200000 : DO idir = 1, 3
2234 4200000 : CPASSERT(SIZE(values, idir) == pw_grid%npts(idir))
2235 : END DO
2236 :
2237 13650000 : relative = MATMUL(pw_grid%dh_inv, point)
2238 3828390 : DO idir = 1, 3
2239 2942700 : IF (cell%perd(idir) == 1) THEN
2240 0 : relative(idir) = MODULO(relative(idir), REAL(pw_grid%npts(idir), KIND=dp))
2241 2942700 : ELSE IF (relative(idir) <= -REAL(native_grid_interp_offset_max, dp) .OR. &
2242 : relative(idir) >= REAL(pw_grid%npts(idir) - &
2243 : native_grid_interp_offset_min, KIND=dp)) THEN
2244 1050000 : value = 0.0_dp
2245 : RETURN
2246 : END IF
2247 2778390 : base(idir) = FLOOR(relative(idir))
2248 2778390 : FRACTION(idir) = relative(idir) - REAL(base(idir), KIND=dp)
2249 3664080 : CALL native_grid_lagrange_weights(FRACTION(idir), weights(:, idir))
2250 : END DO
2251 :
2252 : value = 0.0_dp
2253 7971210 : DO corner_z = native_grid_interp_offset_min, native_grid_interp_offset_max
2254 64655370 : DO corner_y = native_grid_interp_offset_min, native_grid_interp_offset_max
2255 517242960 : DO corner_x = native_grid_interp_offset_min, native_grid_interp_offset_max
2256 1813893120 : relative_index = base + [corner_x, corner_y, corner_z]
2257 : coefficient = weights(corner_x - native_grid_interp_offset_min + 1, 1)* &
2258 : weights(corner_y - native_grid_interp_offset_min + 1, 2)* &
2259 453473280 : weights(corner_z - native_grid_interp_offset_min + 1, 3)
2260 1813893120 : DO idir = 1, 3
2261 1813893120 : IF (cell%perd(idir) == 1) THEN
2262 0 : relative_index(idir) = MODULO(relative_index(idir), pw_grid%npts(idir))
2263 1360419840 : ELSE IF (relative_index(idir) < 0 .OR. &
2264 : relative_index(idir) >= pw_grid%npts(idir)) THEN
2265 25432320 : coefficient = 0.0_dp
2266 : END IF
2267 : END DO
2268 453473280 : IF (coefficient == 0.0_dp) CYCLE
2269 1728102960 : index = LBOUND(values) + relative_index
2270 510157440 : value = value + coefficient*values(INDEX(1), INDEX(2), INDEX(3))
2271 : END DO
2272 : END DO
2273 : END DO
2274 :
2275 : END FUNCTION interpolate_native_grid
2276 :
2277 : ! **************************************************************************************************
2278 : !> \brief Return the Cartesian gradient of native-grid interpolation at one point.
2279 : !> \param values ...
2280 : !> \param pw_grid ...
2281 : !> \param cell ...
2282 : !> \param point ...
2283 : !> \return ...
2284 : ! **************************************************************************************************
2285 50000 : FUNCTION interpolate_native_grid_gradient(values, pw_grid, cell, point) RESULT(gradient)
2286 : REAL(KIND=dp), DIMENSION(:, :, :), INTENT(IN) :: values
2287 : TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
2288 : TYPE(cell_type), INTENT(IN), POINTER :: cell
2289 : REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: point
2290 : REAL(KIND=dp), DIMENSION(3) :: gradient
2291 :
2292 : INTEGER :: corner_x, corner_y, corner_z, idir, jdir
2293 : INTEGER, DIMENSION(3) :: base, corner_index, index, relative_index
2294 : REAL(KIND=dp) :: coefficient
2295 : REAL(KIND=dp), DIMENSION(3) :: fraction, gradient_relative, relative
2296 : REAL(KIND=dp), &
2297 : DIMENSION(native_grid_interp_npts, 3) :: derivative_weights, weights
2298 :
2299 50000 : CPASSERT(ASSOCIATED(pw_grid))
2300 50000 : CPASSERT(ASSOCIATED(cell))
2301 200000 : DO idir = 1, 3
2302 200000 : CPASSERT(SIZE(values, idir) == pw_grid%npts(idir))
2303 : END DO
2304 :
2305 650000 : relative = MATMUL(pw_grid%dh_inv, point)
2306 178165 : DO idir = 1, 3
2307 137650 : IF (cell%perd(idir) == 1) THEN
2308 0 : relative(idir) = MODULO(relative(idir), REAL(pw_grid%npts(idir), KIND=dp))
2309 137650 : ELSE IF (relative(idir) <= -REAL(native_grid_interp_offset_max, dp) .OR. &
2310 : relative(idir) >= REAL(pw_grid%npts(idir) - &
2311 : native_grid_interp_offset_min, KIND=dp)) THEN
2312 37940 : gradient = 0.0_dp
2313 9485 : RETURN
2314 : END IF
2315 128165 : base(idir) = FLOOR(relative(idir))
2316 128165 : FRACTION(idir) = relative(idir) - REAL(base(idir), KIND=dp)
2317 : CALL native_grid_lagrange_weights( &
2318 168680 : FRACTION(idir), weights(:, idir), derivative_weights(:, idir))
2319 : END DO
2320 :
2321 40515 : gradient_relative = 0.0_dp
2322 364635 : DO corner_z = native_grid_interp_offset_min, native_grid_interp_offset_max
2323 2957595 : DO corner_y = native_grid_interp_offset_min, native_grid_interp_offset_max
2324 23660760 : DO corner_x = native_grid_interp_offset_min, native_grid_interp_offset_max
2325 82974720 : relative_index = base + [corner_x, corner_y, corner_z]
2326 : corner_index = [corner_x, corner_y, corner_z] - &
2327 82974720 : native_grid_interp_offset_min + 1
2328 80568215 : DO idir = 1, 3
2329 81727880 : IF (cell%perd(idir) == 1) THEN
2330 0 : relative_index(idir) = MODULO(relative_index(idir), pw_grid%npts(idir))
2331 60984200 : ELSE IF (relative_index(idir) < 0 .OR. &
2332 : relative_index(idir) >= pw_grid%npts(idir)) THEN
2333 : EXIT
2334 : END IF
2335 : END DO
2336 20743680 : IF (idir <= 3) CYCLE
2337 78336060 : index = LBOUND(values) + relative_index
2338 80929020 : DO idir = 1, 3
2339 : coefficient = 1.0_dp
2340 235008180 : DO jdir = 1, 3
2341 235008180 : IF (jdir == idir) THEN
2342 : coefficient = coefficient*derivative_weights( &
2343 58752045 : corner_index(jdir), jdir)
2344 : ELSE
2345 : coefficient = coefficient*weights( &
2346 117504090 : corner_index(jdir), jdir)
2347 : END IF
2348 : END DO
2349 : gradient_relative(idir) = gradient_relative(idir) + &
2350 79495725 : coefficient*values(INDEX(1), INDEX(2), INDEX(3))
2351 : END DO
2352 : END DO
2353 : END DO
2354 : END DO
2355 40515 : gradient = MATMUL(TRANSPOSE(pw_grid%dh_inv), gradient_relative)
2356 :
2357 : END FUNCTION interpolate_native_grid_gradient
2358 :
2359 : ! **************************************************************************************************
2360 : !> \brief Apply the transpose of native-grid interpolation for one point.
2361 : !> \param values ...
2362 : !> \param pw_grid ...
2363 : !> \param cell ...
2364 : !> \param point ...
2365 : !> \param value ...
2366 : ! **************************************************************************************************
2367 700000 : SUBROUTINE add_native_grid_interpolation_adjoint(values, pw_grid, cell, point, value)
2368 : REAL(KIND=dp), DIMENSION(:), INTENT(INOUT) :: values
2369 : TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
2370 : TYPE(cell_type), INTENT(IN), POINTER :: cell
2371 : REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: point
2372 : REAL(KIND=dp), INTENT(IN) :: value
2373 :
2374 : INTEGER :: corner_x, corner_y, corner_z, idir, ipt
2375 : INTEGER, DIMENSION(3) :: base, relative_index
2376 : REAL(KIND=dp) :: coefficient
2377 : REAL(KIND=dp), DIMENSION(3) :: fraction, relative
2378 : REAL(KIND=dp), &
2379 : DIMENSION(native_grid_interp_npts, 3) :: weights
2380 :
2381 700000 : CPASSERT(ASSOCIATED(pw_grid))
2382 700000 : CPASSERT(ASSOCIATED(cell))
2383 2800000 : CPASSERT(SIZE(values) == PRODUCT(pw_grid%npts))
2384 :
2385 9100000 : relative = MATMUL(pw_grid%dh_inv, point)
2386 2552260 : DO idir = 1, 3
2387 1961800 : IF (cell%perd(idir) == 1) THEN
2388 0 : relative(idir) = MODULO(relative(idir), REAL(pw_grid%npts(idir), KIND=dp))
2389 1961800 : ELSE IF (relative(idir) <= -REAL(native_grid_interp_offset_max, dp) .OR. &
2390 : relative(idir) >= REAL(pw_grid%npts(idir) - &
2391 : native_grid_interp_offset_min, KIND=dp)) THEN
2392 109540 : RETURN
2393 : END IF
2394 1852260 : base(idir) = FLOOR(relative(idir))
2395 1852260 : FRACTION(idir) = relative(idir) - REAL(base(idir), KIND=dp)
2396 2442720 : CALL native_grid_lagrange_weights(FRACTION(idir), weights(:, idir))
2397 : END DO
2398 :
2399 5314140 : DO corner_z = native_grid_interp_offset_min, native_grid_interp_offset_max
2400 43103580 : DO corner_y = native_grid_interp_offset_min, native_grid_interp_offset_max
2401 344828640 : DO corner_x = native_grid_interp_offset_min, native_grid_interp_offset_max
2402 1209262080 : relative_index = base + [corner_x, corner_y, corner_z]
2403 : coefficient = weights(corner_x - native_grid_interp_offset_min + 1, 1)* &
2404 : weights(corner_y - native_grid_interp_offset_min + 1, 2)* &
2405 302315520 : weights(corner_z - native_grid_interp_offset_min + 1, 3)
2406 1209262080 : DO idir = 1, 3
2407 1209262080 : IF (cell%perd(idir) == 1) THEN
2408 0 : relative_index(idir) = MODULO(relative_index(idir), pw_grid%npts(idir))
2409 906946560 : ELSE IF (relative_index(idir) < 0 .OR. &
2410 : relative_index(idir) >= pw_grid%npts(idir)) THEN
2411 16954880 : coefficient = 0.0_dp
2412 : END IF
2413 : END DO
2414 302315520 : IF (coefficient == 0.0_dp) CYCLE
2415 : ipt = 1 + relative_index(1) + pw_grid%npts(1)*( &
2416 288017160 : relative_index(2) + pw_grid%npts(2)*relative_index(3))
2417 340104960 : values(ipt) = values(ipt) + coefficient*value
2418 : END DO
2419 : END DO
2420 : END DO
2421 :
2422 : END SUBROUTINE add_native_grid_interpolation_adjoint
2423 :
2424 : ! **************************************************************************************************
2425 : !> \brief Build the value and optional derivative weights for the native-grid interpolation.
2426 : !> \param fraction fractional coordinate between two grid points
2427 : !> \param weights interpolation weights
2428 : !> \param derivative_weights optional derivatives with respect to fraction
2429 : ! **************************************************************************************************
2430 4758815 : SUBROUTINE native_grid_lagrange_weights(fraction, weights, derivative_weights)
2431 : REAL(KIND=dp), INTENT(IN) :: fraction
2432 : REAL(KIND=dp), &
2433 : DIMENSION(native_grid_interp_npts), INTENT(OUT) :: weights
2434 : REAL(KIND=dp), &
2435 : DIMENSION(native_grid_interp_npts), &
2436 : INTENT(OUT), OPTIONAL :: derivative_weights
2437 :
2438 : INTEGER :: inode, jnode, knode
2439 : REAL(KIND=dp) :: denominator, derivative, numerator
2440 : REAL(KIND=dp), DIMENSION(native_grid_interp_npts) :: nodes
2441 :
2442 42829335 : DO inode = 1, native_grid_interp_npts
2443 42829335 : nodes(inode) = REAL(native_grid_interp_offset_min + inode - 1, dp)
2444 : END DO
2445 42829335 : DO inode = 1, native_grid_interp_npts
2446 : denominator = 1.0_dp
2447 : numerator = 1.0_dp
2448 342634680 : DO jnode = 1, native_grid_interp_npts
2449 304564160 : IF (jnode == inode) CYCLE
2450 266493640 : denominator = denominator*(nodes(inode) - nodes(jnode))
2451 342634680 : numerator = numerator*(fraction - nodes(jnode))
2452 : END DO
2453 38070520 : weights(inode) = numerator/denominator
2454 42829335 : IF (PRESENT(derivative_weights)) THEN
2455 : derivative = 0.0_dp
2456 9227880 : DO knode = 1, native_grid_interp_npts
2457 8202560 : IF (knode == inode) CYCLE
2458 : numerator = 1.0_dp
2459 64595160 : DO jnode = 1, native_grid_interp_npts
2460 57417920 : IF (jnode == inode .OR. jnode == knode) CYCLE
2461 64595160 : numerator = numerator*(fraction - nodes(jnode))
2462 : END DO
2463 9227880 : derivative = derivative + numerator/denominator
2464 : END DO
2465 1025320 : derivative_weights(inode) = derivative
2466 : END IF
2467 : END DO
2468 :
2469 4758815 : END SUBROUTINE native_grid_lagrange_weights
2470 :
2471 : ! **************************************************************************************************
2472 : !> \brief Evaluate one GAPW hard-minus-soft atom correction at an arbitrary point.
2473 : !> \param grid_atom ...
2474 : !> \param harmonics ...
2475 : !> \param r_h ...
2476 : !> \param r_s ...
2477 : !> \param dr_h ...
2478 : !> \param dr_s ...
2479 : !> \param r_h_d ...
2480 : !> \param r_s_d ...
2481 : !> \param tau_coeff ...
2482 : !> \param nspins ...
2483 : !> \param cutoff ...
2484 : !> \param atom_coord ...
2485 : !> \param point ...
2486 : !> \param cell ...
2487 : !> \param density ...
2488 : !> \param grad ...
2489 : !> \param kin ...
2490 : ! **************************************************************************************************
2491 70000 : SUBROUTINE evaluate_gapw_atom_delta(grid_atom, harmonics, r_h, r_s, dr_h, dr_s, r_h_d, r_s_d, &
2492 : tau_coeff, nspins, cutoff, atom_coord, point, cell, &
2493 : density, grad, kin)
2494 : TYPE(grid_atom_type), POINTER :: grid_atom
2495 : TYPE(harmonics_atom_type), POINTER :: harmonics
2496 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: r_h, r_s, dr_h, dr_s
2497 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
2498 : REAL(KIND=dp), ALLOCATABLE, DIMENSION(:, :, :), &
2499 : INTENT(IN) :: tau_coeff
2500 : INTEGER, INTENT(IN) :: nspins
2501 : REAL(KIND=dp), INTENT(IN) :: cutoff
2502 : REAL(KIND=dp), DIMENSION(3), INTENT(IN) :: atom_coord, point
2503 : TYPE(cell_type), POINTER :: cell
2504 : REAL(KIND=dp), DIMENSION(2), INTENT(OUT) :: density
2505 : REAL(KIND=dp), DIMENSION(3, 2), INTENT(OUT) :: grad
2506 : REAL(KIND=dp), DIMENSION(2), INTENT(OUT) :: kin
2507 :
2508 : INTEGER :: idir, iso, ispin, l, m
2509 : REAL(KIND=dp) :: dradial, radial, value, y(1)
2510 : REAL(KIND=dp), DIMENSION(3) :: displacement, unit_vector
2511 : REAL(KIND=dp), DIMENSION(3, 1) :: direction
2512 :
2513 70000 : density = 0.0_dp
2514 70000 : grad = 0.0_dp
2515 70000 : kin = 0.0_dp
2516 280000 : displacement = pbc(point - atom_coord, cell)
2517 280000 : radial = SQRT(SUM(displacement**2))
2518 70000 : IF (radial > cutoff) RETURN
2519 0 : IF (radial > 1.0E-14_dp) THEN
2520 0 : unit_vector = displacement/radial
2521 : ELSE
2522 0 : unit_vector = [0.0_dp, 0.0_dp, 1.0_dp]
2523 : END IF
2524 0 : direction(:, 1) = unit_vector
2525 :
2526 0 : DO iso = 1, harmonics%max_iso_not0
2527 0 : l = indso(1, iso)
2528 0 : m = indso(2, iso)
2529 0 : CALL y_lm(direction, y, l, m)
2530 0 : DO ispin = 1, nspins
2531 : value = interpolate_radial_difference( &
2532 0 : grid_atom%rad, r_h(ispin)%r_coef(:, iso), r_s(ispin)%r_coef(:, iso), radial)
2533 0 : density(ispin) = density(ispin) + value*y(1)
2534 : dradial = interpolate_radial_difference( &
2535 0 : grid_atom%rad, dr_h(ispin)%r_coef(:, iso), dr_s(ispin)%r_coef(:, iso), radial)
2536 0 : DO idir = 1, 3
2537 : value = interpolate_radial_difference( &
2538 : grid_atom%rad, r_h_d(idir, ispin)%r_coef(:, iso), &
2539 0 : r_s_d(idir, ispin)%r_coef(:, iso), radial)
2540 : grad(idir, ispin) = grad(idir, ispin) + &
2541 0 : (dradial*unit_vector(idir) + value)*y(1)
2542 : END DO
2543 0 : value = interpolate_radial_value(grid_atom%rad, tau_coeff(:, iso, ispin), radial)
2544 0 : kin(ispin) = kin(ispin) + value*y(1)
2545 : END DO
2546 : END DO
2547 :
2548 : END SUBROUTINE evaluate_gapw_atom_delta
2549 :
2550 : ! **************************************************************************************************
2551 : !> \brief Cubically interpolate the difference of two nonuniform radial tables.
2552 : !> \param radial_grid ...
2553 : !> \param hard ...
2554 : !> \param soft ...
2555 : !> \param radius ...
2556 : !> \return ...
2557 : ! **************************************************************************************************
2558 0 : FUNCTION interpolate_radial_difference(radial_grid, hard, soft, radius) RESULT(value)
2559 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: radial_grid, hard, soft
2560 : REAL(KIND=dp), INTENT(IN) :: radius
2561 : REAL(KIND=dp) :: value
2562 :
2563 0 : value = interpolate_radial_value(radial_grid, hard - soft, radius)
2564 :
2565 0 : END FUNCTION interpolate_radial_difference
2566 :
2567 : ! **************************************************************************************************
2568 : !> \brief Cubically interpolate a nonuniform radial table.
2569 : !> \param radial_grid ...
2570 : !> \param samples ...
2571 : !> \param radius ...
2572 : !> \return ...
2573 : ! **************************************************************************************************
2574 0 : FUNCTION interpolate_radial_value(radial_grid, samples, radius) RESULT(value)
2575 : REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: radial_grid, samples
2576 : REAL(KIND=dp), INTENT(IN) :: radius
2577 : REAL(KIND=dp) :: value
2578 :
2579 : INTEGER :: i, j, k, left, n, start
2580 : REAL(KIND=dp) :: weight
2581 :
2582 0 : n = SIZE(radial_grid)
2583 0 : CPASSERT(SIZE(samples) == n)
2584 0 : IF (radius > radial_grid(n)) THEN
2585 0 : value = 0.0_dp
2586 : RETURN
2587 : END IF
2588 0 : IF (n < 4) THEN
2589 0 : CPASSERT(n >= 2)
2590 0 : IF (radius <= radial_grid(1)) THEN
2591 : left = 1
2592 : ELSE
2593 0 : left = n - 1
2594 0 : DO i = 1, n - 1
2595 0 : IF (radius < radial_grid(i + 1)) THEN
2596 : left = i
2597 : EXIT
2598 : END IF
2599 : END DO
2600 : END IF
2601 : weight = (radius - radial_grid(left))/ &
2602 0 : (radial_grid(left + 1) - radial_grid(left))
2603 0 : value = (1.0_dp - weight)*samples(left) + weight*samples(left + 1)
2604 0 : RETURN
2605 : END IF
2606 :
2607 0 : IF (radius <= radial_grid(2)) THEN
2608 : start = 1
2609 0 : ELSE IF (radius >= radial_grid(n - 1)) THEN
2610 0 : start = n - 3
2611 : ELSE
2612 0 : left = 2
2613 0 : DO i = 2, n - 2
2614 0 : IF (radius < radial_grid(i + 1)) THEN
2615 : left = i
2616 : EXIT
2617 : END IF
2618 : END DO
2619 0 : start = left - 1
2620 : END IF
2621 :
2622 0 : value = 0.0_dp
2623 0 : DO j = start, start + 3
2624 : weight = 1.0_dp
2625 0 : DO k = start, start + 3
2626 0 : IF (k == j) CYCLE
2627 0 : weight = weight*(radius - radial_grid(k))/(radial_grid(j) - radial_grid(k))
2628 : END DO
2629 0 : value = value + weight*samples(j)
2630 : END DO
2631 :
2632 : END FUNCTION interpolate_radial_value
2633 :
2634 : ! **************************************************************************************************
2635 : !> \brief ...
2636 : !> \param qs_env ...
2637 : !> \param exc1 the on-body ex energy contribution
2638 : !> \param gradient_atom_set ...
2639 : ! **************************************************************************************************
2640 10 : SUBROUTINE calculate_vxc_atom_epr(qs_env, exc1, gradient_atom_set)
2641 :
2642 : TYPE(qs_environment_type), POINTER :: qs_env
2643 : REAL(dp), INTENT(INOUT) :: exc1
2644 : TYPE(nablavks_atom_type), DIMENSION(:), POINTER :: gradient_atom_set
2645 :
2646 : CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_vxc_atom_epr'
2647 :
2648 : INTEGER :: bo(2), handle, ia, iat, iatom, idir, &
2649 : ikind, ir, ispin, myfun, na, natom, &
2650 : nr, nspins, num_pe
2651 : INTEGER, DIMENSION(2, 3) :: bounds
2652 10 : INTEGER, DIMENSION(:), POINTER :: atom_list
2653 : LOGICAL :: accint, donlcc, gradient_f, lsd, nlcc, &
2654 : paw_atom, tau_f
2655 : REAL(dp) :: agr, alpha, density_cut, exc_h, exc_s, &
2656 : gradient_cut, tau_cut
2657 : REAL(dp), DIMENSION(1, 1, 1) :: tau_d
2658 : REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d
2659 20 : REAL(dp), DIMENSION(:, :), POINTER :: rho_nlcc, weight_h, weight_s
2660 20 : REAL(dp), DIMENSION(:, :, :), POINTER :: rho_h, rho_s, tau_h, tau_s, vtau_h, &
2661 10 : vtau_s, vxc_h, vxc_s
2662 20 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s, vxg_h, vxg_s
2663 10 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
2664 : TYPE(dft_control_type), POINTER :: dft_control
2665 : TYPE(grid_atom_type), POINTER :: grid_atom
2666 : TYPE(gto_basis_set_type), POINTER :: basis_1c
2667 : TYPE(harmonics_atom_type), POINTER :: harmonics
2668 : TYPE(mp_para_env_type), POINTER :: para_env
2669 10 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: my_kind_set
2670 10 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s, int_hh, int_ss, r_h, r_s
2671 10 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
2672 10 : TYPE(rho_atom_type), DIMENSION(:), POINTER :: my_rho_atom_set
2673 : TYPE(rho_atom_type), POINTER :: rho_atom
2674 : TYPE(section_vals_type), POINTER :: input, my_xc_section, xc_fun_section
2675 10 : TYPE(tau_basis_cache_type) :: tau_basis_cache
2676 : TYPE(xc_derivative_set_type) :: deriv_set
2677 : TYPE(xc_rho_cflags_type) :: needs
2678 : TYPE(xc_rho_set_type) :: rho_set_h, rho_set_s
2679 :
2680 : ! -------------------------------------------------------------------------
2681 :
2682 10 : CALL timeset(routineN, handle)
2683 :
2684 10 : NULLIFY (atom_list)
2685 10 : NULLIFY (my_kind_set)
2686 10 : NULLIFY (atomic_kind_set)
2687 10 : NULLIFY (grid_atom)
2688 10 : NULLIFY (harmonics)
2689 10 : NULLIFY (input)
2690 10 : NULLIFY (para_env)
2691 10 : NULLIFY (rho_atom)
2692 10 : NULLIFY (my_rho_atom_set)
2693 10 : NULLIFY (rho_nlcc)
2694 :
2695 : CALL get_qs_env(qs_env=qs_env, &
2696 : dft_control=dft_control, &
2697 : para_env=para_env, &
2698 : atomic_kind_set=atomic_kind_set, &
2699 : qs_kind_set=my_kind_set, &
2700 : input=input, &
2701 10 : rho_atom_set=my_rho_atom_set)
2702 :
2703 10 : nlcc = has_nlcc(my_kind_set)
2704 10 : accint = dft_control%qs_control%gapw_control%accurate_xcint
2705 :
2706 : my_xc_section => section_vals_get_subs_vals(input, &
2707 10 : "PROPERTIES%LINRES%EPR%PRINT%G_TENSOR%XC")
2708 10 : xc_fun_section => section_vals_get_subs_vals(my_xc_section, "XC_FUNCTIONAL")
2709 : CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", &
2710 10 : i_val=myfun)
2711 :
2712 10 : IF (myfun == xc_none) THEN
2713 0 : exc1 = 0.0_dp
2714 0 : my_rho_atom_set(:)%exc_h = 0.0_dp
2715 0 : my_rho_atom_set(:)%exc_s = 0.0_dp
2716 : ELSE
2717 : CALL section_vals_val_get(my_xc_section, "DENSITY_CUTOFF", &
2718 10 : r_val=density_cut)
2719 : CALL section_vals_val_get(my_xc_section, "GRADIENT_CUTOFF", &
2720 10 : r_val=gradient_cut)
2721 : CALL section_vals_val_get(my_xc_section, "TAU_CUTOFF", &
2722 10 : r_val=tau_cut)
2723 :
2724 10 : lsd = dft_control%lsd
2725 10 : nspins = dft_control%nspins
2726 : needs = xc_functionals_get_needs(xc_fun_section, &
2727 : lsd=lsd, &
2728 10 : calc_potential=.TRUE.)
2729 :
2730 : ! whatever the xc, if epr_xc, drho_spin is needed
2731 10 : needs%drho_spin = .TRUE.
2732 :
2733 10 : gradient_f = (needs%drho .OR. needs%drho_spin)
2734 10 : tau_f = (needs%tau .OR. needs%tau_spin)
2735 :
2736 : ! Initialize energy contribution from the one center XC terms to zero
2737 10 : exc1 = 0.0_dp
2738 :
2739 : ! Nullify some pointers for work-arrays
2740 10 : NULLIFY (rho_h, drho_h, rho_s, drho_s, weight_h, weight_s)
2741 10 : NULLIFY (vxc_h, vxc_s, vxg_h, vxg_s)
2742 10 : NULLIFY (tau_h, tau_s)
2743 10 : NULLIFY (vtau_h, vtau_s)
2744 :
2745 : ! Here starts the loop over all the atoms
2746 :
2747 30 : DO ikind = 1, SIZE(atomic_kind_set)
2748 20 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
2749 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
2750 20 : harmonics=harmonics, grid_atom=grid_atom)
2751 20 : CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
2752 :
2753 20 : IF (.NOT. paw_atom) CYCLE
2754 :
2755 20 : nr = grid_atom%nr
2756 20 : na = grid_atom%ng_sphere
2757 :
2758 : ! Prepare the structures needed to calculate and store the xc derivatives
2759 :
2760 : ! Array dimension: here anly one dimensional arrays are used,
2761 : ! i.e. only the first column of deriv_data is read.
2762 : ! The other to dimensions are set to size equal 1
2763 200 : bounds(1:2, 1:3) = 1
2764 20 : bounds(2, 1) = na
2765 20 : bounds(2, 2) = nr
2766 :
2767 : ! set integration weights
2768 20 : IF (accint) THEN
2769 0 : weight_h => grid_atom%weight
2770 0 : alpha = dft_control%qs_control%gapw_control%aw(ikind)
2771 0 : IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
2772 0 : IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
2773 : END IF
2774 0 : IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
2775 0 : ALLOCATE (grid_atom%gapw_weight_s(na, nr))
2776 0 : DO ir = 1, nr
2777 0 : agr = 1.0_dp - EXP(-alpha*grid_atom%rad2(ir))
2778 0 : grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
2779 : END DO
2780 0 : grid_atom%gapw_weight_alpha = alpha
2781 : END IF
2782 0 : weight_s => grid_atom%gapw_weight_s
2783 : ELSE
2784 20 : weight_h => grid_atom%weight
2785 20 : weight_s => grid_atom%weight
2786 : END IF
2787 :
2788 : ! create a place where to put the derivatives
2789 20 : CALL xc_dset_create(deriv_set, local_bounds=bounds)
2790 : ! create the place where to store the argument for the functionals
2791 : CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
2792 20 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
2793 : CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
2794 20 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
2795 :
2796 : ! allocate the required 3d arrays where to store rho and drho
2797 20 : CALL xc_rho_set_atom_update(rho_set_h, needs, nspins, bounds)
2798 20 : CALL xc_rho_set_atom_update(rho_set_s, needs, nspins, bounds)
2799 :
2800 20 : CALL reallocate(rho_h, 1, na, 1, nr, 1, nspins)
2801 20 : CALL reallocate(rho_s, 1, na, 1, nr, 1, nspins)
2802 20 : CALL reallocate(vxc_h, 1, na, 1, nr, 1, nspins)
2803 20 : CALL reallocate(vxc_s, 1, na, 1, nr, 1, nspins)
2804 : !
2805 : IF (gradient_f) THEN
2806 20 : CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
2807 20 : CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
2808 20 : CALL reallocate(vxg_h, 1, 3, 1, na, 1, nr, 1, nspins)
2809 20 : CALL reallocate(vxg_s, 1, 3, 1, na, 1, nr, 1, nspins)
2810 : END IF
2811 :
2812 20 : IF (tau_f) THEN
2813 0 : CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
2814 0 : CALL reallocate(tau_h, 1, na, 1, nr, 1, nspins)
2815 0 : CALL reallocate(tau_s, 1, na, 1, nr, 1, nspins)
2816 0 : CALL reallocate(vtau_h, 1, na, 1, nr, 1, nspins)
2817 0 : CALL reallocate(vtau_s, 1, na, 1, nr, 1, nspins)
2818 : END IF
2819 :
2820 : ! NLCC: prepare rho and drho of the core charge for this KIND
2821 20 : donlcc = .FALSE.
2822 20 : IF (nlcc) THEN
2823 0 : NULLIFY (rho_nlcc)
2824 0 : rho_nlcc => my_kind_set(ikind)%nlcc_pot
2825 0 : IF (ASSOCIATED(rho_nlcc)) donlcc = .TRUE.
2826 : END IF
2827 :
2828 : ! Distribute the atoms of this kind
2829 :
2830 20 : num_pe = para_env%num_pe
2831 20 : bo = get_limit(natom, para_env%num_pe, para_env%mepos)
2832 :
2833 35 : DO iat = bo(1), bo(2)
2834 15 : iatom = atom_list(iat)
2835 :
2836 15 : my_rho_atom_set(iatom)%exc_h = 0.0_dp
2837 15 : my_rho_atom_set(iatom)%exc_s = 0.0_dp
2838 :
2839 15 : rho_atom => my_rho_atom_set(iatom)
2840 76545 : rho_h = 0.0_dp
2841 76545 : rho_s = 0.0_dp
2842 : IF (gradient_f) THEN
2843 15 : NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
2844 : CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, &
2845 : rho_rad_s=r_s, drho_rad_h=dr_h, &
2846 : drho_rad_s=dr_s, rho_rad_h_d=r_h_d, &
2847 15 : rho_rad_s_d=r_s_d)
2848 376545 : drho_h = 0.0_dp
2849 376545 : drho_s = 0.0_dp
2850 : ELSE
2851 : NULLIFY (r_h, r_s)
2852 : CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s)
2853 : rho_d = 0.0_dp
2854 : END IF
2855 15 : IF (tau_f) THEN
2856 : !compute tau on the grid all at once
2857 0 : CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
2858 : ELSE
2859 15 : tau_d = 0.0_dp
2860 : END IF
2861 :
2862 765 : DO ir = 1, nr
2863 : CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
2864 : ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
2865 750 : r_h_d, r_s_d, drho_h, drho_s)
2866 765 : IF (donlcc) THEN
2867 : CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
2868 0 : ir, rho_nlcc(:, 1), rho_h, rho_s, rho_nlcc(:, 2), drho_h, drho_s)
2869 : END IF
2870 : END DO
2871 765 : DO ir = 1, nr
2872 765 : IF (tau_f) THEN
2873 0 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
2874 0 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
2875 : ELSE IF (gradient_f) THEN
2876 750 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_d, na, ir)
2877 750 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_d, na, ir)
2878 : ELSE
2879 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, rho_d, tau_d, na, ir)
2880 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, rho_d, tau_d, na, ir)
2881 : END IF
2882 : END DO
2883 :
2884 : !-------------------!
2885 : ! hard atom density !
2886 : !-------------------!
2887 15 : CALL xc_dset_zero_all(deriv_set)
2888 : CALL vxc_of_r_epr(xc_fun_section, rho_set_h, deriv_set, needs, weight_h, &
2889 15 : lsd, na, nr, exc_h, vxc_h, vxg_h, vtau_h)
2890 15 : rho_atom%exc_h = rho_atom%exc_h + exc_h
2891 :
2892 : !-------------------!
2893 : ! soft atom density !
2894 : !-------------------!
2895 15 : CALL xc_dset_zero_all(deriv_set)
2896 : CALL vxc_of_r_epr(xc_fun_section, rho_set_s, deriv_set, needs, weight_s, &
2897 15 : lsd, na, nr, exc_s, vxc_s, vxg_s, vtau_s)
2898 15 : rho_atom%exc_s = rho_atom%exc_s + exc_s
2899 :
2900 45 : DO ispin = 1, nspins
2901 135 : DO idir = 1, 3
2902 4620 : DO ir = 1, nr
2903 229590 : DO ia = 1, na
2904 : gradient_atom_set(iatom)%nablavks_vec_rad_h(idir, ispin)%r_coef(ir, ia) = &
2905 : gradient_atom_set(iatom)%nablavks_vec_rad_h(idir, ispin)%r_coef(ir, ia) &
2906 225000 : + vxg_h(idir, ia, ir, ispin)
2907 : gradient_atom_set(iatom)%nablavks_vec_rad_s(idir, ispin)%r_coef(ir, ia) = &
2908 : gradient_atom_set(iatom)%nablavks_vec_rad_s(idir, ispin)%r_coef(ir, ia) &
2909 229500 : + vxg_s(idir, ia, ir, ispin)
2910 : END DO ! ia
2911 : END DO ! ir
2912 : END DO ! idir
2913 : END DO ! ispin
2914 :
2915 : ! Add contributions to the exc energy
2916 :
2917 15 : exc1 = exc1 + rho_atom%exc_h - rho_atom%exc_s
2918 :
2919 : ! Integration to get the matrix elements relative to the vxc_atom
2920 : ! here the products with the primitives is done: gaVxcgb
2921 : ! internal transformation to get the integral in cartesian Gaussians
2922 :
2923 15 : NULLIFY (int_hh, int_ss)
2924 15 : CALL get_rho_atom(rho_atom=rho_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
2925 : IF (gradient_f) THEN
2926 : CALL gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
2927 15 : grid_atom, basis_1c, harmonics, nspins)
2928 : ELSE
2929 : CALL gaVxcgb_noGC(vxc_h, vxc_s, int_hh, int_ss, &
2930 : grid_atom, basis_1c, harmonics, nspins)
2931 : END IF
2932 15 : IF (tau_f) THEN
2933 : CALL dgaVtaudgb(vtau_h, vtau_s, int_hh, int_ss, &
2934 0 : tau_basis_cache, nspins)
2935 : END IF
2936 35 : NULLIFY (r_h, r_s, dr_h, dr_s)
2937 : END DO ! iat
2938 :
2939 20 : IF (tau_f) CALL release_tau_basis_cache(tau_basis_cache)
2940 :
2941 : ! Release the xc structure used to store the xc derivatives
2942 20 : CALL xc_dset_release(deriv_set)
2943 20 : CALL xc_rho_set_release(rho_set_h)
2944 70 : CALL xc_rho_set_release(rho_set_s)
2945 : END DO ! ikind
2946 :
2947 10 : CALL para_env%sum(exc1)
2948 :
2949 10 : IF (ASSOCIATED(rho_h)) DEALLOCATE (rho_h)
2950 10 : IF (ASSOCIATED(rho_s)) DEALLOCATE (rho_s)
2951 10 : IF (ASSOCIATED(vxc_h)) DEALLOCATE (vxc_h)
2952 10 : IF (ASSOCIATED(vxc_s)) DEALLOCATE (vxc_s)
2953 :
2954 : IF (gradient_f) THEN
2955 10 : IF (ASSOCIATED(drho_h)) DEALLOCATE (drho_h)
2956 10 : IF (ASSOCIATED(drho_s)) DEALLOCATE (drho_s)
2957 10 : IF (ASSOCIATED(vxg_h)) DEALLOCATE (vxg_h)
2958 10 : IF (ASSOCIATED(vxg_s)) DEALLOCATE (vxg_s)
2959 : END IF
2960 :
2961 10 : IF (tau_f) THEN
2962 0 : IF (ASSOCIATED(tau_h)) DEALLOCATE (tau_h)
2963 0 : IF (ASSOCIATED(tau_s)) DEALLOCATE (tau_s)
2964 0 : IF (ASSOCIATED(vtau_h)) DEALLOCATE (vtau_h)
2965 0 : IF (ASSOCIATED(vtau_s)) DEALLOCATE (vtau_s)
2966 : END IF
2967 :
2968 : END IF !xc_none
2969 :
2970 10 : CALL timestop(handle)
2971 :
2972 380 : END SUBROUTINE calculate_vxc_atom_epr
2973 :
2974 : ! **************************************************************************************************
2975 : !> \brief ...
2976 : !> \param rho_atom_set ...
2977 : !> \param rho1_atom_set ...
2978 : !> \param qs_env ...
2979 : !> \param xc_section ...
2980 : !> \param para_env ...
2981 : !> \param do_tddfpt2 New implementation of TDDFT.
2982 : !> \param do_triplet ...
2983 : !> \param do_sf ...
2984 : !> \param kind_set_external ...
2985 : ! **************************************************************************************************
2986 6130 : SUBROUTINE calculate_xc_2nd_deriv_atom(rho_atom_set, rho1_atom_set, qs_env, xc_section, para_env, &
2987 : do_tddfpt2, do_triplet, do_sf, kind_set_external)
2988 :
2989 : TYPE(rho_atom_type), DIMENSION(:), POINTER :: rho_atom_set, rho1_atom_set
2990 : TYPE(qs_environment_type), POINTER :: qs_env
2991 : TYPE(section_vals_type), POINTER :: xc_section
2992 : TYPE(mp_para_env_type), INTENT(IN) :: para_env
2993 : LOGICAL, INTENT(IN), OPTIONAL :: do_tddfpt2, do_triplet, do_sf
2994 : TYPE(qs_kind_type), DIMENSION(:), OPTIONAL, &
2995 : POINTER :: kind_set_external
2996 :
2997 : CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_xc_2nd_deriv_atom'
2998 :
2999 : INTEGER :: atom, handle, iatom, ikind, ir, na, &
3000 : natom, nr, nspins
3001 : INTEGER, DIMENSION(2) :: local_loop_limit
3002 : INTEGER, DIMENSION(2, 3) :: bounds
3003 6130 : INTEGER, DIMENSION(:), POINTER :: atom_list
3004 : LOGICAL :: accint, gradient_functional, lsd, &
3005 : my_do_sf, paw_atom, scale_rho, tau_f
3006 : REAL(KIND=dp) :: agr, alpha, density_cut, gradient_cut, &
3007 : rtot, tau_cut
3008 : REAL(KIND=dp), CONTIGUOUS, DIMENSION(:, :, :), &
3009 6130 : POINTER :: vtau_h, vtau_s, vxc_h, vxc_s
3010 : REAL(KIND=dp), DIMENSION(1, 1, 1) :: rtau
3011 : REAL(KIND=dp), DIMENSION(1, 1, 1, 1) :: rrho
3012 6130 : REAL(KIND=dp), DIMENSION(:, :), POINTER :: weight_h, weight_s
3013 18390 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: rho1_h, rho1_s, rho_h, rho_s, tau1_h, &
3014 6130 : tau1_s, tau_h, tau_s
3015 12260 : REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: drho1_h, drho1_s, drho_h, drho_s, vxg_h, &
3016 6130 : vxg_s
3017 6130 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
3018 : TYPE(dft_control_type), POINTER :: dft_control
3019 : TYPE(grid_atom_type), POINTER :: grid_atom
3020 : TYPE(gto_basis_set_type), POINTER :: basis_1c
3021 : TYPE(harmonics_atom_type), POINTER :: harmonics
3022 6130 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: my_kind_set, qs_kind_set
3023 6130 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr1_h, dr1_s, dr_h, dr_s, int_hh, &
3024 6130 : int_ss, r1_h, r1_s, r_h, r_s
3025 6130 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r1_h_d, r1_s_d, r_h_d, r_s_d
3026 : TYPE(rho_atom_type), POINTER :: rho1_atom, rho_atom
3027 : TYPE(section_vals_type), POINTER :: input, xc_fun_section
3028 6130 : TYPE(tau_basis_cache_type) :: tau_basis_cache
3029 : TYPE(xc_derivative_set_type) :: deriv_set
3030 : TYPE(xc_rho_cflags_type) :: needs
3031 : TYPE(xc_rho_set_type) :: rho1_set_h, rho1_set_s, rho_set_h, &
3032 : rho_set_s
3033 :
3034 : ! -------------------------------------------------------------------------
3035 :
3036 6130 : CALL timeset(routineN, handle)
3037 :
3038 6130 : NULLIFY (qs_kind_set)
3039 6130 : NULLIFY (rho_h, rho_s, drho_h, drho_s, weight_h, weight_s)
3040 6130 : NULLIFY (rho1_h, rho1_s, drho1_h, drho1_s)
3041 6130 : NULLIFY (vxc_h, vxc_s, vxg_h, vxg_s)
3042 6130 : NULLIFY (tau_h, tau_s, tau1_h, tau1_s, vtau_h, vtau_s)
3043 :
3044 : CALL get_qs_env(qs_env=qs_env, &
3045 : input=input, &
3046 : dft_control=dft_control, &
3047 : qs_kind_set=qs_kind_set, &
3048 6130 : atomic_kind_set=atomic_kind_set)
3049 :
3050 6130 : IF (PRESENT(kind_set_external)) THEN
3051 726 : my_kind_set => kind_set_external
3052 : ELSE
3053 5404 : my_kind_set => qs_kind_set
3054 : END IF
3055 :
3056 6130 : accint = dft_control%qs_control%gapw_control%accurate_xcint
3057 :
3058 6130 : CALL section_vals_val_get(input, "DFT%LSD", l_val=lsd)
3059 : CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", &
3060 6130 : r_val=density_cut)
3061 : CALL section_vals_val_get(xc_section, "GRADIENT_CUTOFF", &
3062 6130 : r_val=gradient_cut)
3063 : CALL section_vals_val_get(xc_section, "TAU_CUTOFF", &
3064 6130 : r_val=tau_cut)
3065 :
3066 6130 : my_do_sf = .FALSE.
3067 6130 : IF (PRESENT(do_sf)) my_do_sf = do_sf
3068 :
3069 : xc_fun_section => section_vals_get_subs_vals(xc_section, &
3070 6130 : "XC_FUNCTIONAL")
3071 6130 : IF (lsd) THEN
3072 190 : nspins = 2
3073 : ELSE
3074 5940 : nspins = 1
3075 : END IF
3076 :
3077 6130 : scale_rho = .FALSE.
3078 6130 : IF (PRESENT(do_tddfpt2) .AND. PRESENT(do_triplet)) THEN
3079 2864 : IF (nspins == 1 .AND. do_triplet) THEN
3080 310 : lsd = .TRUE.
3081 310 : scale_rho = .TRUE.
3082 : END IF
3083 3266 : ELSE IF (PRESENT(do_triplet)) THEN
3084 2858 : IF (nspins == 1 .AND. do_triplet) lsd = .TRUE.
3085 : END IF
3086 :
3087 : needs = xc_functionals_get_needs(xc_fun_section, lsd=lsd, &
3088 6130 : calc_potential=.TRUE.)
3089 6130 : gradient_functional = needs%drho .OR. needs%drho_spin
3090 6130 : tau_f = (needs%tau .OR. needs%tau_spin)
3091 6130 : IF (.NOT. tau_f) rtau = 0.0_dp
3092 :
3093 : ! Here starts the loop over all the atoms
3094 19524 : DO ikind = 1, SIZE(atomic_kind_set)
3095 :
3096 13394 : NULLIFY (atom_list, harmonics, grid_atom)
3097 13394 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
3098 : CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
3099 13394 : harmonics=harmonics, grid_atom=grid_atom)
3100 13394 : CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
3101 13394 : IF (.NOT. paw_atom) CYCLE
3102 :
3103 12576 : nr = grid_atom%nr
3104 12576 : na = grid_atom%ng_sphere
3105 :
3106 : ! set integration weights
3107 12576 : IF (accint) THEN
3108 4772 : weight_h => grid_atom%weight
3109 4772 : alpha = dft_control%qs_control%gapw_control%aw(ikind)
3110 4772 : IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
3111 4768 : IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
3112 : END IF
3113 4772 : IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
3114 16 : ALLOCATE (grid_atom%gapw_weight_s(na, nr))
3115 204 : DO ir = 1, nr
3116 200 : agr = 1.0_dp - EXP(-alpha*grid_atom%rad2(ir))
3117 10204 : grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
3118 : END DO
3119 4 : grid_atom%gapw_weight_alpha = alpha
3120 : END IF
3121 4772 : weight_s => grid_atom%gapw_weight_s
3122 : ELSE
3123 7804 : weight_h => grid_atom%weight
3124 7804 : weight_s => grid_atom%weight
3125 : END IF
3126 :
3127 : ! Array dimension: here anly one dimensional arrays are used,
3128 : ! i.e. only the first column of deriv_data is read.
3129 : ! The other to dimensions are set to size equal 1.
3130 125760 : bounds(1:2, 1:3) = 1
3131 12576 : bounds(2, 1) = na
3132 12576 : bounds(2, 2) = nr
3133 :
3134 12576 : CALL xc_dset_create(deriv_set, local_bounds=bounds)
3135 : CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
3136 12576 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3137 : CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
3138 12576 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3139 : CALL xc_rho_set_create(rho1_set_h, bounds, rho_cutoff=density_cut, &
3140 12576 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3141 : CALL xc_rho_set_create(rho1_set_s, bounds, rho_cutoff=density_cut, &
3142 12576 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3143 :
3144 : ! allocate the required 3d arrays where to store rho and drho
3145 12576 : IF (nspins == 1 .AND. .NOT. lsd) THEN
3146 11714 : CALL xc_rho_set_atom_update(rho_set_h, needs, 1, bounds)
3147 11714 : CALL xc_rho_set_atom_update(rho1_set_h, needs, 1, bounds)
3148 11714 : CALL xc_rho_set_atom_update(rho_set_s, needs, 1, bounds)
3149 11714 : CALL xc_rho_set_atom_update(rho1_set_s, needs, 1, bounds)
3150 : ELSE
3151 862 : CALL xc_rho_set_atom_update(rho_set_h, needs, 2, bounds)
3152 862 : CALL xc_rho_set_atom_update(rho1_set_h, needs, 2, bounds)
3153 862 : CALL xc_rho_set_atom_update(rho_set_s, needs, 2, bounds)
3154 862 : CALL xc_rho_set_atom_update(rho1_set_s, needs, 2, bounds)
3155 : END IF
3156 :
3157 : ALLOCATE (rho_h(1:na, 1:nr, 1:nspins), rho1_h(1:na, 1:nr, 1:nspins), &
3158 176064 : rho_s(1:na, 1:nr, 1:nspins), rho1_s(1:na, 1:nr, 1:nspins))
3159 :
3160 88032 : ALLOCATE (vxc_h(1:na, 1:nr, 1:nspins), vxc_s(1:na, 1:nr, 1:nspins))
3161 12576 : vxc_h = 0.0_dp
3162 12576 : vxc_s = 0.0_dp
3163 :
3164 12576 : IF (tau_f) THEN
3165 0 : CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
3166 : ALLOCATE (tau_h(1:na, 1:nr, 1:nspins), tau1_h(1:na, 1:nr, 1:nspins), &
3167 0 : tau_s(1:na, 1:nr, 1:nspins), tau1_s(1:na, 1:nr, 1:nspins))
3168 0 : ALLOCATE (vtau_h(1:na, 1:nr, 1:nspins), vtau_s(1:na, 1:nr, 1:nspins))
3169 : END IF
3170 :
3171 12576 : IF (gradient_functional) THEN
3172 : ALLOCATE (drho_h(1:4, 1:na, 1:nr, 1:nspins), drho1_h(1:4, 1:na, 1:nr, 1:nspins), &
3173 127148 : drho_s(1:4, 1:na, 1:nr, 1:nspins), drho1_s(1:4, 1:na, 1:nr, 1:nspins))
3174 72656 : ALLOCATE (vxg_h(1:3, 1:na, 1:nr, 1:nspins), vxg_s(1:3, 1:na, 1:nr, 1:nspins))
3175 : ELSE
3176 : ALLOCATE (drho_h(1, 1, 1, 1), drho1_h(1, 1, 1, 1), &
3177 3494 : drho_s(1, 1, 1, 1), drho1_s(1, 1, 1, 1))
3178 3494 : ALLOCATE (vxg_h(1, 1, 1, 1), vxg_s(1, 1, 1, 1))
3179 3494 : rrho = 0.0_dp
3180 : END IF
3181 94325034 : vxg_h = 0.0_dp
3182 94325034 : vxg_s = 0.0_dp
3183 :
3184 : ! parallelization
3185 12576 : local_loop_limit = get_limit(natom, para_env%num_pe, para_env%mepos)
3186 :
3187 21505 : DO iatom = local_loop_limit(1), local_loop_limit(2) !1,natom
3188 8929 : atom = atom_list(iatom)
3189 :
3190 8929 : rho_atom_set(atom)%exc_h = 0.0_dp
3191 8929 : rho_atom_set(atom)%exc_s = 0.0_dp
3192 8929 : rho1_atom_set(atom)%exc_h = 0.0_dp
3193 8929 : rho1_atom_set(atom)%exc_s = 0.0_dp
3194 :
3195 8929 : rho_atom => rho_atom_set(atom)
3196 8929 : rho1_atom => rho1_atom_set(atom)
3197 8929 : NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
3198 8929 : NULLIFY (r1_h, r1_s, dr1_h, dr1_s, r1_h_d, r1_s_d)
3199 23424558 : rho_h = 0.0_dp
3200 23424558 : rho_s = 0.0_dp
3201 23424558 : rho1_h = 0.0_dp
3202 23424558 : rho1_s = 0.0_dp
3203 8929 : IF (gradient_functional) THEN
3204 : CALL get_rho_atom(rho_atom=rho_atom, &
3205 : rho_rad_h=r_h, rho_rad_s=r_s, &
3206 : drho_rad_h=dr_h, drho_rad_s=dr_s, &
3207 6480 : rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
3208 : CALL get_rho_atom(rho_atom=rho1_atom, &
3209 : rho_rad_h=r1_h, rho_rad_s=r1_s, &
3210 : drho_rad_h=dr1_h, drho_rad_s=dr1_s, &
3211 6480 : rho_rad_h_d=r1_h_d, rho_rad_s_d=r1_s_d)
3212 168691920 : drho_h = 0.0_dp; drho_s = 0.0_dp
3213 168691920 : drho1_h = 0.0_dp; drho1_s = 0.0_dp
3214 : ELSE
3215 : CALL get_rho_atom(rho_atom=rho_atom, &
3216 2449 : rho_rad_h=r_h, rho_rad_s=r_s)
3217 : CALL get_rho_atom(rho_atom=rho1_atom, &
3218 2449 : rho_rad_h=r1_h, rho_rad_s=r1_s)
3219 : END IF
3220 :
3221 8929 : rtot = 0.0_dp
3222 :
3223 455379 : DO ir = 1, nr
3224 : CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_functional, &
3225 : ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, r_h_d, r_s_d, &
3226 446450 : drho_h, drho_s)
3227 : CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_functional, &
3228 : ir, r1_h, r1_s, rho1_h, rho1_s, dr1_h, dr1_s, r1_h_d, r1_s_d, &
3229 455379 : drho1_h, drho1_s)
3230 : END DO
3231 8929 : IF (tau_f) THEN
3232 0 : CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
3233 0 : CALL calc_tau_atom(tau1_h, tau1_s, rho1_atom, tau_basis_cache, nspins)
3234 : END IF
3235 8929 : IF (scale_rho) THEN
3236 926376 : rho_h = 2.0_dp*rho_h
3237 926376 : rho_s = 2.0_dp*rho_s
3238 363 : IF (gradient_functional) THEN
3239 3426696 : drho_h = 2.0_dp*drho_h
3240 3426696 : drho_s = 2.0_dp*drho_s
3241 : END IF
3242 363 : IF (tau_f) THEN
3243 0 : tau_h = 2.0_dp*tau_h
3244 0 : tau_s = 2.0_dp*tau_s
3245 : END IF
3246 : END IF
3247 :
3248 455379 : DO ir = 1, nr
3249 455379 : IF (tau_f) THEN
3250 0 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
3251 0 : CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, tau1_h, na, ir)
3252 0 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
3253 0 : CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, tau1_s, na, ir)
3254 446450 : ELSE IF (gradient_functional) THEN
3255 324000 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, rtau, na, ir)
3256 324000 : CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, rtau, na, ir)
3257 324000 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, rtau, na, ir)
3258 324000 : CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, rtau, na, ir)
3259 : ELSE
3260 122450 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, rrho, rtau, na, ir)
3261 122450 : CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, rrho, rtau, na, ir)
3262 122450 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, rrho, rtau, na, ir)
3263 122450 : CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, rrho, rtau, na, ir)
3264 : END IF
3265 : END DO
3266 :
3267 : CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
3268 : rho_set=rho_set_h, rho1_set=rho1_set_h, &
3269 : deriv_set=deriv_set, &
3270 : w=weight_h, vxc=vxc_h, vxg=vxg_h, vtau=vtau_h, do_triplet=do_triplet, &
3271 8929 : do_sf=my_do_sf)
3272 : CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
3273 : rho_set=rho_set_s, rho1_set=rho1_set_s, &
3274 : deriv_set=deriv_set, &
3275 : w=weight_s, vxc=vxc_s, vxg=vxg_s, vtau=vtau_s, do_triplet=do_triplet, &
3276 8929 : do_sf=my_do_sf)
3277 :
3278 8929 : CALL get_rho_atom(rho_atom=rho1_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
3279 8929 : IF (gradient_functional) THEN
3280 : CALL gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
3281 6480 : grid_atom, basis_1c, harmonics, nspins)
3282 : ELSE
3283 : CALL gaVxcgb_noGC(vxc_h, vxc_s, int_hh, int_ss, &
3284 2449 : grid_atom, basis_1c, harmonics, nspins)
3285 : END IF
3286 8929 : IF (tau_f) THEN
3287 : CALL dgaVtaudgb(vtau_h, vtau_s, int_hh, int_ss, &
3288 0 : tau_basis_cache, nspins)
3289 : END IF
3290 :
3291 21505 : NULLIFY (r_h, r_s, dr_h, dr_s)
3292 :
3293 : END DO
3294 :
3295 : ! some cleanup
3296 12576 : DEALLOCATE (rho_h, rho_s, rho1_h, rho1_s, vxc_h, vxc_s)
3297 12576 : DEALLOCATE (drho_h, drho_s, vxg_h, vxg_s)
3298 12576 : DEALLOCATE (drho1_h, drho1_s)
3299 12576 : IF (tau_f) THEN
3300 0 : DEALLOCATE (tau_h, tau_s, tau1_h, tau1_s)
3301 0 : DEALLOCATE (vtau_h, vtau_s)
3302 0 : CALL release_tau_basis_cache(tau_basis_cache)
3303 : END IF
3304 :
3305 12576 : CALL xc_dset_release(deriv_set)
3306 12576 : CALL xc_rho_set_release(rho_set_h)
3307 12576 : CALL xc_rho_set_release(rho1_set_h)
3308 12576 : CALL xc_rho_set_release(rho_set_s)
3309 45494 : CALL xc_rho_set_release(rho1_set_s)
3310 : END DO
3311 :
3312 6130 : CALL timestop(handle)
3313 :
3314 453620 : END SUBROUTINE calculate_xc_2nd_deriv_atom
3315 :
3316 : ! **************************************************************************************************
3317 : !> \brief ...
3318 : !> \param qs_env ...
3319 : !> \param rho0_atom_set ...
3320 : !> \param rho1_atom_set ...
3321 : !> \param rho2_atom_set ...
3322 : !> \param kind_set ...
3323 : !> \param xc_section ...
3324 : !> \param is_triplet ...
3325 : !> \param accuracy ...
3326 : ! **************************************************************************************************
3327 0 : SUBROUTINE calculate_gfxc_atom(qs_env, rho0_atom_set, rho1_atom_set, rho2_atom_set, &
3328 : kind_set, xc_section, is_triplet, accuracy)
3329 :
3330 : TYPE(qs_environment_type), POINTER :: qs_env
3331 : TYPE(rho_atom_type), DIMENSION(:), POINTER :: rho0_atom_set, rho1_atom_set, &
3332 : rho2_atom_set
3333 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: kind_set
3334 : TYPE(section_vals_type), OPTIONAL, POINTER :: xc_section
3335 : LOGICAL, INTENT(IN) :: is_triplet
3336 : INTEGER, INTENT(IN) :: accuracy
3337 :
3338 : CHARACTER(LEN=*), PARAMETER :: routineN = 'calculate_gfxc_atom'
3339 : REAL(KIND=dp), PARAMETER :: epsrho = 5.e-4_dp
3340 :
3341 : INTEGER :: bo(2), handle, iat, iatom, ikind, ir, &
3342 : istep, mspins, myfun, na, natom, nf, &
3343 : nr, ns, nspins, nstep, num_pe
3344 : INTEGER, DIMENSION(2, 3) :: bounds
3345 0 : INTEGER, DIMENSION(:), POINTER :: atom_list
3346 : LOGICAL :: accint, donlcc, gradient_f, lsd, nlcc, &
3347 : paw_atom, tau_f
3348 : REAL(dp) :: agr, alpha, beta, density_cut, exc_h, &
3349 : exc_s, gradient_cut, oeps1, oeps2, &
3350 : tau_cut
3351 : REAL(dp), DIMENSION(1, 1, 1) :: tau_d
3352 : REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d
3353 0 : REAL(dp), DIMENSION(:, :), POINTER :: rho_nlcc, weight_h, weight_s
3354 0 : REAL(dp), DIMENSION(:, :, :), POINTER :: rho0_h, rho0_s, rho1_h, rho1_s, rho_h, &
3355 0 : rho_s, tau0_h, tau0_s, tau1_h, tau1_s, &
3356 0 : tau_h, tau_s, vtau_h, vtau_s, vxc_h, &
3357 0 : vxc_s
3358 0 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho0_h, drho0_s, drho1_h, drho1_s, &
3359 0 : drho_h, drho_s, vxg_h, vxg_s
3360 : REAL(KIND=dp), DIMENSION(-4:4) :: ak, bl
3361 0 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
3362 : TYPE(dft_control_type), POINTER :: dft_control
3363 : TYPE(grid_atom_type), POINTER :: grid_atom
3364 : TYPE(gto_basis_set_type), POINTER :: basis_1c
3365 : TYPE(harmonics_atom_type), POINTER :: harmonics
3366 : TYPE(mp_para_env_type), POINTER :: para_env
3367 0 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s, fint_hh, fint_ss, int_hh, &
3368 0 : int_ss, r_h, r_s
3369 0 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
3370 : TYPE(rho_atom_type), POINTER :: rho0_atom, rho1_atom, rho2_atom
3371 : TYPE(section_vals_type), POINTER :: xc_fun_section
3372 0 : TYPE(tau_basis_cache_type) :: tau_basis_cache
3373 : TYPE(xc_derivative_set_type) :: deriv_set
3374 : TYPE(xc_rho_cflags_type) :: needs
3375 : TYPE(xc_rho_set_type) :: rho_set_h, rho_set_s
3376 :
3377 0 : CALL timeset(routineN, handle)
3378 :
3379 0 : NULLIFY (vtau_h, vtau_s)
3380 :
3381 0 : ak = 0.0_dp
3382 0 : bl = 0.0_dp
3383 0 : SELECT CASE (accuracy)
3384 : CASE (:4)
3385 0 : nstep = 2
3386 0 : ak(-2:2) = [1.0_dp, -8.0_dp, 0.0_dp, 8.0_dp, -1.0_dp]/12.0_dp
3387 0 : bl(-2:2) = [-1.0_dp, 16.0_dp, -30.0_dp, 16.0_dp, -1.0_dp]/12.0_dp
3388 : CASE (5:7)
3389 0 : nstep = 3
3390 0 : ak(-3:3) = [-1.0_dp, 9.0_dp, -45.0_dp, 0.0_dp, 45.0_dp, -9.0_dp, 1.0_dp]/60.0_dp
3391 0 : bl(-3:3) = [2.0_dp, -27.0_dp, 270.0_dp, -490.0_dp, 270.0_dp, -27.0_dp, 2.0_dp]/180.0_dp
3392 : CASE (8:)
3393 0 : nstep = 4
3394 : ak(-4:4) = [1.0_dp, -32.0_dp/3.0_dp, 56.0_dp, -224.0_dp, 0.0_dp, &
3395 0 : 224.0_dp, -56.0_dp, 32.0_dp/3.0_dp, -1.0_dp]/280.0_dp
3396 : bl(-4:4) = [-1.0_dp, 128.0_dp/9.0_dp, -112.0_dp, 896.0_dp, -14350.0_dp/9.0_dp, &
3397 0 : 896.0_dp, -112.0_dp, 128.0_dp/9.0_dp, -1.0_dp]/560.0_dp
3398 : END SELECT
3399 0 : oeps1 = 1.0_dp/epsrho
3400 0 : oeps2 = 1.0_dp/(epsrho**2)
3401 :
3402 : CALL get_qs_env(qs_env=qs_env, &
3403 : dft_control=dft_control, &
3404 : para_env=para_env, &
3405 0 : atomic_kind_set=atomic_kind_set)
3406 :
3407 0 : xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
3408 0 : CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", i_val=myfun)
3409 :
3410 0 : accint = dft_control%qs_control%gapw_control%accurate_xcint
3411 :
3412 0 : IF (myfun == xc_none) THEN
3413 : ! no action needed?
3414 : ELSE
3415 0 : CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", r_val=density_cut)
3416 0 : CALL section_vals_val_get(xc_section, "GRADIENT_CUTOFF", r_val=gradient_cut)
3417 0 : CALL section_vals_val_get(xc_section, "TAU_CUTOFF", r_val=tau_cut)
3418 :
3419 0 : nlcc = has_nlcc(kind_set)
3420 0 : lsd = dft_control%lsd
3421 0 : nspins = dft_control%nspins
3422 0 : mspins = nspins
3423 0 : IF (is_triplet) THEN
3424 0 : CPASSERT(nspins == 1)
3425 0 : lsd = .TRUE.
3426 0 : mspins = 2
3427 : END IF
3428 0 : needs = xc_functionals_get_needs(xc_fun_section, lsd=lsd, calc_potential=.TRUE.)
3429 0 : gradient_f = (needs%drho .OR. needs%drho_spin)
3430 0 : tau_f = (needs%tau .OR. needs%tau_spin)
3431 :
3432 : ! Here starts the loop over all the atoms
3433 0 : DO ikind = 1, SIZE(atomic_kind_set)
3434 0 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
3435 : CALL get_qs_kind(kind_set(ikind), paw_atom=paw_atom, &
3436 0 : harmonics=harmonics, grid_atom=grid_atom)
3437 0 : CALL get_qs_kind(kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
3438 :
3439 0 : IF (.NOT. paw_atom) CYCLE
3440 :
3441 0 : nr = grid_atom%nr
3442 0 : na = grid_atom%ng_sphere
3443 :
3444 : ! set integration weights
3445 0 : IF (accint) THEN
3446 0 : weight_h => grid_atom%weight
3447 0 : alpha = dft_control%qs_control%gapw_control%aw(ikind)
3448 0 : IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
3449 0 : IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
3450 : END IF
3451 0 : IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
3452 0 : ALLOCATE (grid_atom%gapw_weight_s(na, nr))
3453 0 : DO ir = 1, nr
3454 0 : agr = 1.0_dp - EXP(-alpha*grid_atom%rad2(ir))
3455 0 : grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
3456 : END DO
3457 0 : grid_atom%gapw_weight_alpha = alpha
3458 : END IF
3459 0 : weight_s => grid_atom%gapw_weight_s
3460 : ELSE
3461 0 : weight_h => grid_atom%weight
3462 0 : weight_s => grid_atom%weight
3463 : END IF
3464 :
3465 : ! Prepare the structures needed to calculate and store the xc derivatives
3466 :
3467 : ! Array dimension: here anly one dimensional arrays are used,
3468 : ! i.e. only the first column of deriv_data is read.
3469 : ! The other to dimensions are set to size equal 1
3470 0 : bounds(1:2, 1:3) = 1
3471 0 : bounds(2, 1) = na
3472 0 : bounds(2, 2) = nr
3473 :
3474 : ! create a place where to put the derivatives
3475 0 : CALL xc_dset_create(deriv_set, local_bounds=bounds)
3476 : ! create the place where to store the argument for the functionals
3477 : CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
3478 0 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3479 : CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
3480 0 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3481 :
3482 : ! allocate the required 3d arrays where to store rho and drho
3483 0 : CALL xc_rho_set_atom_update(rho_set_h, needs, mspins, bounds)
3484 0 : CALL xc_rho_set_atom_update(rho_set_s, needs, mspins, bounds)
3485 :
3486 : ALLOCATE (rho_h(na, nr, mspins), rho_s(na, nr, mspins), &
3487 : rho0_h(na, nr, nspins), rho0_s(na, nr, nspins), &
3488 0 : rho1_h(na, nr, nspins), rho1_s(na, nr, nspins))
3489 0 : ALLOCATE (vxc_h(na, nr, mspins), vxc_s(na, nr, mspins))
3490 0 : IF (gradient_f) THEN
3491 : ALLOCATE (drho_h(4, na, nr, mspins), drho_s(4, na, nr, mspins), &
3492 : drho0_h(4, na, nr, nspins), drho0_s(4, na, nr, nspins), &
3493 0 : drho1_h(4, na, nr, nspins), drho1_s(4, na, nr, nspins))
3494 0 : ALLOCATE (vxg_h(3, na, nr, mspins), vxg_s(3, na, nr, mspins))
3495 : END IF
3496 0 : IF (tau_f) THEN
3497 0 : CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
3498 : ALLOCATE (tau_h(na, nr, mspins), tau_s(na, nr, mspins), &
3499 : tau0_h(na, nr, nspins), tau0_s(na, nr, nspins), &
3500 0 : tau1_h(na, nr, nspins), tau1_s(na, nr, nspins))
3501 0 : ALLOCATE (vtau_h(na, nr, mspins), vtau_s(na, nr, mspins))
3502 : END IF
3503 : !
3504 : ! NLCC: prepare rho and drho of the core charge for this KIND
3505 0 : donlcc = .FALSE.
3506 0 : IF (nlcc) THEN
3507 0 : NULLIFY (rho_nlcc)
3508 0 : rho_nlcc => kind_set(ikind)%nlcc_pot
3509 0 : IF (ASSOCIATED(rho_nlcc)) donlcc = .TRUE.
3510 : END IF
3511 :
3512 : ! Distribute the atoms of this kind
3513 0 : num_pe = para_env%num_pe
3514 0 : bo = get_limit(natom, num_pe, para_env%mepos)
3515 :
3516 0 : DO iat = bo(1), bo(2)
3517 0 : iatom = atom_list(iat)
3518 : !
3519 0 : NULLIFY (int_hh, int_ss)
3520 0 : rho0_atom => rho0_atom_set(iatom)
3521 0 : CALL get_rho_atom(rho_atom=rho0_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
3522 0 : ALLOCATE (fint_ss(nspins), fint_hh(nspins))
3523 0 : DO ns = 1, nspins
3524 0 : nf = SIZE(int_ss(ns)%r_coef, 1)
3525 0 : ALLOCATE (fint_ss(ns)%r_coef(nf, nf))
3526 0 : nf = SIZE(int_hh(ns)%r_coef, 1)
3527 0 : ALLOCATE (fint_hh(ns)%r_coef(nf, nf))
3528 : END DO
3529 :
3530 : ! RHO0
3531 0 : rho0_h = 0.0_dp
3532 0 : rho0_s = 0.0_dp
3533 0 : rho0_atom => rho0_atom_set(iatom)
3534 0 : IF (gradient_f) THEN
3535 0 : NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
3536 : CALL get_rho_atom(rho_atom=rho0_atom, rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
3537 0 : drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
3538 0 : drho0_h = 0.0_dp
3539 0 : drho0_s = 0.0_dp
3540 : ELSE
3541 0 : NULLIFY (r_h, r_s)
3542 0 : CALL get_rho_atom(rho_atom=rho0_atom, rho_rad_h=r_h, rho_rad_s=r_s)
3543 0 : rho_d = 0.0_dp
3544 : END IF
3545 0 : DO ir = 1, nr
3546 : CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
3547 : ir, r_h, r_s, rho0_h, rho0_s, dr_h, dr_s, &
3548 0 : r_h_d, r_s_d, drho0_h, drho0_s)
3549 0 : IF (donlcc) THEN
3550 : CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
3551 0 : ir, rho_nlcc(:, 1), rho0_h, rho0_s, rho_nlcc(:, 2), drho0_h, drho0_s)
3552 : END IF
3553 : END DO
3554 0 : IF (tau_f) THEN
3555 : !compute tau on the grid all at once
3556 0 : CALL calc_tau_atom(tau0_h, tau0_s, rho0_atom, tau_basis_cache, nspins)
3557 : ELSE
3558 0 : tau_d = 0.0_dp
3559 : END IF
3560 : ! RHO1
3561 0 : rho1_h = 0.0_dp
3562 0 : rho1_s = 0.0_dp
3563 0 : rho1_atom => rho1_atom_set(iatom)
3564 0 : IF (gradient_f) THEN
3565 0 : NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
3566 : CALL get_rho_atom(rho_atom=rho1_atom, rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
3567 0 : drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
3568 0 : drho1_h = 0.0_dp
3569 0 : drho1_s = 0.0_dp
3570 : ELSE
3571 0 : NULLIFY (r_h, r_s)
3572 0 : CALL get_rho_atom(rho_atom=rho1_atom, rho_rad_h=r_h, rho_rad_s=r_s)
3573 : END IF
3574 0 : DO ir = 1, nr
3575 : CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
3576 : ir, r_h, r_s, rho1_h, rho1_s, dr_h, dr_s, &
3577 0 : r_h_d, r_s_d, drho1_h, drho1_s)
3578 : END DO
3579 0 : IF (tau_f) THEN
3580 : !compute tau on the grid all at once
3581 0 : CALL calc_tau_atom(tau1_h, tau1_s, rho1_atom, tau_basis_cache, nspins)
3582 : END IF
3583 : ! RHO2
3584 0 : rho2_atom => rho2_atom_set(iatom)
3585 :
3586 0 : DO istep = -nstep, nstep
3587 :
3588 0 : beta = REAL(istep, KIND=dp)*epsrho
3589 :
3590 0 : IF (is_triplet) THEN
3591 0 : rho_h(:, :, 1) = rho0_h(:, :, 1) + beta*rho1_h(:, :, 1)
3592 0 : rho_h(:, :, 2) = rho0_h(:, :, 1)
3593 0 : rho_h = 0.5_dp*rho_h
3594 0 : rho_s(:, :, 1) = rho0_s(:, :, 1) + beta*rho1_s(:, :, 1)
3595 0 : rho_s(:, :, 2) = rho0_s(:, :, 1)
3596 0 : rho_s = 0.5_dp*rho_s
3597 0 : IF (gradient_f) THEN
3598 0 : drho_h(:, :, :, 1) = drho0_h(:, :, :, 1) + beta*drho1_h(:, :, :, 1)
3599 0 : drho_h(:, :, :, 2) = drho0_h(:, :, :, 1)
3600 0 : drho_h = 0.5_dp*drho_h
3601 0 : drho_s(:, :, :, 1) = drho0_s(:, :, :, 1) + beta*drho1_s(:, :, :, 1)
3602 0 : drho_s(:, :, :, 2) = drho0_s(:, :, :, 1)
3603 0 : drho_s = 0.5_dp*drho_s
3604 : END IF
3605 0 : IF (tau_f) THEN
3606 0 : tau_h(:, :, 1) = tau0_h(:, :, 1) + beta*tau1_h(:, :, 1)
3607 0 : tau_h(:, :, 2) = tau0_h(:, :, 1)
3608 0 : tau_h = 0.5_dp*tau0_h
3609 0 : tau_s(:, :, 1) = tau0_s(:, :, 1) + beta*tau1_s(:, :, 1)
3610 0 : tau_s(:, :, 2) = tau0_s(:, :, 1)
3611 0 : tau_s = 0.5_dp*tau0_s
3612 : END IF
3613 : ELSE
3614 0 : rho_h = rho0_h + beta*rho1_h
3615 0 : rho_s = rho0_s + beta*rho1_s
3616 0 : IF (gradient_f) THEN
3617 0 : drho_h = drho0_h + beta*drho1_h
3618 0 : drho_s = drho0_s + beta*drho1_s
3619 : END IF
3620 0 : IF (tau_f) THEN
3621 0 : tau_h = tau0_h + beta*tau1_h
3622 0 : tau_s = tau0_s + beta*tau1_s
3623 : END IF
3624 : END IF
3625 : !
3626 0 : IF (gradient_f) THEN
3627 : drho_h(4, :, :, :) = SQRT( &
3628 : drho_h(1, :, :, :)*drho_h(1, :, :, :) + &
3629 : drho_h(2, :, :, :)*drho_h(2, :, :, :) + &
3630 0 : drho_h(3, :, :, :)*drho_h(3, :, :, :))
3631 :
3632 : drho_s(4, :, :, :) = SQRT( &
3633 : drho_s(1, :, :, :)*drho_s(1, :, :, :) + &
3634 : drho_s(2, :, :, :)*drho_s(2, :, :, :) + &
3635 0 : drho_s(3, :, :, :)*drho_s(3, :, :, :))
3636 : END IF
3637 :
3638 0 : DO ir = 1, nr
3639 0 : IF (tau_f) THEN
3640 0 : CALL fill_rho_set(rho_set_h, lsd, mspins, needs, rho_h, drho_h, tau_h, na, ir)
3641 0 : CALL fill_rho_set(rho_set_s, lsd, mspins, needs, rho_s, drho_s, tau_s, na, ir)
3642 0 : ELSE IF (gradient_f) THEN
3643 0 : CALL fill_rho_set(rho_set_h, lsd, mspins, needs, rho_h, drho_h, tau_d, na, ir)
3644 0 : CALL fill_rho_set(rho_set_s, lsd, mspins, needs, rho_s, drho_s, tau_d, na, ir)
3645 : ELSE
3646 0 : CALL fill_rho_set(rho_set_h, lsd, mspins, needs, rho_h, rho_d, tau_d, na, ir)
3647 0 : CALL fill_rho_set(rho_set_s, lsd, mspins, needs, rho_s, rho_d, tau_d, na, ir)
3648 : END IF
3649 : END DO
3650 :
3651 : ! hard atom density !
3652 0 : CALL xc_dset_zero_all(deriv_set)
3653 : CALL vxc_of_r_new(xc_fun_section, rho_set_h, deriv_set, 1, needs, weight_h, &
3654 0 : lsd, na, nr, exc_h, vxc_h, vxg_h, vtau_h)
3655 0 : IF (is_triplet) THEN
3656 0 : vxc_h(:, :, 1) = vxc_h(:, :, 1) - vxc_h(:, :, 2)
3657 0 : IF (gradient_f) THEN
3658 0 : vxg_h(:, :, :, 1) = vxg_h(:, :, :, 1) - vxg_h(:, :, :, 2)
3659 : END IF
3660 0 : IF (tau_f) THEN
3661 0 : vtau_h(:, :, 1) = vtau_h(:, :, 1) - vtau_h(:, :, 2)
3662 : END IF
3663 : END IF
3664 : ! soft atom density !
3665 0 : CALL xc_dset_zero_all(deriv_set)
3666 : CALL vxc_of_r_new(xc_fun_section, rho_set_s, deriv_set, 1, needs, weight_s, &
3667 0 : lsd, na, nr, exc_s, vxc_s, vxg_s, vtau_s)
3668 0 : IF (is_triplet) THEN
3669 0 : vxc_s(:, :, 1) = vxc_s(:, :, 1) - vxc_s(:, :, 2)
3670 0 : IF (gradient_f) THEN
3671 0 : vxg_s(:, :, :, 1) = vxg_s(:, :, :, 1) - vxg_s(:, :, :, 2)
3672 : END IF
3673 0 : IF (tau_f) THEN
3674 0 : vtau_s(:, :, 1) = vtau_s(:, :, 1) - vtau_s(:, :, 2)
3675 : END IF
3676 : END IF
3677 : ! potentials
3678 0 : DO ns = 1, nspins
3679 0 : fint_hh(ns)%r_coef(:, :) = 0.0_dp
3680 0 : fint_ss(ns)%r_coef(:, :) = 0.0_dp
3681 : END DO
3682 0 : IF (gradient_f) THEN
3683 : CALL gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, fint_hh, fint_ss, &
3684 0 : grid_atom, basis_1c, harmonics, nspins)
3685 : ELSE
3686 : CALL gaVxcgb_noGC(vxc_h, vxc_s, fint_hh, fint_ss, &
3687 0 : grid_atom, basis_1c, harmonics, nspins)
3688 : END IF
3689 0 : IF (tau_f) THEN
3690 : CALL dgaVtaudgb(vtau_h, vtau_s, fint_hh, fint_ss, &
3691 0 : tau_basis_cache, nspins)
3692 : END IF
3693 : ! first derivative fxc
3694 0 : NULLIFY (int_hh, int_ss)
3695 0 : CALL get_rho_atom(rho_atom=rho1_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
3696 0 : DO ns = 1, nspins
3697 0 : int_ss(ns)%r_coef(:, :) = int_ss(ns)%r_coef(:, :) + oeps1*ak(istep)*fint_ss(ns)%r_coef(:, :)
3698 0 : int_hh(ns)%r_coef(:, :) = int_hh(ns)%r_coef(:, :) + oeps1*ak(istep)*fint_hh(ns)%r_coef(:, :)
3699 : END DO
3700 : ! second derivative gxc
3701 0 : NULLIFY (int_hh, int_ss)
3702 0 : CALL get_rho_atom(rho_atom=rho2_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
3703 0 : DO ns = 1, nspins
3704 0 : int_ss(ns)%r_coef(:, :) = int_ss(ns)%r_coef(:, :) + oeps2*bl(istep)*fint_ss(ns)%r_coef(:, :)
3705 0 : int_hh(ns)%r_coef(:, :) = int_hh(ns)%r_coef(:, :) + oeps2*bl(istep)*fint_hh(ns)%r_coef(:, :)
3706 : END DO
3707 : END DO
3708 : !
3709 0 : DO ns = 1, nspins
3710 0 : DEALLOCATE (fint_ss(ns)%r_coef)
3711 0 : DEALLOCATE (fint_hh(ns)%r_coef)
3712 : END DO
3713 0 : DEALLOCATE (fint_ss, fint_hh)
3714 :
3715 : END DO ! iat
3716 :
3717 : ! Release the xc structure used to store the xc derivatives
3718 0 : CALL xc_dset_release(deriv_set)
3719 0 : CALL xc_rho_set_release(rho_set_h)
3720 0 : CALL xc_rho_set_release(rho_set_s)
3721 :
3722 0 : DEALLOCATE (rho_h, rho_s, rho0_h, rho0_s, rho1_h, rho1_s)
3723 0 : DEALLOCATE (vxc_h, vxc_s)
3724 0 : IF (gradient_f) THEN
3725 0 : DEALLOCATE (drho_h, drho_s, drho0_h, drho0_s, drho1_h, drho1_s)
3726 0 : DEALLOCATE (vxg_h, vxg_s)
3727 : END IF
3728 0 : IF (tau_f) THEN
3729 0 : DEALLOCATE (tau_h, tau_s, tau0_h, tau0_s, tau1_h, tau1_s)
3730 0 : DEALLOCATE (vtau_h, vtau_s)
3731 0 : CALL release_tau_basis_cache(tau_basis_cache)
3732 : END IF
3733 : END DO ! ikind
3734 :
3735 : END IF !xc_none
3736 :
3737 0 : CALL timestop(handle)
3738 :
3739 0 : END SUBROUTINE calculate_gfxc_atom
3740 :
3741 : ! **************************************************************************************************
3742 : !> \brief ...
3743 : !> \param qs_env ...
3744 : !> \param rho0_atom_set ...
3745 : !> \param rho1_atom_set ...
3746 : !> \param rho2_atom_set ...
3747 : !> \param kind_set ...
3748 : !> \param xc_section ...
3749 : !> \param is_triplet ...
3750 : !> \param accuracy ...
3751 : !> \param epsrho ...
3752 : ! **************************************************************************************************
3753 114 : SUBROUTINE gfxc_atom_diff(qs_env, rho0_atom_set, rho1_atom_set, rho2_atom_set, &
3754 : kind_set, xc_section, is_triplet, accuracy, epsrho)
3755 :
3756 : TYPE(qs_environment_type), POINTER :: qs_env
3757 : TYPE(rho_atom_type), DIMENSION(:), POINTER :: rho0_atom_set, rho1_atom_set, &
3758 : rho2_atom_set
3759 : TYPE(qs_kind_type), DIMENSION(:), POINTER :: kind_set
3760 : TYPE(section_vals_type), OPTIONAL, POINTER :: xc_section
3761 : LOGICAL, INTENT(IN) :: is_triplet
3762 : INTEGER, INTENT(IN) :: accuracy
3763 : REAL(KIND=dp), INTENT(IN) :: epsrho
3764 :
3765 : CHARACTER(LEN=*), PARAMETER :: routineN = 'gfxc_atom_diff'
3766 :
3767 : INTEGER :: bo(2), handle, iat, iatom, ikind, ir, &
3768 : istep, mspins, myfun, na, natom, nf, &
3769 : nr, ns, nspins, nstep, num_pe
3770 : INTEGER, DIMENSION(2, 3) :: bounds
3771 114 : INTEGER, DIMENSION(:), POINTER :: atom_list
3772 : LOGICAL :: accint, donlcc, gradient_f, lsd, nlcc, &
3773 : paw_atom, tau_f
3774 : REAL(dp) :: agr, alpha, beta, density_cut, &
3775 : gradient_cut, oeps1, tau_cut
3776 114 : REAL(dp), CONTIGUOUS, DIMENSION(:, :, :), POINTER :: vtau_h, vtau_s, vxc_h, vxc_s
3777 : REAL(dp), DIMENSION(1, 1, 1) :: tau_d
3778 : REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d
3779 228 : REAL(dp), DIMENSION(:, :), POINTER :: rho_nlcc, weight_h, weight_s
3780 228 : REAL(dp), DIMENSION(:, :, :), POINTER :: rho0_h, rho0_s, rho1_h, rho1_s, rho_h, &
3781 228 : rho_s, tau0_h, tau0_s, tau1_h, tau1_s, &
3782 114 : tau_h, tau_s
3783 114 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho0_h, drho0_s, drho1_h, drho1_s, &
3784 228 : drho_h, drho_s, vxg_h, vxg_s
3785 : REAL(KIND=dp), DIMENSION(-4:4) :: ak
3786 114 : TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
3787 : TYPE(dft_control_type), POINTER :: dft_control
3788 : TYPE(grid_atom_type), POINTER :: grid_atom
3789 : TYPE(gto_basis_set_type), POINTER :: basis_1c
3790 : TYPE(harmonics_atom_type), POINTER :: harmonics
3791 : TYPE(mp_para_env_type), POINTER :: para_env
3792 114 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s, fint_hh, fint_ss, int_hh, &
3793 114 : int_ss, r_h, r_s
3794 114 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
3795 : TYPE(rho_atom_type), POINTER :: rho0_atom, rho1_atom, rho2_atom
3796 : TYPE(section_vals_type), POINTER :: xc_fun_section
3797 114 : TYPE(tau_basis_cache_type) :: tau_basis_cache
3798 : TYPE(xc_derivative_set_type) :: deriv_set
3799 : TYPE(xc_rho_cflags_type) :: needs
3800 : TYPE(xc_rho_set_type) :: rho1_set_h, rho1_set_s, rho_set_h, &
3801 : rho_set_s
3802 :
3803 114 : CALL timeset(routineN, handle)
3804 :
3805 114 : NULLIFY (vtau_h, vtau_s)
3806 :
3807 114 : ak = 0.0_dp
3808 114 : SELECT CASE (accuracy)
3809 : CASE (:4)
3810 0 : nstep = 2
3811 0 : ak(-2:2) = [1.0_dp, -8.0_dp, 0.0_dp, 8.0_dp, -1.0_dp]/12.0_dp
3812 : CASE (5:7)
3813 912 : nstep = 3
3814 912 : ak(-3:3) = [-1.0_dp, 9.0_dp, -45.0_dp, 0.0_dp, 45.0_dp, -9.0_dp, 1.0_dp]/60.0_dp
3815 : CASE (8:)
3816 0 : nstep = 4
3817 : ak(-4:4) = [1.0_dp, -32.0_dp/3.0_dp, 56.0_dp, -224.0_dp, 0.0_dp, &
3818 114 : 224.0_dp, -56.0_dp, 32.0_dp/3.0_dp, -1.0_dp]/280.0_dp
3819 : END SELECT
3820 114 : oeps1 = 1.0_dp/epsrho
3821 :
3822 : CALL get_qs_env(qs_env=qs_env, &
3823 : dft_control=dft_control, &
3824 : para_env=para_env, &
3825 114 : atomic_kind_set=atomic_kind_set)
3826 :
3827 114 : xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
3828 114 : CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", i_val=myfun)
3829 :
3830 114 : accint = dft_control%qs_control%gapw_control%accurate_xcint
3831 :
3832 114 : IF (myfun == xc_none) THEN
3833 : ! no action needed?
3834 : ELSE
3835 : ! calculate fxc
3836 : CALL calculate_xc_2nd_deriv_atom(rho0_atom_set, rho1_atom_set, qs_env, xc_section, para_env, &
3837 114 : do_triplet=is_triplet, kind_set_external=kind_set)
3838 :
3839 114 : CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", r_val=density_cut)
3840 114 : CALL section_vals_val_get(xc_section, "GRADIENT_CUTOFF", r_val=gradient_cut)
3841 114 : CALL section_vals_val_get(xc_section, "TAU_CUTOFF", r_val=tau_cut)
3842 :
3843 114 : nlcc = has_nlcc(kind_set)
3844 114 : lsd = dft_control%lsd
3845 114 : nspins = dft_control%nspins
3846 114 : mspins = nspins
3847 114 : IF (is_triplet) THEN
3848 12 : CPASSERT(nspins == 1)
3849 12 : lsd = .TRUE.
3850 12 : mspins = 2
3851 : END IF
3852 114 : needs = xc_functionals_get_needs(xc_fun_section, lsd=lsd, calc_potential=.TRUE.)
3853 114 : gradient_f = (needs%drho .OR. needs%drho_spin)
3854 114 : tau_f = (needs%tau .OR. needs%tau_spin)
3855 :
3856 : ! Here starts the loop over all the atoms
3857 386 : DO ikind = 1, SIZE(atomic_kind_set)
3858 272 : CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
3859 : CALL get_qs_kind(kind_set(ikind), paw_atom=paw_atom, &
3860 272 : harmonics=harmonics, grid_atom=grid_atom)
3861 272 : CALL get_qs_kind(kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
3862 :
3863 272 : IF (.NOT. paw_atom) CYCLE
3864 :
3865 258 : nr = grid_atom%nr
3866 258 : na = grid_atom%ng_sphere
3867 :
3868 : ! set integration weights
3869 258 : IF (accint) THEN
3870 138 : weight_h => grid_atom%weight
3871 138 : alpha = dft_control%qs_control%gapw_control%aw(ikind)
3872 138 : IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
3873 138 : IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
3874 : END IF
3875 138 : IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
3876 0 : ALLOCATE (grid_atom%gapw_weight_s(na, nr))
3877 0 : DO ir = 1, nr
3878 0 : agr = 1.0_dp - EXP(-alpha*grid_atom%rad2(ir))
3879 0 : grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
3880 : END DO
3881 0 : grid_atom%gapw_weight_alpha = alpha
3882 : END IF
3883 138 : weight_s => grid_atom%gapw_weight_s
3884 : ELSE
3885 120 : weight_h => grid_atom%weight
3886 120 : weight_s => grid_atom%weight
3887 : END IF
3888 :
3889 : ! Prepare the structures needed to calculate and store the xc derivatives
3890 :
3891 : ! Array dimension: here anly one dimensional arrays are used,
3892 : ! i.e. only the first column of deriv_data is read.
3893 : ! The other to dimensions are set to size equal 1
3894 2580 : bounds(1:2, 1:3) = 1
3895 258 : bounds(2, 1) = na
3896 258 : bounds(2, 2) = nr
3897 :
3898 : ! create a place where to put the derivatives
3899 258 : CALL xc_dset_create(deriv_set, local_bounds=bounds)
3900 : ! create the place where to store the argument for the functionals
3901 : CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
3902 258 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3903 : CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
3904 258 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3905 : CALL xc_rho_set_create(rho1_set_h, bounds, rho_cutoff=density_cut, &
3906 258 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3907 : CALL xc_rho_set_create(rho1_set_s, bounds, rho_cutoff=density_cut, &
3908 258 : drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
3909 :
3910 : ! allocate the required 3d arrays where to store rho and drho
3911 258 : CALL xc_rho_set_atom_update(rho_set_h, needs, mspins, bounds)
3912 258 : CALL xc_rho_set_atom_update(rho_set_s, needs, mspins, bounds)
3913 258 : CALL xc_rho_set_atom_update(rho1_set_h, needs, mspins, bounds)
3914 258 : CALL xc_rho_set_atom_update(rho1_set_s, needs, mspins, bounds)
3915 :
3916 : ALLOCATE (rho_h(na, nr, nspins), rho_s(na, nr, nspins), &
3917 : rho0_h(na, nr, nspins), rho0_s(na, nr, nspins), &
3918 5160 : rho1_h(na, nr, nspins), rho1_s(na, nr, nspins))
3919 1806 : ALLOCATE (vxc_h(na, nr, nspins), vxc_s(na, nr, nspins))
3920 258 : IF (gradient_f) THEN
3921 : ALLOCATE (drho_h(4, na, nr, nspins), drho_s(4, na, nr, nspins), &
3922 : drho0_h(4, na, nr, nspins), drho0_s(4, na, nr, nspins), &
3923 3520 : drho1_h(4, na, nr, nspins), drho1_s(4, na, nr, nspins))
3924 1408 : ALLOCATE (vxg_h(3, na, nr, nspins), vxg_s(3, na, nr, nspins))
3925 : END IF
3926 258 : IF (tau_f) THEN
3927 0 : CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
3928 : ALLOCATE (tau_h(na, nr, nspins), tau_s(na, nr, nspins), &
3929 : tau0_h(na, nr, nspins), tau0_s(na, nr, nspins), &
3930 0 : tau1_h(na, nr, nspins), tau1_s(na, nr, nspins))
3931 0 : ALLOCATE (vtau_h(na, nr, nspins), vtau_s(na, nr, nspins))
3932 : END IF
3933 : !
3934 : ! NLCC: prepare rho and drho of the core charge for this KIND
3935 258 : donlcc = .FALSE.
3936 258 : IF (nlcc) THEN
3937 0 : NULLIFY (rho_nlcc)
3938 0 : rho_nlcc => kind_set(ikind)%nlcc_pot
3939 0 : IF (ASSOCIATED(rho_nlcc)) donlcc = .TRUE.
3940 : END IF
3941 :
3942 : ! Distribute the atoms of this kind
3943 258 : num_pe = para_env%num_pe
3944 258 : bo = get_limit(natom, num_pe, para_env%mepos)
3945 :
3946 441 : DO iat = bo(1), bo(2)
3947 183 : iatom = atom_list(iat)
3948 : !
3949 183 : NULLIFY (int_hh, int_ss)
3950 183 : rho0_atom => rho0_atom_set(iatom)
3951 183 : CALL get_rho_atom(rho_atom=rho0_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
3952 1098 : ALLOCATE (fint_ss(nspins), fint_hh(nspins))
3953 366 : DO ns = 1, nspins
3954 183 : nf = SIZE(int_ss(ns)%r_coef, 1)
3955 732 : ALLOCATE (fint_ss(ns)%r_coef(nf, nf))
3956 183 : nf = SIZE(int_hh(ns)%r_coef, 1)
3957 915 : ALLOCATE (fint_hh(ns)%r_coef(nf, nf))
3958 : END DO
3959 :
3960 : ! RHO0
3961 467016 : rho0_h = 0.0_dp
3962 467016 : rho0_s = 0.0_dp
3963 183 : rho0_atom => rho0_atom_set(iatom)
3964 183 : IF (gradient_f) THEN
3965 126 : NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
3966 : CALL get_rho_atom(rho_atom=rho0_atom, rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
3967 126 : drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
3968 1581552 : drho0_h = 0.0_dp
3969 1581552 : drho0_s = 0.0_dp
3970 : ELSE
3971 57 : NULLIFY (r_h, r_s)
3972 57 : CALL get_rho_atom(rho_atom=rho0_atom, rho_rad_h=r_h, rho_rad_s=r_s)
3973 57 : rho_d = 0.0_dp
3974 : END IF
3975 9333 : DO ir = 1, nr
3976 : CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
3977 : ir, r_h, r_s, rho0_h, rho0_s, dr_h, dr_s, &
3978 9150 : r_h_d, r_s_d, drho0_h, drho0_s)
3979 9333 : IF (donlcc) THEN
3980 : CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
3981 0 : ir, rho_nlcc(:, 1), rho0_h, rho0_s, rho_nlcc(:, 2), drho0_h, drho0_s)
3982 : END IF
3983 : END DO
3984 183 : IF (tau_f) THEN
3985 : !compute tau on the grid all at once
3986 0 : CALL calc_tau_atom(tau0_h, tau0_s, rho0_atom, tau_basis_cache, nspins)
3987 : ELSE
3988 183 : tau_d = 0.0_dp
3989 : END IF
3990 : ! RHO1
3991 467016 : rho1_h = 0.0_dp
3992 467016 : rho1_s = 0.0_dp
3993 183 : rho1_atom => rho1_atom_set(iatom)
3994 183 : IF (gradient_f) THEN
3995 126 : NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
3996 : CALL get_rho_atom(rho_atom=rho1_atom, rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
3997 126 : drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
3998 1581552 : drho1_h = 0.0_dp
3999 1581552 : drho1_s = 0.0_dp
4000 : ELSE
4001 57 : NULLIFY (r_h, r_s)
4002 57 : CALL get_rho_atom(rho_atom=rho1_atom, rho_rad_h=r_h, rho_rad_s=r_s)
4003 : END IF
4004 9333 : DO ir = 1, nr
4005 : CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
4006 : ir, r_h, r_s, rho1_h, rho1_s, dr_h, dr_s, &
4007 9333 : r_h_d, r_s_d, drho1_h, drho1_s)
4008 : END DO
4009 183 : IF (tau_f) THEN
4010 : !compute tau on the grid all at once
4011 0 : CALL calc_tau_atom(tau1_h, tau1_s, rho1_atom, tau_basis_cache, nspins)
4012 : END IF
4013 :
4014 9333 : DO ir = 1, nr
4015 9333 : IF (tau_f) THEN
4016 0 : CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, tau1_h, na, ir)
4017 0 : CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, tau1_s, na, ir)
4018 9150 : ELSE IF (gradient_f) THEN
4019 6300 : CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, tau_d, na, ir)
4020 6300 : CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, tau_d, na, ir)
4021 : ELSE
4022 2850 : CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, rho_d, tau_d, na, ir)
4023 2850 : CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, rho_d, tau_d, na, ir)
4024 : END IF
4025 : END DO
4026 :
4027 : ! RHO2
4028 183 : rho2_atom => rho2_atom_set(iatom)
4029 :
4030 1464 : DO istep = -nstep, nstep
4031 :
4032 1281 : beta = REAL(istep, KIND=dp)*epsrho
4033 :
4034 6536943 : rho_h = rho0_h + beta*rho1_h
4035 6536943 : rho_s = rho0_s + beta*rho1_s
4036 1281 : IF (gradient_f) THEN
4037 22140846 : drho_h = drho0_h + beta*drho1_h
4038 22140846 : drho_s = drho0_s + beta*drho1_s
4039 : END IF
4040 1281 : IF (tau_f) THEN
4041 0 : tau_h = tau0_h + beta*tau1_h
4042 0 : tau_s = tau0_s + beta*tau1_s
4043 : END IF
4044 : !
4045 1281 : IF (gradient_f) THEN
4046 : drho_h(4, :, :, :) = SQRT( &
4047 : drho_h(1, :, :, :)*drho_h(1, :, :, :) + &
4048 : drho_h(2, :, :, :)*drho_h(2, :, :, :) + &
4049 2250864 : drho_h(3, :, :, :)*drho_h(3, :, :, :))
4050 :
4051 : drho_s(4, :, :, :) = SQRT( &
4052 : drho_s(1, :, :, :)*drho_s(1, :, :, :) + &
4053 : drho_s(2, :, :, :)*drho_s(2, :, :, :) + &
4054 2250864 : drho_s(3, :, :, :)*drho_s(3, :, :, :))
4055 : END IF
4056 :
4057 65331 : DO ir = 1, nr
4058 65331 : IF (tau_f) THEN
4059 0 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
4060 0 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
4061 64050 : ELSE IF (gradient_f) THEN
4062 44100 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_d, na, ir)
4063 44100 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_d, na, ir)
4064 : ELSE
4065 19950 : CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, rho_d, tau_d, na, ir)
4066 19950 : CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, rho_d, tau_d, na, ir)
4067 : END IF
4068 : END DO
4069 :
4070 : ! hard atom density !
4071 1281 : CALL xc_dset_zero_all(deriv_set)
4072 : CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
4073 : rho_set=rho_set_h, rho1_set=rho1_set_h, &
4074 : deriv_set=deriv_set, &
4075 : w=weight_h, vxc=vxc_h, vxg=vxg_h, vtau=vtau_h, &
4076 1281 : do_triplet=is_triplet)
4077 : ! soft atom density !
4078 1281 : CALL xc_dset_zero_all(deriv_set)
4079 : CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
4080 : rho_set=rho_set_s, rho1_set=rho1_set_s, &
4081 : deriv_set=deriv_set, &
4082 : w=weight_s, vxc=vxc_s, vxg=vxg_s, vtau=vtau_s, &
4083 1281 : do_triplet=is_triplet)
4084 : ! potentials
4085 2562 : DO ns = 1, nspins
4086 2410793 : fint_hh(ns)%r_coef(:, :) = 0.0_dp
4087 2412074 : fint_ss(ns)%r_coef(:, :) = 0.0_dp
4088 : END DO
4089 1281 : IF (gradient_f) THEN
4090 : CALL gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, fint_hh, fint_ss, &
4091 882 : grid_atom, basis_1c, harmonics, nspins)
4092 : ELSE
4093 : CALL gaVxcgb_noGC(vxc_h, vxc_s, fint_hh, fint_ss, &
4094 399 : grid_atom, basis_1c, harmonics, nspins)
4095 : END IF
4096 1281 : IF (tau_f) THEN
4097 : CALL dgaVtaudgb(vtau_h, vtau_s, fint_hh, fint_ss, &
4098 0 : tau_basis_cache, nspins)
4099 : END IF
4100 : ! second derivative gxc
4101 1281 : NULLIFY (int_hh, int_ss)
4102 1281 : CALL get_rho_atom(rho_atom=rho2_atom, ga_Vlocal_gb_h=int_hh, ga_Vlocal_gb_s=int_ss)
4103 2745 : DO ns = 1, nspins
4104 4820305 : int_ss(ns)%r_coef(:, :) = int_ss(ns)%r_coef(:, :) + oeps1*ak(istep)*fint_ss(ns)%r_coef(:, :)
4105 4821586 : int_hh(ns)%r_coef(:, :) = int_hh(ns)%r_coef(:, :) + oeps1*ak(istep)*fint_hh(ns)%r_coef(:, :)
4106 : END DO
4107 : END DO
4108 : !
4109 366 : DO ns = 1, nspins
4110 183 : DEALLOCATE (fint_ss(ns)%r_coef)
4111 366 : DEALLOCATE (fint_hh(ns)%r_coef)
4112 : END DO
4113 441 : DEALLOCATE (fint_ss, fint_hh)
4114 :
4115 : END DO ! iat
4116 :
4117 : ! Release the xc structure used to store the xc derivatives
4118 258 : CALL xc_dset_release(deriv_set)
4119 258 : CALL xc_rho_set_release(rho_set_h)
4120 258 : CALL xc_rho_set_release(rho_set_s)
4121 258 : CALL xc_rho_set_release(rho1_set_h)
4122 258 : CALL xc_rho_set_release(rho1_set_s)
4123 :
4124 258 : DEALLOCATE (rho_h, rho_s, rho0_h, rho0_s, rho1_h, rho1_s)
4125 258 : DEALLOCATE (vxc_h, vxc_s)
4126 258 : IF (gradient_f) THEN
4127 176 : DEALLOCATE (drho_h, drho_s, drho0_h, drho0_s, drho1_h, drho1_s)
4128 176 : DEALLOCATE (vxg_h, vxg_s)
4129 : END IF
4130 902 : IF (tau_f) THEN
4131 0 : DEALLOCATE (tau_h, tau_s, tau0_h, tau0_s, tau1_h, tau1_s)
4132 0 : DEALLOCATE (vtau_h, vtau_s)
4133 0 : CALL release_tau_basis_cache(tau_basis_cache)
4134 : END IF
4135 : END DO ! ikind
4136 :
4137 : END IF !xc_none
4138 :
4139 114 : CALL timestop(handle)
4140 :
4141 8436 : END SUBROUTINE gfxc_atom_diff
4142 :
4143 : ! **************************************************************************************************
4144 : !> \brief ...
4145 : !> \param grid_atom ...
4146 : !> \param harmonics ...
4147 : !> \param nspins ...
4148 : !> \param grad_func ...
4149 : !> \param ir ...
4150 : !> \param r_h ...
4151 : !> \param r_s ...
4152 : !> \param rho_h ...
4153 : !> \param rho_s ...
4154 : !> \param dr_h ...
4155 : !> \param dr_s ...
4156 : !> \param r_h_d ...
4157 : !> \param r_s_d ...
4158 : !> \param drho_h ...
4159 : !> \param drho_s ...
4160 : ! **************************************************************************************************
4161 3019240 : SUBROUTINE calc_rho_angular(grid_atom, harmonics, nspins, grad_func, &
4162 : ir, r_h, r_s, rho_h, rho_s, &
4163 : dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s)
4164 :
4165 : TYPE(grid_atom_type), POINTER :: grid_atom
4166 : TYPE(harmonics_atom_type), POINTER :: harmonics
4167 : INTEGER, INTENT(IN) :: nspins
4168 : LOGICAL, INTENT(IN) :: grad_func
4169 : INTEGER, INTENT(IN) :: ir
4170 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: r_h, r_s
4171 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: rho_h, rho_s
4172 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s
4173 : TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
4174 : REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s
4175 :
4176 : INTEGER :: ia, iso, ispin, na
4177 : REAL(KIND=dp) :: rad, urad
4178 :
4179 3019240 : CPASSERT(ASSOCIATED(r_h))
4180 3019240 : CPASSERT(ASSOCIATED(r_s))
4181 3019240 : CPASSERT(ASSOCIATED(rho_h))
4182 3019240 : CPASSERT(ASSOCIATED(rho_s))
4183 3019240 : IF (grad_func) THEN
4184 1923390 : CPASSERT(ASSOCIATED(dr_h))
4185 1923390 : CPASSERT(ASSOCIATED(dr_s))
4186 1923390 : CPASSERT(ASSOCIATED(r_h_d))
4187 1923390 : CPASSERT(ASSOCIATED(r_s_d))
4188 1923390 : CPASSERT(ASSOCIATED(drho_h))
4189 1923390 : CPASSERT(ASSOCIATED(drho_s))
4190 : END IF
4191 :
4192 3019240 : na = grid_atom%ng_sphere
4193 3019240 : rad = grid_atom%rad(ir)
4194 3019240 : urad = grid_atom%oorad2l(ir, 1)
4195 6410770 : DO ispin = 1, nspins
4196 50955740 : DO iso = 1, harmonics%max_iso_not0
4197 2276726520 : DO ia = 1, na
4198 : rho_h(ia, ir, ispin) = rho_h(ia, ir, ispin) + &
4199 2228790020 : r_h(ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)
4200 : rho_s(ia, ir, ispin) = rho_s(ia, ir, ispin) + &
4201 2273334990 : r_s(ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)
4202 : END DO ! ia
4203 : END DO ! iso
4204 : END DO ! ispin
4205 :
4206 3019240 : IF (grad_func) THEN
4207 4057370 : DO ispin = 1, nspins
4208 31072600 : DO iso = 1, harmonics%max_iso_not0
4209 1479545120 : DO ia = 1, na
4210 :
4211 : ! components of the gradient of rho1 hard
4212 : drho_h(1, ia, ir, ispin) = drho_h(1, ia, ir, ispin) + &
4213 : dr_h(ispin)%r_coef(ir, iso)* &
4214 : harmonics%a(1, ia)*harmonics%slm(ia, iso) + &
4215 : r_h_d(1, ispin)%r_coef(ir, iso)* &
4216 1448472520 : harmonics%slm(ia, iso)
4217 :
4218 : drho_h(2, ia, ir, ispin) = drho_h(2, ia, ir, ispin) + &
4219 : dr_h(ispin)%r_coef(ir, iso)* &
4220 : harmonics%a(2, ia)*harmonics%slm(ia, iso) + &
4221 : r_h_d(2, ispin)%r_coef(ir, iso)* &
4222 1448472520 : harmonics%slm(ia, iso)
4223 :
4224 : drho_h(3, ia, ir, ispin) = drho_h(3, ia, ir, ispin) + &
4225 : dr_h(ispin)%r_coef(ir, iso)* &
4226 : harmonics%a(3, ia)*harmonics%slm(ia, iso) + &
4227 : r_h_d(3, ispin)%r_coef(ir, iso)* &
4228 1448472520 : harmonics%slm(ia, iso)
4229 :
4230 : ! components of the gradient of rho1 soft
4231 : drho_s(1, ia, ir, ispin) = drho_s(1, ia, ir, ispin) + &
4232 : dr_s(ispin)%r_coef(ir, iso)* &
4233 : harmonics%a(1, ia)*harmonics%slm(ia, iso) + &
4234 : r_s_d(1, ispin)%r_coef(ir, iso)* &
4235 1448472520 : harmonics%slm(ia, iso)
4236 :
4237 : drho_s(2, ia, ir, ispin) = drho_s(2, ia, ir, ispin) + &
4238 : dr_s(ispin)%r_coef(ir, iso)* &
4239 : harmonics%a(2, ia)*harmonics%slm(ia, iso) + &
4240 : r_s_d(2, ispin)%r_coef(ir, iso)* &
4241 1448472520 : harmonics%slm(ia, iso)
4242 :
4243 : drho_s(3, ia, ir, ispin) = drho_s(3, ia, ir, ispin) + &
4244 : dr_s(ispin)%r_coef(ir, iso)* &
4245 : harmonics%a(3, ia)*harmonics%slm(ia, iso) + &
4246 : r_s_d(3, ispin)%r_coef(ir, iso)* &
4247 1477411140 : harmonics%slm(ia, iso)
4248 :
4249 : END DO ! ia
4250 : END DO ! iso
4251 110834850 : DO ia = 1, na
4252 : drho_h(4, ia, ir, ispin) = SQRT( &
4253 : drho_h(1, ia, ir, ispin)*drho_h(1, ia, ir, ispin) + &
4254 : drho_h(2, ia, ir, ispin)*drho_h(2, ia, ir, ispin) + &
4255 106777480 : drho_h(3, ia, ir, ispin)*drho_h(3, ia, ir, ispin))
4256 :
4257 : drho_s(4, ia, ir, ispin) = SQRT( &
4258 : drho_s(1, ia, ir, ispin)*drho_s(1, ia, ir, ispin) + &
4259 : drho_s(2, ia, ir, ispin)*drho_s(2, ia, ir, ispin) + &
4260 108911460 : drho_s(3, ia, ir, ispin)*drho_s(3, ia, ir, ispin))
4261 : END DO ! ia
4262 : END DO ! ispin
4263 : END IF
4264 :
4265 3019240 : END SUBROUTINE calc_rho_angular
4266 :
4267 : ! **************************************************************************************************
4268 : !> \brief Precompute radial and angular factors for GAPW meta-GGA tau contractions
4269 : !> \param tau_cache precomputed compact one-center gradient basis
4270 : !> \param grid_atom atom-centered integration grid
4271 : !> \param basis_1c GAPW one-center basis
4272 : !> \param harmonics spherical harmonics on the atom-centered grid
4273 : ! **************************************************************************************************
4274 1332 : SUBROUTINE create_tau_basis_cache(tau_cache, grid_atom, basis_1c, harmonics)
4275 :
4276 : TYPE(tau_basis_cache_type), INTENT(INOUT) :: tau_cache
4277 : TYPE(grid_atom_type), POINTER :: grid_atom
4278 : TYPE(gto_basis_set_type), POINTER :: basis_1c
4279 : TYPE(harmonics_atom_type), POINTER :: harmonics
4280 :
4281 : INTEGER :: dir, ia, igrid, ip, ipgf, ir, iset, iso, &
4282 : l, starti
4283 1332 : REAL(dp), ALLOCATABLE, DIMENSION(:) :: a1, a2, gexp, r1, r2
4284 1332 : REAL(dp), DIMENSION(:, :), POINTER :: slm
4285 1332 : REAL(dp), DIMENSION(:, :, :), POINTER :: dslm_dxyz
4286 :
4287 1332 : NULLIFY (slm, dslm_dxyz)
4288 :
4289 1332 : CALL release_tau_basis_cache(tau_cache)
4290 :
4291 : CALL get_gto_basis_set(gto_basis_set=basis_1c, lmax=tau_cache%lmax, &
4292 : lmin=tau_cache%lmin, maxso=tau_cache%maxso, &
4293 : npgf=tau_cache%npgf, nset=tau_cache%nset, &
4294 1332 : zet=tau_cache%zet)
4295 : CALL get_paw_basis_info(basis_1c, o2nindex=tau_cache%o2nindex, &
4296 : n2oindex=tau_cache%n2oindex, &
4297 1332 : nsatbas=tau_cache%nsatbas)
4298 :
4299 1332 : tau_cache%nr = grid_atom%nr
4300 1332 : tau_cache%na = grid_atom%ng_sphere
4301 1332 : slm => harmonics%slm
4302 1332 : dslm_dxyz => harmonics%dslm_dxyz
4303 :
4304 6660 : ALLOCATE (tau_cache%grad(tau_cache%na*tau_cache%nr, tau_cache%nsatbas, 3))
4305 : ALLOCATE (a1(tau_cache%na), a2(tau_cache%na), gexp(tau_cache%nr), &
4306 10656 : r1(tau_cache%nr), r2(tau_cache%nr))
4307 291013758 : tau_cache%grad = 0.0_dp
4308 :
4309 5430 : DO iset = 1, tau_cache%nset
4310 17822 : DO ipgf = 1, tau_cache%npgf(iset)
4311 : starti = (iset - 1)*tau_cache%maxso + &
4312 12392 : (ipgf - 1)*nsoset(tau_cache%lmax(iset))
4313 : gexp(1:tau_cache%nr) = EXP(-tau_cache%zet(ipgf, iset)* &
4314 644992 : grid_atom%rad2(1:tau_cache%nr))
4315 53500 : DO iso = nsoset(tau_cache%lmin(iset) - 1) + 1, nsoset(tau_cache%lmax(iset))
4316 37010 : ip = tau_cache%o2nindex(starti + iso)
4317 37010 : IF (ip == 0) CYCLE
4318 37010 : l = indso(1, iso)
4319 :
4320 1923910 : r1(1:tau_cache%nr) = grid_atom%rad(1:tau_cache%nr)**(l - 1)*gexp(1:tau_cache%nr)
4321 : r2(1:tau_cache%nr) = -2.0_dp*tau_cache%zet(ipgf, iset)* &
4322 1923910 : grid_atom%rad2(1:tau_cache%nr)*r1(1:tau_cache%nr)
4323 :
4324 160432 : DO dir = 1, 3
4325 5741154 : a1(1:tau_cache%na) = dslm_dxyz(dir, 1:tau_cache%na, iso)
4326 5741154 : a2(1:tau_cache%na) = harmonics%a(dir, 1:tau_cache%na)*slm(1:tau_cache%na, iso)
4327 5808740 : DO ir = 1, tau_cache%nr
4328 296669130 : DO ia = 1, tau_cache%na
4329 290897400 : igrid = ia + (ir - 1)*tau_cache%na
4330 296558100 : tau_cache%grad(igrid, ip, dir) = r1(ir)*a1(ia) + r2(ir)*a2(ia)
4331 : END DO
4332 : END DO
4333 : END DO
4334 : END DO
4335 : END DO
4336 : END DO
4337 :
4338 1332 : DEALLOCATE (a1, a2, gexp, r1, r2)
4339 :
4340 1332 : END SUBROUTINE create_tau_basis_cache
4341 :
4342 : ! **************************************************************************************************
4343 : !> \brief Release precomputed GAPW meta-GGA tau factors
4344 : !> \param tau_cache precomputed compact one-center gradient basis
4345 : ! **************************************************************************************************
4346 2664 : SUBROUTINE release_tau_basis_cache(tau_cache)
4347 :
4348 : TYPE(tau_basis_cache_type), INTENT(INOUT) :: tau_cache
4349 :
4350 2664 : IF (ALLOCATED(tau_cache%grad)) DEALLOCATE (tau_cache%grad)
4351 2664 : IF (ASSOCIATED(tau_cache%n2oindex)) DEALLOCATE (tau_cache%n2oindex)
4352 2664 : IF (ASSOCIATED(tau_cache%o2nindex)) DEALLOCATE (tau_cache%o2nindex)
4353 2664 : NULLIFY (tau_cache%lmax, tau_cache%lmin, tau_cache%n2oindex, tau_cache%npgf, &
4354 2664 : tau_cache%zet, tau_cache%o2nindex)
4355 2664 : tau_cache%maxso = 0
4356 2664 : tau_cache%na = 0
4357 2664 : tau_cache%nr = 0
4358 2664 : tau_cache%nsatbas = 0
4359 2664 : tau_cache%nset = 0
4360 :
4361 2664 : END SUBROUTINE release_tau_basis_cache
4362 :
4363 : ! **************************************************************************************************
4364 : !> \brief Computes tau hard and soft on the atomic grids for meta-GGA calculations
4365 : !> \param tau_h the hard part of tau
4366 : !> \param tau_s the soft part of tau
4367 : !> \param rho_atom atom-centered density matrices
4368 : !> \param tau_cache precomputed compact one-center gradient basis
4369 : !> \param nspins number of spin channels
4370 : !> \note This is a rewrite to correct a meta-GGA GAPW bug. This is more brute force than the original,
4371 : !> which was done along in qs_rho_atom_methods.F, but makes sure that no corner is cut in
4372 : !> terms of accuracy (A. Bussy)
4373 : ! **************************************************************************************************
4374 979 : SUBROUTINE calc_tau_atom(tau_h, tau_s, rho_atom, tau_cache, nspins)
4375 :
4376 : REAL(dp), DIMENSION(:, :, :), INTENT(INOUT) :: tau_h, tau_s
4377 : TYPE(rho_atom_type), POINTER :: rho_atom
4378 : TYPE(tau_basis_cache_type), INTENT(IN) :: tau_cache
4379 : INTEGER, INTENT(IN) :: nspins
4380 :
4381 : CHARACTER(len=*), PARAMETER :: routineN = 'calc_tau_atom'
4382 :
4383 : INTEGER :: dir, handle, ia, ibas, igrid, ir, ispin, &
4384 : na, nbas, ngrid, nr
4385 979 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: work
4386 :
4387 979 : CALL timeset(routineN, handle)
4388 :
4389 979 : CPASSERT(ALLOCATED(tau_cache%grad))
4390 :
4391 : !zeroing tau, assuming it is already allocated
4392 2678716 : tau_h = 0.0_dp
4393 2678716 : tau_s = 0.0_dp
4394 :
4395 979 : nr = tau_cache%nr
4396 979 : na = tau_cache%na
4397 979 : nbas = tau_cache%nsatbas
4398 979 : ngrid = na*nr
4399 3916 : ALLOCATE (work(ngrid, nbas))
4400 :
4401 1966 : DO ispin = 1, nspins
4402 4927 : DO dir = 1, 3
4403 : CALL dgemm('N', 'T', ngrid, nbas, nbas, 0.5_dp, tau_cache%grad(:, :, dir), &
4404 2961 : ngrid, rho_atom%cpc_h(ispin)%r_coef, nbas, 0.0_dp, work, ngrid)
4405 76200 : DO ibas = 1, nbas
4406 3792750 : DO ir = 1, nr
4407 193548489 : DO ia = 1, na
4408 189758700 : igrid = ia + (ir - 1)*na
4409 : tau_h(ia, ir, ispin) = tau_h(ia, ir, ispin) + &
4410 193475250 : tau_cache%grad(igrid, ibas, dir)*work(igrid, ibas)
4411 : END DO
4412 : END DO
4413 : END DO
4414 :
4415 : CALL dgemm('N', 'T', ngrid, nbas, nbas, 0.5_dp, tau_cache%grad(:, :, dir), &
4416 2961 : ngrid, rho_atom%cpc_s(ispin)%r_coef, nbas, 0.0_dp, work, ngrid)
4417 77187 : DO ibas = 1, nbas
4418 3792750 : DO ir = 1, nr
4419 193548489 : DO ia = 1, na
4420 189758700 : igrid = ia + (ir - 1)*na
4421 : tau_s(ia, ir, ispin) = tau_s(ia, ir, ispin) + &
4422 193475250 : tau_cache%grad(igrid, ibas, dir)*work(igrid, ibas)
4423 : END DO
4424 : END DO
4425 : END DO
4426 : END DO
4427 : END DO
4428 :
4429 979 : DEALLOCATE (work)
4430 :
4431 979 : CALL timestop(handle)
4432 :
4433 979 : END SUBROUTINE calc_tau_atom
4434 :
4435 : ! **************************************************************************************************
4436 : !> \brief ...
4437 : !> \param grid_atom ...
4438 : !> \param nspins ...
4439 : !> \param grad_func ...
4440 : !> \param ir ...
4441 : !> \param rho_nlcc ...
4442 : !> \param rho_h ...
4443 : !> \param rho_s ...
4444 : !> \param drho_nlcc ...
4445 : !> \param drho_h ...
4446 : !> \param drho_s ...
4447 : ! **************************************************************************************************
4448 8700 : SUBROUTINE calc_rho_nlcc(grid_atom, nspins, grad_func, &
4449 8700 : ir, rho_nlcc, rho_h, rho_s, drho_nlcc, drho_h, drho_s)
4450 :
4451 : TYPE(grid_atom_type), POINTER :: grid_atom
4452 : INTEGER, INTENT(IN) :: nspins
4453 : LOGICAL, INTENT(IN) :: grad_func
4454 : INTEGER, INTENT(IN) :: ir
4455 : REAL(KIND=dp), DIMENSION(:) :: rho_nlcc
4456 : REAL(KIND=dp), DIMENSION(:, :, :), POINTER :: rho_h, rho_s
4457 : REAL(KIND=dp), DIMENSION(:) :: drho_nlcc
4458 : REAL(KIND=dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s
4459 :
4460 : INTEGER :: ia, ispin, na
4461 : REAL(KIND=dp) :: drho, dx, dy, dz, rad, rho, urad, xsp
4462 :
4463 8700 : CPASSERT(ASSOCIATED(rho_h))
4464 8700 : CPASSERT(ASSOCIATED(rho_s))
4465 8700 : IF (grad_func) THEN
4466 8700 : CPASSERT(ASSOCIATED(drho_h))
4467 8700 : CPASSERT(ASSOCIATED(drho_s))
4468 : END IF
4469 :
4470 8700 : na = grid_atom%ng_sphere
4471 8700 : rad = grid_atom%rad(ir)
4472 8700 : urad = grid_atom%oorad2l(ir, 1)
4473 :
4474 8700 : xsp = REAL(nspins, KIND=dp)
4475 8700 : rho = rho_nlcc(ir)/xsp
4476 17400 : DO ispin = 1, nspins
4477 443700 : rho_h(1:na, ir, ispin) = rho_h(1:na, ir, ispin) + rho
4478 452400 : rho_s(1:na, ir, ispin) = rho_s(1:na, ir, ispin) + rho
4479 : END DO ! ispin
4480 :
4481 8700 : IF (grad_func) THEN
4482 8700 : drho = drho_nlcc(ir)/xsp
4483 17400 : DO ispin = 1, nspins
4484 452400 : DO ia = 1, na
4485 435000 : IF (grid_atom%azi(ia) == 0.0_dp) THEN
4486 : dx = 0.0_dp
4487 : dy = 0.0_dp
4488 : ELSE
4489 391500 : dx = grid_atom%sin_pol(ia)*grid_atom%sin_azi(ia)
4490 391500 : dy = grid_atom%sin_pol(ia)*grid_atom%cos_azi(ia)
4491 : END IF
4492 435000 : dz = grid_atom%cos_pol(ia)
4493 : ! components of the gradient of rho1 hard
4494 435000 : drho_h(1, ia, ir, ispin) = drho_h(1, ia, ir, ispin) + drho*dx
4495 435000 : drho_h(2, ia, ir, ispin) = drho_h(2, ia, ir, ispin) + drho*dy
4496 435000 : drho_h(3, ia, ir, ispin) = drho_h(3, ia, ir, ispin) + drho*dz
4497 : ! components of the gradient of rho1 soft
4498 435000 : drho_s(1, ia, ir, ispin) = drho_s(1, ia, ir, ispin) + drho*dx
4499 435000 : drho_s(2, ia, ir, ispin) = drho_s(2, ia, ir, ispin) + drho*dy
4500 435000 : drho_s(3, ia, ir, ispin) = drho_s(3, ia, ir, ispin) + drho*dz
4501 : ! norm of gradient
4502 : drho_h(4, ia, ir, ispin) = SQRT( &
4503 : drho_h(1, ia, ir, ispin)*drho_h(1, ia, ir, ispin) + &
4504 : drho_h(2, ia, ir, ispin)*drho_h(2, ia, ir, ispin) + &
4505 435000 : drho_h(3, ia, ir, ispin)*drho_h(3, ia, ir, ispin))
4506 :
4507 : drho_s(4, ia, ir, ispin) = SQRT( &
4508 : drho_s(1, ia, ir, ispin)*drho_s(1, ia, ir, ispin) + &
4509 : drho_s(2, ia, ir, ispin)*drho_s(2, ia, ir, ispin) + &
4510 443700 : drho_s(3, ia, ir, ispin)*drho_s(3, ia, ir, ispin))
4511 : END DO ! ia
4512 : END DO ! ispin
4513 : END IF
4514 :
4515 8700 : END SUBROUTINE calc_rho_nlcc
4516 :
4517 : ! **************************************************************************************************
4518 : !> \brief ...
4519 : !> \param vxc_h ...
4520 : !> \param vxc_s ...
4521 : !> \param int_hh ...
4522 : !> \param int_ss ...
4523 : !> \param grid_atom ...
4524 : !> \param basis_1c ...
4525 : !> \param harmonics ...
4526 : !> \param nspins ...
4527 : ! **************************************************************************************************
4528 16436 : SUBROUTINE gaVxcgb_noGC(vxc_h, vxc_s, int_hh, int_ss, grid_atom, basis_1c, harmonics, nspins)
4529 :
4530 : REAL(dp), DIMENSION(:, :, :), POINTER :: vxc_h, vxc_s
4531 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: int_hh, int_ss
4532 : TYPE(grid_atom_type), POINTER :: grid_atom
4533 : TYPE(gto_basis_set_type), POINTER :: basis_1c
4534 : TYPE(harmonics_atom_type), POINTER :: harmonics
4535 : INTEGER, INTENT(IN) :: nspins
4536 :
4537 : CHARACTER(len=*), PARAMETER :: routineN = 'gaVxcgb_noGC'
4538 :
4539 : INTEGER :: handle, ia, ic, icg, ipgf1, ipgf2, ir, iset1, iset2, iso, iso1, iso2, ispin, l, &
4540 : ld, lmax12, lmax_expansion, lmin12, m1, m2, max_iso_not0, max_iso_not0_local, max_s_harm, &
4541 : maxl, maxso, n1, n2, na, ngau1, ngau2, nngau1, nr, nset, size1
4542 : INTEGER, ALLOCATABLE, DIMENSION(:) :: cg_n_list
4543 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: cg_list
4544 16436 : INTEGER, DIMENSION(:), POINTER :: lmax, lmin, npgf
4545 16436 : REAL(dp), ALLOCATABLE, DIMENSION(:) :: g1, g2
4546 16436 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: gg, gVg_h, gVg_s, matso_h, matso_s, vx
4547 16436 : REAL(dp), DIMENSION(:, :), POINTER :: zet
4548 : REAL(dp), DIMENSION(:, :, :), POINTER :: my_CG
4549 :
4550 16436 : CALL timeset(routineN, handle)
4551 :
4552 16436 : NULLIFY (lmin, lmax, npgf, zet, my_CG)
4553 :
4554 : CALL get_gto_basis_set(gto_basis_set=basis_1c, lmax=lmax, lmin=lmin, &
4555 : maxso=maxso, maxl=maxl, npgf=npgf, &
4556 16436 : nset=nset, zet=zet)
4557 :
4558 16436 : nr = grid_atom%nr
4559 16436 : na = grid_atom%ng_sphere
4560 16436 : my_CG => harmonics%my_CG
4561 16436 : max_iso_not0 = harmonics%max_iso_not0
4562 16436 : lmax_expansion = indso(1, max_iso_not0)
4563 16436 : max_s_harm = harmonics%max_s_harm
4564 :
4565 115052 : ALLOCATE (g1(nr), g2(nr), gg(nr, 0:2*maxl))
4566 98616 : ALLOCATE (gVg_h(na, 0:2*maxl), gVg_s(na, 0:2*maxl))
4567 : ALLOCATE (matso_h(nsoset(maxl), nsoset(maxl)), &
4568 98616 : matso_s(nsoset(maxl), nsoset(maxl)))
4569 65744 : ALLOCATE (vx(na, nr))
4570 98616 : ALLOCATE (cg_list(2, nsoset(maxl)**2, max_s_harm), cg_n_list(max_s_harm))
4571 :
4572 16436 : g1 = 0.0_dp
4573 16436 : g2 = 0.0_dp
4574 16436 : m1 = 0
4575 55936 : DO iset1 = 1, nset
4576 39500 : n1 = nsoset(lmax(iset1))
4577 39500 : m2 = 0
4578 163574 : DO iset2 = 1, nset
4579 : CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
4580 124074 : max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local)
4581 124074 : CPASSERT(max_iso_not0_local <= max_iso_not0)
4582 :
4583 124074 : n2 = nsoset(lmax(iset2))
4584 454473 : DO ipgf1 = 1, npgf(iset1)
4585 330399 : ngau1 = n1*(ipgf1 - 1) + m1
4586 330399 : size1 = nsoset(lmax(iset1)) - nsoset(lmin(iset1) - 1)
4587 330399 : nngau1 = nsoset(lmin(iset1) - 1) + ngau1
4588 :
4589 18974349 : g1(1:nr) = EXP(-zet(ipgf1, iset1)*grid_atom%rad2(1:nr))
4590 1532742 : DO ipgf2 = 1, npgf(iset2)
4591 1078269 : ngau2 = n2*(ipgf2 - 1) + m2
4592 :
4593 61482419 : g2(1:nr) = EXP(-zet(ipgf2, iset2)*grid_atom%rad2(1:nr))
4594 1078269 : lmin12 = lmin(iset1) + lmin(iset2)
4595 1078269 : lmax12 = lmax(iset1) + lmax(iset2)
4596 :
4597 : ! reduce expansion local densities
4598 1408668 : IF (lmin12 <= lmax_expansion) THEN
4599 :
4600 1077324 : gg = 0.0_dp
4601 1077324 : IF (lmin12 == 0) THEN
4602 34361520 : gg(1:nr, lmin12) = g1(1:nr)*g2(1:nr)
4603 : ELSE
4604 27072704 : gg(1:nr, lmin12) = grid_atom%rad2l(1:nr, lmin12)*g1(1:nr)*g2(1:nr)
4605 : END IF
4606 :
4607 : ! limit the expansion of the local densities to a max L
4608 1077324 : IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion
4609 :
4610 1571084 : DO l = lmin12 + 1, lmax12
4611 30759884 : gg(1:nr, l) = grid_atom%rad(1:nr)*gg(:, l - 1)
4612 : END DO
4613 :
4614 2331201 : DO ispin = 1, nspins
4615 1253877 : ld = lmax12 + 1
4616 75450727 : DO ir = 1, nr
4617 3785293227 : vx(1:na, ir) = vxc_h(1:na, ir, ispin)
4618 : END DO
4619 : CALL dgemm('N', 'N', na, ld, nr, 1.0_dp, vx(1:na, 1:nr), na, &
4620 1253877 : gg(1:nr, 0:lmax12), nr, 0.0_dp, gVg_h(1:na, 0:lmax12), na)
4621 75450727 : DO ir = 1, nr
4622 3785293227 : vx(1:na, ir) = vxc_s(1:na, ir, ispin)
4623 : END DO
4624 : CALL dgemm('N', 'N', na, ld, nr, 1.0_dp, vx(1:na, 1:nr), na, &
4625 1253877 : gg(1:nr, 0:lmax12), nr, 0.0_dp, gVg_s(1:na, 0:lmax12), na)
4626 :
4627 1253877 : matso_h = 0.0_dp
4628 1253877 : matso_s = 0.0_dp
4629 9755902 : DO iso = 1, max_iso_not0_local
4630 26785106 : DO icg = 1, cg_n_list(iso)
4631 17029204 : iso1 = cg_list(1, icg, iso)
4632 17029204 : iso2 = cg_list(2, icg, iso)
4633 17029204 : l = indso(1, iso1) + indso(1, iso2)
4634 :
4635 17029204 : CPASSERT(l <= lmax_expansion)
4636 876991429 : DO ia = 1, na
4637 : matso_h(iso1, iso2) = matso_h(iso1, iso2) + &
4638 : gVg_h(ia, l)* &
4639 : my_CG(iso1, iso2, iso)* &
4640 851460200 : harmonics%slm(ia, iso)
4641 : matso_s(iso1, iso2) = matso_s(iso1, iso2) + &
4642 : gVg_s(ia, l)* &
4643 : my_CG(iso1, iso2, iso)* &
4644 868489404 : harmonics%slm(ia, iso)
4645 : END DO
4646 : END DO
4647 : END DO
4648 :
4649 : ! Write in the global matrix
4650 5596448 : DO ic = nsoset(lmin(iset2) - 1) + 1, nsoset(lmax(iset2))
4651 3265247 : iso1 = nsoset(lmin(iset1) - 1) + 1
4652 3265247 : iso2 = ngau2 + ic
4653 : CALL daxpy(size1, 1.0_dp, matso_h(iso1, ic), 1, &
4654 3265247 : int_hh(ispin)%r_coef(nngau1 + 1, iso2), 1)
4655 : CALL daxpy(size1, 1.0_dp, matso_s(iso1, ic), 1, &
4656 4519124 : int_ss(ispin)%r_coef(nngau1 + 1, iso2), 1)
4657 : END DO
4658 :
4659 : END DO ! ispin
4660 :
4661 : END IF ! lmax_expansion
4662 :
4663 : END DO ! ipfg2
4664 : END DO ! ipfg1
4665 287648 : m2 = m2 + maxso
4666 : END DO ! iset2
4667 55936 : m1 = m1 + maxso
4668 : END DO ! iset1
4669 :
4670 16436 : DEALLOCATE (g1, g2, gg, matso_h, matso_s, gVg_s, gVg_h, vx)
4671 :
4672 16436 : DEALLOCATE (cg_list, cg_n_list)
4673 :
4674 16436 : CALL timestop(handle)
4675 :
4676 16436 : END SUBROUTINE gaVxcgb_noGC
4677 :
4678 : ! **************************************************************************************************
4679 : !> \brief ...
4680 : !> \param vxc_h ...
4681 : !> \param vxc_s ...
4682 : !> \param vxg_h ...
4683 : !> \param vxg_s ...
4684 : !> \param int_hh ...
4685 : !> \param int_ss ...
4686 : !> \param grid_atom ...
4687 : !> \param basis_1c ...
4688 : !> \param harmonics ...
4689 : !> \param nspins ...
4690 : ! **************************************************************************************************
4691 30820 : SUBROUTINE gaVxcgb_GC(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
4692 : grid_atom, basis_1c, harmonics, nspins)
4693 :
4694 : REAL(dp), DIMENSION(:, :, :), POINTER :: vxc_h, vxc_s
4695 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: vxg_h, vxg_s
4696 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: int_hh, int_ss
4697 : TYPE(grid_atom_type), POINTER :: grid_atom
4698 : TYPE(gto_basis_set_type), POINTER :: basis_1c
4699 : TYPE(harmonics_atom_type), POINTER :: harmonics
4700 : INTEGER, INTENT(IN) :: nspins
4701 :
4702 : CHARACTER(len=*), PARAMETER :: routineN = 'gaVxcgb_GC'
4703 :
4704 : INTEGER :: dmax_iso_not0_local, handle, ia, ic, icg, ipgf1, ipgf2, ir, iset1, iset2, iso, &
4705 : iso1, iso2, ispin, l, lmax12, lmax_expansion, lmin12, m1, m2, max_iso_not0, &
4706 : max_iso_not0_local, max_s_harm, maxl, maxso, n1, n2, na, ngau1, ngau2, nngau1, nr, nset, &
4707 : size1
4708 : INTEGER, ALLOCATABLE, DIMENSION(:) :: cg_n_list, dcg_n_list
4709 : INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: cg_list, dcg_list
4710 30820 : INTEGER, DIMENSION(:), POINTER :: lmax, lmin, npgf
4711 : REAL(dp) :: urad
4712 30820 : REAL(dp), ALLOCATABLE, DIMENSION(:) :: g1, g2
4713 30820 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: dgg, gg, gVXCg_h, gVXCg_s, matso_h, &
4714 30820 : matso_s
4715 30820 : REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: gVXGg_h, gVXGg_s
4716 30820 : REAL(dp), DIMENSION(:, :), POINTER :: zet
4717 : REAL(dp), DIMENSION(:, :, :), POINTER :: my_CG
4718 : REAL(dp), DIMENSION(:, :, :, :), POINTER :: my_CG_dxyz
4719 :
4720 30820 : CALL timeset(routineN, handle)
4721 :
4722 30820 : NULLIFY (lmin, lmax, npgf, zet, my_CG, my_CG_dxyz)
4723 :
4724 : CALL get_gto_basis_set(gto_basis_set=basis_1c, lmax=lmax, lmin=lmin, &
4725 : maxso=maxso, maxl=maxl, npgf=npgf, &
4726 30820 : nset=nset, zet=zet)
4727 :
4728 30820 : nr = grid_atom%nr
4729 30820 : na = grid_atom%ng_sphere
4730 30820 : my_CG => harmonics%my_CG
4731 30820 : my_CG_dxyz => harmonics%my_CG_dxyz
4732 30820 : max_iso_not0 = harmonics%max_iso_not0
4733 30820 : lmax_expansion = indso(1, max_iso_not0)
4734 30820 : max_s_harm = harmonics%max_s_harm
4735 :
4736 277380 : ALLOCATE (g1(nr), g2(nr), gg(nr, 0:2*maxl), dgg(nr, 0:2*maxl))
4737 184920 : ALLOCATE (gVXCg_h(na, 0:2*maxl), gVXCg_s(na, 0:2*maxl))
4738 184920 : ALLOCATE (gVXGg_h(3, na, 0:2*maxl), gVXGg_s(3, na, 0:2*maxl))
4739 : ALLOCATE (cg_list(2, nsoset(maxl)**2, max_s_harm), cg_n_list(max_s_harm), &
4740 277380 : dcg_list(2, nsoset(maxl)**2, max_s_harm), dcg_n_list(max_s_harm))
4741 :
4742 : ALLOCATE (matso_h(nsoset(maxl), nsoset(maxl)), &
4743 184920 : matso_s(nsoset(maxl), nsoset(maxl)))
4744 :
4745 64953 : DO ispin = 1, nspins
4746 :
4747 34133 : g1 = 0.0_dp
4748 34133 : g2 = 0.0_dp
4749 34133 : m1 = 0
4750 151639 : DO iset1 = 1, nset
4751 86686 : n1 = nsoset(lmax(iset1))
4752 86686 : m2 = 0
4753 383074 : DO iset2 = 1, nset
4754 : CALL get_none0_cg_list(my_CG, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
4755 296388 : max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local)
4756 296388 : CPASSERT(max_iso_not0_local <= max_iso_not0)
4757 : CALL get_none0_cg_list(my_CG_dxyz, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
4758 296388 : max_s_harm, lmax_expansion, dcg_list, dcg_n_list, dmax_iso_not0_local)
4759 :
4760 296388 : n2 = nsoset(lmax(iset2))
4761 956987 : DO ipgf1 = 1, npgf(iset1)
4762 660599 : ngau1 = n1*(ipgf1 - 1) + m1
4763 660599 : size1 = nsoset(lmax(iset1)) - nsoset(lmin(iset1) - 1)
4764 660599 : nngau1 = nsoset(lmin(iset1) - 1) + ngau1
4765 :
4766 34402829 : g1(1:nr) = EXP(-zet(ipgf1, iset1)*grid_atom%rad2(1:nr))
4767 2615934 : DO ipgf2 = 1, npgf(iset2)
4768 1658947 : ngau2 = n2*(ipgf2 - 1) + m2
4769 :
4770 86608777 : g2(1:nr) = EXP(-zet(ipgf2, iset2)*grid_atom%rad2(1:nr))
4771 1658947 : lmin12 = lmin(iset1) + lmin(iset2)
4772 1658947 : lmax12 = lmax(iset1) + lmax(iset2)
4773 :
4774 : !test reduce expansion local densities
4775 1658947 : IF (lmin12 <= lmax_expansion) THEN
4776 :
4777 1658347 : gg = 0.0_dp
4778 1658347 : dgg = 0.0_dp
4779 :
4780 1658347 : IF (lmin12 == 0) THEN
4781 51877675 : gg(1:nr, lmin12) = g1(1:nr)*g2(1:nr)
4782 : ELSE
4783 34700502 : gg(1:nr, lmin12) = grid_atom%rad2l(1:nr, lmin12)*g1(1:nr)*g2(1:nr)
4784 : END IF
4785 :
4786 : !test reduce expansion local densities
4787 1658347 : IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion
4788 :
4789 2547073 : DO l = lmin12 + 1, lmax12
4790 46766226 : gg(1:nr, l) = grid_atom%rad(1:nr)*gg(:, l - 1)
4791 : dgg(1:nr, l - 1) = dgg(1:nr, l - 1) - 2.0_dp*(zet(ipgf1, iset1) + &
4792 48424573 : zet(ipgf2, iset2))*gg(1:nr, l)
4793 : END DO
4794 : dgg(1:nr, lmax12) = dgg(1:nr, lmax12) - 2.0_dp*(zet(ipgf1, iset1) + &
4795 : zet(ipgf2, iset2))*grid_atom%rad(1:nr)* &
4796 86578177 : gg(1:nr, lmax12)
4797 :
4798 1658347 : gVXCg_h = 0.0_dp
4799 1658347 : gVXCg_s = 0.0_dp
4800 1658347 : gVXGg_h = 0.0_dp
4801 1658347 : gVXGg_s = 0.0_dp
4802 :
4803 : ! Cross Term
4804 4205420 : DO l = lmin12, lmax12
4805 131510302 : DO ia = 1, na
4806 6673260855 : DO ir = 1, nr
4807 : gVXCg_h(ia, l) = gVXCg_h(ia, l) + &
4808 : gg(ir, l)*vxc_h(ia, ir, ispin) + &
4809 : dgg(ir, l)* &
4810 : (vxg_h(1, ia, ir, ispin)*harmonics%a(1, ia) + &
4811 : vxg_h(2, ia, ir, ispin)*harmonics%a(2, ia) + &
4812 6543408900 : vxg_h(3, ia, ir, ispin)*harmonics%a(3, ia))
4813 :
4814 : gVXCg_s(ia, l) = gVXCg_s(ia, l) + &
4815 : gg(ir, l)*vxc_s(ia, ir, ispin) + &
4816 : dgg(ir, l)* &
4817 : (vxg_s(1, ia, ir, ispin)*harmonics%a(1, ia) + &
4818 : vxg_s(2, ia, ir, ispin)*harmonics%a(2, ia) + &
4819 6543408900 : vxg_s(3, ia, ir, ispin)*harmonics%a(3, ia))
4820 :
4821 6543408900 : urad = grid_atom%oorad2l(ir, 1)
4822 :
4823 : gVXGg_h(1, ia, l) = gVXGg_h(1, ia, l) + &
4824 : vxg_h(1, ia, ir, ispin)* &
4825 6543408900 : gg(ir, l)*urad
4826 :
4827 : gVXGg_h(2, ia, l) = gVXGg_h(2, ia, l) + &
4828 : vxg_h(2, ia, ir, ispin)* &
4829 6543408900 : gg(ir, l)*urad
4830 :
4831 : gVXGg_h(3, ia, l) = gVXGg_h(3, ia, l) + &
4832 : vxg_h(3, ia, ir, ispin)* &
4833 6543408900 : gg(ir, l)*urad
4834 :
4835 : gVXGg_s(1, ia, l) = gVXGg_s(1, ia, l) + &
4836 : vxg_s(1, ia, ir, ispin)* &
4837 6543408900 : gg(ir, l)*urad
4838 :
4839 : gVXGg_s(2, ia, l) = gVXGg_s(2, ia, l) + &
4840 : vxg_s(2, ia, ir, ispin)* &
4841 6543408900 : gg(ir, l)*urad
4842 :
4843 : gVXGg_s(3, ia, l) = gVXGg_s(3, ia, l) + &
4844 : vxg_s(3, ia, ir, ispin)* &
4845 6670713782 : gg(ir, l)*urad
4846 :
4847 : END DO ! ir
4848 : END DO ! ia
4849 : END DO ! l
4850 :
4851 1658347 : matso_h = 0.0_dp
4852 1658347 : matso_s = 0.0_dp
4853 11991674 : DO iso = 1, max_iso_not0_local
4854 33967015 : DO icg = 1, cg_n_list(iso)
4855 21975341 : iso1 = cg_list(1, icg, iso)
4856 21975341 : iso2 = cg_list(2, icg, iso)
4857 :
4858 21975341 : l = indso(1, iso1) + indso(1, iso2)
4859 :
4860 : !test reduce expansion local densities
4861 21975341 : CPASSERT(l <= lmax_expansion)
4862 1130827378 : DO ia = 1, na
4863 : matso_h(iso1, iso2) = matso_h(iso1, iso2) + &
4864 : gVXCg_h(ia, l)* &
4865 : harmonics%slm(ia, iso)* &
4866 1098518710 : my_CG(iso1, iso2, iso)
4867 : matso_s(iso1, iso2) = matso_s(iso1, iso2) + &
4868 : gVXCg_s(ia, l)* &
4869 : harmonics%slm(ia, iso)* &
4870 1120494051 : my_CG(iso1, iso2, iso)
4871 : END DO ! ia
4872 :
4873 : !test reduce expansion local densities
4874 :
4875 : END DO
4876 :
4877 : END DO ! iso
4878 :
4879 6395507 : DO iso = 1, dmax_iso_not0_local
4880 42235433 : DO icg = 1, dcg_n_list(iso)
4881 35839926 : iso1 = dcg_list(1, icg, iso)
4882 35839926 : iso2 = dcg_list(2, icg, iso)
4883 :
4884 35839926 : l = indso(1, iso1) + indso(1, iso2)
4885 : !test reduce expansion local densities
4886 35839926 : CPASSERT(l <= lmax_expansion)
4887 1831834054 : DO ia = 1, na
4888 : matso_h(iso1, iso2) = matso_h(iso1, iso2) + &
4889 : (gVXGg_h(1, ia, l)*my_CG_dxyz(1, iso1, iso2, iso) + &
4890 : gVXGg_h(2, ia, l)*my_CG_dxyz(2, iso1, iso2, iso) + &
4891 : gVXGg_h(3, ia, l)*my_CG_dxyz(3, iso1, iso2, iso))* &
4892 1791256968 : harmonics%slm(ia, iso)
4893 :
4894 : matso_s(iso1, iso2) = matso_s(iso1, iso2) + &
4895 : (gVXGg_s(1, ia, l)*my_CG_dxyz(1, iso1, iso2, iso) + &
4896 : gVXGg_s(2, ia, l)*my_CG_dxyz(2, iso1, iso2, iso) + &
4897 : gVXGg_s(3, ia, l)*my_CG_dxyz(3, iso1, iso2, iso))* &
4898 1827096894 : harmonics%slm(ia, iso)
4899 :
4900 : END DO ! ia
4901 :
4902 : !test reduce expansion local densities
4903 :
4904 : END DO ! icg
4905 : END DO ! iso
4906 : !test reduce expansion local densities
4907 : END IF ! lmax_expansion
4908 :
4909 : ! Write in the global matrix
4910 6551864 : DO ic = nsoset(lmin(iset2) - 1) + 1, nsoset(lmax(iset2))
4911 4232318 : iso1 = nsoset(lmin(iset1) - 1) + 1
4912 4232318 : iso2 = ngau2 + ic
4913 : CALL daxpy(size1, 1.0_dp, matso_h(iso1, ic), 1, &
4914 4232318 : int_hh(ispin)%r_coef(nngau1 + 1, iso2), 1)
4915 : CALL daxpy(size1, 1.0_dp, matso_s(iso1, ic), 1, &
4916 5891265 : int_ss(ispin)%r_coef(nngau1 + 1, iso2), 1)
4917 : END DO
4918 :
4919 : END DO ! ipfg2
4920 : END DO ! ipfg1
4921 975850 : m2 = m2 + maxso
4922 : END DO ! iset2
4923 120819 : m1 = m1 + maxso
4924 : END DO ! iset1
4925 : END DO ! ispin
4926 :
4927 30820 : DEALLOCATE (g1, g2, gg, dgg, matso_h, matso_s, gVXCg_h, gVXCg_s, gVXGg_h, gVXGg_s)
4928 30820 : DEALLOCATE (cg_list, cg_n_list, dcg_list, dcg_n_list)
4929 :
4930 30820 : CALL timestop(handle)
4931 :
4932 30820 : END SUBROUTINE gaVxcgb_GC
4933 :
4934 : ! **************************************************************************************************
4935 : !> \brief Integrates 0.5 * grad_ga .dot. (V_tau * grad_gb) on the atomic grid for meta-GGA
4936 : !> \param vtau_h the hard tau potential
4937 : !> \param vtau_s the soft tau potential
4938 : !> \param int_hh hard one-center matrix contribution
4939 : !> \param int_ss soft one-center matrix contribution
4940 : !> \param tau_cache precomputed compact one-center gradient basis
4941 : !> \param nspins number of spin channels
4942 : !> \note This is a rewrite to correct meta-GGA GAPW bug. This is more brute force than the original
4943 : !> but makes sure that no corner is cut in terms of accuracy (A. Bussy)
4944 : ! **************************************************************************************************
4945 923 : SUBROUTINE dgaVtaudgb(vtau_h, vtau_s, int_hh, int_ss, &
4946 : tau_cache, nspins)
4947 :
4948 : REAL(dp), DIMENSION(:, :, :), POINTER :: vtau_h, vtau_s
4949 : TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: int_hh, int_ss
4950 : TYPE(tau_basis_cache_type), INTENT(IN) :: tau_cache
4951 : INTEGER, INTENT(IN) :: nspins
4952 :
4953 : CHARACTER(len=*), PARAMETER :: routineN = 'dgaVtaudgb'
4954 :
4955 : INTEGER :: dir, handle, ia, ibas, igrid, iold, ir, &
4956 : ispin, jbas, jold, max_old_basis, na, &
4957 : nbas, ngrid, nr
4958 923 : REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: int_h, int_s, weighted_grad
4959 :
4960 923 : CALL timeset(routineN, handle)
4961 :
4962 923 : CPASSERT(ALLOCATED(tau_cache%grad))
4963 923 : CPASSERT(ASSOCIATED(tau_cache%n2oindex))
4964 :
4965 923 : nr = tau_cache%nr
4966 923 : na = tau_cache%na
4967 923 : nbas = tau_cache%nsatbas
4968 923 : ngrid = na*nr
4969 67728 : max_old_basis = MAXVAL(tau_cache%n2oindex)
4970 8307 : ALLOCATE (int_h(nbas, nbas), int_s(nbas, nbas), weighted_grad(ngrid, nbas))
4971 :
4972 1854 : DO ispin = 1, nspins
4973 931 : CPASSERT(SIZE(int_hh(ispin)%r_coef, 1) >= max_old_basis)
4974 931 : CPASSERT(SIZE(int_hh(ispin)%r_coef, 2) >= max_old_basis)
4975 931 : CPASSERT(SIZE(int_ss(ispin)%r_coef, 1) >= max_old_basis)
4976 931 : CPASSERT(SIZE(int_ss(ispin)%r_coef, 2) >= max_old_basis)
4977 931 : int_h = 0.0_dp
4978 931 : int_s = 0.0_dp
4979 3724 : DO dir = 1, 3
4980 74556 : DO ibas = 1, nbas
4981 3717306 : DO ir = 1, nr
4982 189783213 : DO ia = 1, na
4983 186068700 : igrid = ia + (ir - 1)*na
4984 : weighted_grad(igrid, ibas) = vtau_h(ia, ir, ispin)* &
4985 189711450 : tau_cache%grad(igrid, ibas, dir)
4986 : END DO
4987 : END DO
4988 : END DO
4989 : CALL dgemm('T', 'N', nbas, nbas, ngrid, 0.5_dp, tau_cache%grad(:, :, dir), &
4990 2793 : ngrid, weighted_grad, ngrid, 1.0_dp, int_h, nbas)
4991 :
4992 74556 : DO ibas = 1, nbas
4993 3717306 : DO ir = 1, nr
4994 189783213 : DO ia = 1, na
4995 186068700 : igrid = ia + (ir - 1)*na
4996 : weighted_grad(igrid, ibas) = vtau_s(ia, ir, ispin)* &
4997 189711450 : tau_cache%grad(igrid, ibas, dir)
4998 : END DO
4999 : END DO
5000 : END DO
5001 : CALL dgemm('T', 'N', nbas, nbas, ngrid, 0.5_dp, tau_cache%grad(:, :, dir), &
5002 3724 : ngrid, weighted_grad, ngrid, 1.0_dp, int_s, nbas)
5003 : END DO
5004 :
5005 25775 : DO jbas = 1, nbas
5006 23921 : jold = tau_cache%n2oindex(jbas)
5007 959307 : DO ibas = 1, nbas
5008 934455 : iold = tau_cache%n2oindex(ibas)
5009 : int_hh(ispin)%r_coef(iold, jold) = int_hh(ispin)%r_coef(iold, jold) + &
5010 934455 : int_h(ibas, jbas)
5011 : int_ss(ispin)%r_coef(iold, jold) = int_ss(ispin)%r_coef(iold, jold) + &
5012 958376 : int_s(ibas, jbas)
5013 : END DO
5014 : END DO
5015 : END DO
5016 :
5017 923 : DEALLOCATE (int_h, int_s, weighted_grad)
5018 :
5019 923 : CALL timestop(handle)
5020 :
5021 923 : END SUBROUTINE dgaVtaudgb
5022 :
5023 0 : END MODULE qs_vxc_atom
|
