(git:fd7f302)
Loading...
Searching...
No Matches
qs_vxc_atom.F
Go to the documentation of this file.
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! **************************************************************************************************
12MODULE 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 USE cp_array_utils, ONLY: cp_3d_r_cp_type
19 USE cp_control_types, ONLY: dft_control_type
20 USE cp_log_handling, ONLY: cp_logger_get_default_io_unit
21 USE external_potential_types, ONLY: get_potential,&
22 gth_potential_type,&
23 sgp_potential_type
24 USE input_constants, ONLY: cdft_alpha_constraint,&
25 cdft_beta_constraint,&
26 cdft_charge_constraint,&
27 cdft_magnetization_constraint,&
28 xc_none
29 USE input_section_types, ONLY: section_get_rval,&
30 section_vals_get_subs_vals,&
31 section_vals_type,&
32 section_vals_val_get
33 USE kinds, ONLY: dp,&
34 int_8
35 USE lebedev, ONLY: deallocate_lebedev_grids,&
36 get_number_of_lebedev_grid,&
37 init_lebedev_grids,&
38 lebedev_grid
39 USE memory_utilities, ONLY: reallocate
40 USE message_passing, ONLY: mp_para_env_type
41 USE orbital_pointers, ONLY: indco,&
42 indso,&
43 nco,&
44 ncoset,&
45 nsoset
46 USE orbital_transformation_matrices, ONLY: orbtramat
47 USE particle_types, ONLY: particle_type
48 USE paw_basis_types, ONLY: get_paw_basis_info
49 USE pw_env_types, ONLY: pw_env_get,&
50 pw_env_type
51 USE pw_grid_types, ONLY: pw_grid_type
52 USE pw_methods, ONLY: pw_axpy
53 USE pw_pool_types, ONLY: pw_pool_type
54 USE pw_types, ONLY: pw_c1d_gs_type,&
55 pw_r3d_rs_type
56 USE qs_cdft_grid, ONLY: cdft_point_context_create,&
57 cdft_point_context_release,&
58 cdft_point_context_type,&
59 cdft_point_weights
60 USE qs_cdft_types, ONLY: cdft_control_type
61 USE qs_environment_types, ONLY: get_qs_env,&
62 qs_environment_type
63 USE qs_force_types, ONLY: qs_force_type
64 USE qs_grid_atom, ONLY: allocate_grid_atom,&
65 create_grid_atom,&
66 grid_atom_type
67 USE qs_harmonics_atom, ONLY: get_none0_cg_list,&
68 harmonics_atom_type
69 USE qs_kind_types, ONLY: get_qs_kind,&
70 has_nlcc,&
71 qs_kind_type
72 USE qs_linres_types, ONLY: nablavks_atom_type
73 USE qs_rho_atom_methods, ONLY: replicate_rho_atom_radial
74 USE qs_rho_atom_types, ONLY: get_rho_atom,&
75 rho_atom_coeff,&
76 rho_atom_type
77 USE qs_rho_types, ONLY: qs_rho_get,&
78 qs_rho_type
79 USE skala_gpw_features, ONLY: build_periodic_atom_image_layout,&
80 periodic_atom_image_partition,&
81 periodic_atom_image_partition_from_layout,&
82 skala_gpw_smooth_partition_derivatives,&
83 smooth_atom_partition,&
84 smooth_partition_atomic_weight_scale,&
85 smooth_partition_atomic_weight_scale_derivative
86 USE skala_gpw_functional, ONLY: &
87 build_vxc_from_feature_grads, get_gauxc_section, native_skala_gapw_density_partition, &
88 skala_gapw_atom_composite_energy, skala_gapw_atom_vxc_of_r, &
89 skala_gapw_density_partition_hard_minus_soft, skala_gapw_density_partition_hard_only, &
90 skala_gapw_density_partition_none, skala_gapw_density_partition_soft_only, &
91 xc_section_uses_gauxc_model, xc_section_uses_native_skala_evaluator
92 USE spherical_harmonics, ONLY: y_lm
93 USE util, ONLY: get_limit
94 USE virial_types, ONLY: virial_type
95 USE xc_atom, ONLY: fill_rho_set,&
96 vxc_of_r_epr,&
97 vxc_of_r_new,&
98 xc_2nd_deriv_of_r,&
99 xc_rho_set_atom_update
100 USE xc_derivative_set_types, ONLY: xc_derivative_set_type,&
101 xc_dset_create,&
102 xc_dset_release,&
103 xc_dset_zero_all
104 USE xc_derivatives, ONLY: xc_functionals_get_needs
105 USE xc_input_constants, ONLY: skala_gapw_cp2k_default,&
106 skala_gapw_direct_valence,&
107 skala_gapw_paw_one_center,&
108 skala_gapw_paw_one_center_split
109 USE xc_rho_cflags_types, ONLY: xc_rho_cflags_type
110 USE xc_rho_set_types, ONLY: xc_rho_set_create,&
111 xc_rho_set_get,&
112 xc_rho_set_release,&
113 xc_rho_set_type,&
114 xc_rho_set_update
115#include "./base/base_uses.f90"
116
117 IMPLICIT NONE
118
119 PRIVATE
120
121 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_vxc_atom'
122
123 ! The wider stencil suppresses mixed-kind eggbox forces while preserving an exact transpose.
124 INTEGER, PARAMETER, PRIVATE :: native_grid_interp_offset_min = -5, &
125 native_grid_interp_offset_max = 6, &
126 native_grid_interp_npts = &
127 native_grid_interp_offset_max - &
128 native_grid_interp_offset_min + 1
129 ! A wrapped stencil can touch both end tiles and one adjacent interior tile when the final
130 ! tile is shorter than the stencil. Three tiles per direction are therefore sufficient.
131 INTEGER, PARAMETER, PRIVATE :: native_grid_adjoint_tile_edge = 64, &
132 native_grid_adjoint_max_tiles_per_direction = 3, &
133 native_grid_adjoint_max_bins_per_row = &
134 native_grid_adjoint_max_tiles_per_direction**3
135
136 TYPE native_grid_interpolation_stencil_type
137 INTEGER, DIMENSION(native_grid_interp_npts, 3) :: relative_index = 0
138 REAL(KIND=dp), DIMENSION(native_grid_interp_npts, 3) :: weight = 0.0_dp
139 LOGICAL, DIMENSION(native_grid_interp_npts, 3) :: valid = .false.
140 LOGICAL :: active = .false.
141 END TYPE native_grid_interpolation_stencil_type
142
143 TYPE tau_basis_cache_type
144 INTEGER :: maxso = 0, na = 0, nr = 0, nsatbas = 0, &
145 nset = 0
146 INTEGER, DIMENSION(:), POINTER :: lmax => null(), lmin => null(), &
147 n2oindex => null(), npgf => null(), &
148 o2nindex => null()
149 REAL(dp), DIMENSION(:, :), POINTER :: zet => null()
150 REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: grad
151 END TYPE tau_basis_cache_type
152
153 PUBLIC :: calculate_vxc_atom, &
154 calculate_vxc_atom_epr, &
155 calculate_xc_2nd_deriv_atom, &
156 calc_rho_angular, &
157 calculate_gfxc_atom, &
158 gapw_cdft_one_center, &
159 gfxc_atom_diff, &
160 gavxcgb_nogc
161
162CONTAINS
163
164! **************************************************************************************************
165!> \brief Evaluate an NLCC density and its first two Cartesian derivatives.
166!> \param point evaluation point
167!> \param center pseudopotential center
168!> \param gth_potential optional GTH potential
169!> \param sgp_potential optional separable Gaussian potential
170!> \param rho core density
171!> \param gradient Cartesian density gradient
172!> \param hessian Cartesian density Hessian
173! **************************************************************************************************
174 SUBROUTINE evaluate_nlcc_primitive_fields(point, center, gth_potential, sgp_potential, &
175 rho, gradient, hessian)
176 REAL(dp), DIMENSION(3), INTENT(IN) :: point, center
177 TYPE(gth_potential_type), INTENT(IN), POINTER :: gth_potential
178 TYPE(sgp_potential_type), INTENT(IN), POINTER :: sgp_potential
179 REAL(dp), INTENT(OUT) :: rho
180 REAL(dp), DIMENSION(3), INTENT(OUT) :: gradient
181 REAL(dp), DIMENSION(3, 3), INTENT(OUT) :: hessian
182
183 INTEGER :: ic, idir, iexp, jdir, n_nlcc, nexp_nlcc, &
184 power
185 INTEGER, DIMENSION(:), POINTER :: nct_nlcc
186 LOGICAL :: has_sgp_nlcc, nlcc_present
187 REAL(dp) :: alpha, beta, d2poly, dpoly, exponential, &
188 poly, r2, rho_x, rho_xx, scaled_r2
189 REAL(dp), DIMENSION(3) :: displacement
190 REAL(dp), DIMENSION(:), POINTER :: a_nlcc, alpha_nlcc, c_nlcc
191 REAL(dp), DIMENSION(:, :), POINTER :: cval_nlcc
192
193 NULLIFY (a_nlcc, alpha_nlcc, c_nlcc, cval_nlcc, nct_nlcc)
194 rho = 0.0_dp
195 rho_x = 0.0_dp
196 rho_xx = 0.0_dp
197 displacement = point - center
198 r2 = dot_product(displacement, displacement)
199
200 IF (ASSOCIATED(gth_potential)) THEN
201 CALL get_potential(gth_potential, nlcc_present=nlcc_present, &
202 nexp_nlcc=nexp_nlcc, alpha_nlcc=alpha_nlcc, &
203 nct_nlcc=nct_nlcc, cval_nlcc=cval_nlcc)
204 IF (nlcc_present) THEN
205 DO iexp = 1, nexp_nlcc
206 alpha = alpha_nlcc(iexp)
207 beta = 0.5_dp/(alpha*alpha)
208 scaled_r2 = r2/(alpha*alpha)
209 exponential = exp(-0.5_dp*scaled_r2)
210 DO ic = 1, nct_nlcc(iexp)
211 power = ic - 1
212 poly = cval_nlcc(ic, iexp)*scaled_r2**power
213 dpoly = 0.0_dp
214 IF (power > 0) THEN
215 dpoly = cval_nlcc(ic, iexp)*real(power, dp)* &
216 scaled_r2**(power - 1)/(alpha*alpha)
217 END IF
218 d2poly = 0.0_dp
219 IF (power > 1) THEN
220 d2poly = cval_nlcc(ic, iexp)*real(power*(power - 1), dp)* &
221 scaled_r2**(power - 2)/(alpha**4)
222 END IF
223 rho = rho + exponential*poly
224 rho_x = rho_x + exponential*(dpoly - beta*poly)
225 rho_xx = rho_xx + exponential*(d2poly - 2.0_dp*beta*dpoly + beta*beta*poly)
226 END DO
227 END DO
228 END IF
229 ELSE IF (ASSOCIATED(sgp_potential)) THEN
230 CALL get_potential(sgp_potential, has_nlcc=has_sgp_nlcc, n_nlcc=n_nlcc, &
231 a_nlcc=a_nlcc, c_nlcc=c_nlcc)
232 IF (has_sgp_nlcc) THEN
233 DO iexp = 1, n_nlcc
234 exponential = exp(-a_nlcc(iexp)*r2)
235 rho = rho + c_nlcc(iexp)*exponential
236 rho_x = rho_x - a_nlcc(iexp)*c_nlcc(iexp)*exponential
237 rho_xx = rho_xx + a_nlcc(iexp)**2*c_nlcc(iexp)*exponential
238 END DO
239 END IF
240 END IF
241
242 gradient = 2.0_dp*rho_x*displacement
243 DO idir = 1, 3
244 DO jdir = 1, 3
245 hessian(idir, jdir) = 4.0_dp*rho_xx*displacement(idir)*displacement(jdir)
246 END DO
247 hessian(idir, idir) = hessian(idir, idir) + 2.0_dp*rho_x
248 END DO
249 END SUBROUTINE evaluate_nlcc_primitive_fields
250
251! **************************************************************************************************
252!> \brief Initialize atom-centered quadrature for native Skala layouts.
253!> \param kind_set quantum kinds
254!> \param dft_control DFT controls supplying the radial quadrature
255! **************************************************************************************************
256 SUBROUTINE ensure_native_skala_atom_grids(kind_set, dft_control)
257 TYPE(qs_kind_type), DIMENSION(:), POINTER :: kind_set
258 TYPE(dft_control_type), POINTER :: dft_control
259
260 INTEGER :: ikind, ll, na, nr, quadrature
261 TYPE(grid_atom_type), POINTER :: grid_atom
262
263 quadrature = dft_control%qs_control%gapw_control%quadrature
264 CALL init_lebedev_grids()
265 DO ikind = 1, SIZE(kind_set)
266 NULLIFY (grid_atom)
267 CALL get_qs_kind(kind_set(ikind), grid_atom=grid_atom, ngrid_ang=na, ngrid_rad=nr)
268 IF (ASSOCIATED(grid_atom)) THEN
269 IF (ASSOCIATED(grid_atom%weight) .AND. grid_atom%nr == nr) cycle
270 ELSE
271 CALL allocate_grid_atom(kind_set(ikind)%grid_atom)
272 grid_atom => kind_set(ikind)%grid_atom
273 END IF
274 ll = get_number_of_lebedev_grid(n=na)
275 na = lebedev_grid(ll)%n
276 grid_atom%ng_sphere = na
277 grid_atom%nr = nr
278 CALL create_grid_atom(grid_atom, nr, na, 0, ll, quadrature)
279 END DO
280 CALL deallocate_lebedev_grids()
281
282 END SUBROUTINE ensure_native_skala_atom_grids
283
284! **************************************************************************************************
285!> \brief Decide whether a kind contributes hard-minus-soft primitive fields.
286!> \param paw_atom whether CP2K constructed a one-center representation for the kind
287!> \param gapw_representation requested Skala pseudopotential GAPW representation
288!> \param has_pseudopotential whether the kind uses a GTH or semi-global pseudopotential
289!> \param zeff valence charge of the potential
290!> \param zatom atomic number
291!> \return true when hard-minus-soft fields contribute for this kind
292! **************************************************************************************************
293 PURE FUNCTION native_skala_uses_one_center_kind( &
294 paw_atom, gapw_representation, has_pseudopotential, zeff, zatom) RESULT(use_one_center)
295 LOGICAL, INTENT(IN) :: paw_atom
296 INTEGER, INTENT(IN) :: gapw_representation
297 LOGICAL, INTENT(IN) :: has_pseudopotential
298 REAL(dp), INTENT(IN) :: zeff
299 INTEGER, INTENT(IN) :: zatom
300 LOGICAL :: use_one_center
301
302 use_one_center = paw_atom
303 IF (.NOT. use_one_center) RETURN
304
305 SELECT CASE (gapw_representation)
306 CASE (skala_gapw_direct_valence)
307 use_one_center = .NOT. has_pseudopotential
308 CASE (skala_gapw_paw_one_center, skala_gapw_paw_one_center_split)
309 CONTINUE
310 CASE (skala_gapw_cp2k_default)
311 IF (has_pseudopotential .AND. &
312 abs(zeff - real(zatom, dp)) <= 1.0e-10_dp) use_one_center = .false.
313 END SELECT
314
315 END FUNCTION native_skala_uses_one_center_kind
316
317! **************************************************************************************************
318!> \brief ...
319!> \param qs_env ...
320!> \param energy_only ...
321!> \param exc1 the on-body ex energy contribution
322!> \param adiabatic_rescale_factor ...
323!> \param kind_set_external provides a non-default kind_set to use
324!> \param rho_atom_set_external provides a non-default atomic density set to use
325!> \param xc_section_external provides an external non-default XC
326!> \param calculate_forces ...
327!> \param composite_vxc_rho ...
328!> \param composite_vxc_tau ...
329!> \param composite_reference_active ...
330!> \param direct_valence_atom_grid evaluate the smooth valence fields on atom-centered grids
331!> \param atom_composite_grid evaluate GAPW primitive fields on atom-centered composite grids
332! **************************************************************************************************
333 SUBROUTINE calculate_vxc_atom(qs_env, energy_only, exc1, &
334 adiabatic_rescale_factor, kind_set_external, &
335 rho_atom_set_external, xc_section_external, calculate_forces, &
336 composite_vxc_rho, composite_vxc_tau, composite_reference_active, &
337 direct_valence_atom_grid, atom_composite_grid)
338
339 TYPE(qs_environment_type), POINTER :: qs_env
340 LOGICAL, INTENT(IN) :: energy_only
341 REAL(dp), INTENT(INOUT) :: exc1
342 REAL(dp), INTENT(IN), OPTIONAL :: adiabatic_rescale_factor
343 TYPE(qs_kind_type), DIMENSION(:), OPTIONAL, &
344 POINTER :: kind_set_external
345 TYPE(rho_atom_type), DIMENSION(:), OPTIONAL, &
346 POINTER :: rho_atom_set_external
347 TYPE(section_vals_type), OPTIONAL, POINTER :: xc_section_external
348 LOGICAL, INTENT(IN), OPTIONAL :: calculate_forces
349 TYPE(pw_r3d_rs_type), DIMENSION(:), OPTIONAL, &
350 POINTER :: composite_vxc_rho, composite_vxc_tau
351 LOGICAL, INTENT(OUT), OPTIONAL :: composite_reference_active
352 LOGICAL, INTENT(IN), OPTIONAL :: direct_valence_atom_grid, &
353 atom_composite_grid
354
355 CHARACTER(LEN=*), PARAMETER :: routinen = 'calculate_vxc_atom'
356
357 INTEGER :: adjoint_bin, adjoint_entry, adjoint_nbins, adjoint_nchannels, &
358 adjoint_tile_count(3), adjoint_tile_lower(3), adjoint_tile_upper(3), &
359 atom_composite_components, base_shift(3), bo(2), composite_descriptor_target_image, &
360 composite_image_periodicity(3), composite_local_atom, composite_local_natom, &
361 composite_nflat, composite_partition_target_image, composite_pw_nflat, composite_row, &
362 gapw_density_partition, gapw_representation, handle, ia, iat, iatom, icomponent, idir, &
363 ikind, image_i1, image_i2, image_i3, image_shell(3), image_shift(3), ir, ispin, iw, jdir, &
364 myfun, na, natom, nr, nspins
365 INTEGER :: num_pe, source_atom, target_atom, xc_deriv_method_id, xc_rho_smooth_id, zatom
366 INTEGER(KIND=int_8), ALLOCATABLE, DIMENSION(:) :: composite_atomic_grid_sizes, &
367 composite_local_grid_sizes
368 INTEGER, ALLOCATABLE, DIMENSION(:) :: adjoint_bin_offsets, adjoint_bin_rows, &
369 composite_atom_end, composite_atom_kind, composite_atom_kind_index, composite_atom_start, &
370 composite_grid_atom, composite_local_atoms
371 INTEGER, DIMENSION(2, 3) :: bounds
372 INTEGER, DIMENSION(:), POINTER :: atom_list
373 LOGICAL :: accint, atom_composite_active, atom_composite_diagnostic, &
374 atom_composite_reference, direct_valence_atom_composite, donlcc, evaluate_hard, &
375 evaluate_soft, gradient_f, image_partition_atom_composite, lsd, my_calculate_forces, &
376 native_grid_diagnostics, nlcc, one_center_kind, paw_atom, paw_pseudopotentials, &
377 requested_atom_composite_grid, rho_g_valid, skala_atom_grid, source_matrix_local, tau_f, &
378 tau_r_valid, use_atom_composite_density, use_atom_composite_gradient, &
379 use_atom_composite_tau, use_virial
380 LOGICAL, ALLOCATABLE, DIMENSION(:) :: composite_partition_included
381 REAL(dp) :: agr, alpha, atom_composite_exc, atom_composite_nelec, &
382 composite_cross_cutoff_max, composite_cross_density_max, composite_cross_grad_max, &
383 composite_cross_kin_max, composite_density_max, composite_density_min, &
384 composite_grad_max, composite_kin_max, composite_kin_min, composite_tau_integral, &
385 cross_cutoff, density_cut, descriptor_window_adjoint, descriptor_window_weight, exc_h, &
386 exc_s, feature_vxc_analytic, feature_vxc_fd, feature_vxc_minus, feature_vxc_plus, &
387 feature_vxc_step, gradient_cut, local_partition_weight, my_adiabatic_rescale_factor, &
388 nlcc_density, nlcc_spin_factor
389 REAL(dp) :: one_center_density_field_contraction, one_center_density_matrix_contraction, &
390 one_center_field_contraction, one_center_gradient_field_contraction, &
391 one_center_gradient_matrix_contraction, one_center_matrix_contraction, &
392 one_center_rho_grad_field_contraction, one_center_rho_grad_matrix_contraction, &
393 one_center_tau_field_contraction, one_center_tau_matrix_contraction, &
394 one_center_tensor_contraction, partition_adjoint, partition_scale, partition_weight, &
395 smooth_grid_contraction, smooth_input_contraction, target_partition_adjoint, tau_cut, zeff
396 REAL(dp), ALLOCATABLE, DIMENSION(:) :: composite_atomic_grid_weight_grad, &
397 composite_atomic_grid_weights, composite_base_grid_weights, composite_distances, &
398 composite_grid_weight_grad, composite_grid_weights, composite_partition_weights
399 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: composite_atom_coord_grad, composite_atom_coords, &
400 composite_cross_density, composite_cross_force, composite_cross_force_local, &
401 composite_cross_kin, composite_density, composite_density_grad, &
402 composite_descriptor_image_coords, composite_explicit_force, composite_grid_coord_force, &
403 composite_grid_coord_grad, composite_grid_coords, composite_kin, composite_kin_grad, &
404 composite_local_atom_coords, composite_model_atom_force, composite_moving_smooth_force, &
405 composite_nlcc_center_force, composite_nlcc_center_force_local, &
406 composite_nlcc_target_force
407 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: composite_partition_atom_coords, &
408 composite_partition_force, composite_partition_force_local, &
409 composite_partition_image_coords, composite_smooth_density_cache, &
410 composite_smooth_kin_cache, local_partition_datom
411 REAL(dp), ALLOCATABLE, DIMENSION(:, :), TARGET :: smooth_density_adjoint_storage, &
412 smooth_kin_adjoint_storage
413 REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: composite_cross_grad, composite_grad, &
414 composite_grad_grad, composite_int_h, composite_int_s, composite_partition_datom, &
415 composite_partition_dstrain, composite_smooth_gradient_cache
416 REAL(dp), ALLOCATABLE, DIMENSION(:, :, :), TARGET :: smooth_grad_adjoint_storage
417 REAL(dp), DIMENSION(1, 1, 1) :: tau_d
418 REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d
419 REAL(dp), DIMENSION(2) :: composite_smooth_density_adjoint_value, &
420 composite_smooth_density_value, composite_smooth_kin_adjoint_value, &
421 composite_smooth_kin_value, cross_density, cross_density_adjoint, cross_kin, &
422 cross_kin_adjoint
423 REAL(dp), DIMENSION(3) :: composite_point, cross_displacement, cross_spatial_derivative, &
424 fractional, image_translation, nlcc_gradient, nlcc_spatial_derivative, &
425 skala_atom_force_h, skala_atom_force_s, spatial_derivative
426 REAL(dp), DIMENSION(3, 1) :: local_descriptor_datom
427 REAL(dp), DIMENSION(3, 2) :: composite_smooth_gradient_adjoint_value, &
428 composite_smooth_gradient_value, cross_density_spatial, cross_grad, cross_grad_adjoint, &
429 cross_kin_spatial
430 REAL(dp), DIMENSION(3, 3) :: composite_cross_image_virial, &
431 composite_cross_image_virial_local, composite_explicit_virial, composite_feature_virial, &
432 composite_interpolation_virial, composite_partition_strain_virial, &
433 local_descriptor_dstrain, local_partition_dstrain, nlcc_hessian, skala_atom_virial, &
434 skala_atom_virial_h, skala_atom_virial_s
435 REAL(dp), DIMENSION(3, 3, 2) :: cross_grad_spatial
436 REAL(dp), DIMENSION(4) :: feature_component_analytic, &
437 feature_component_fd
438 REAL(dp), DIMENSION(:, :), POINTER :: rho_nlcc, smooth_density_adjoint, &
439 smooth_kin_adjoint, weight_h, weight_s
440 REAL(dp), DIMENSION(:, :, :), POINTER :: composite_smooth_rho, composite_smooth_rhoa, &
441 composite_smooth_rhob, composite_smooth_tau, composite_smooth_tau_a, &
442 composite_smooth_tau_b, rho_h, rho_s, smooth_grad_adjoint, smooth_rho, smooth_rhoa, &
443 smooth_rhob, smooth_tau, smooth_tau_a, smooth_tau_b, tau_h, tau_s, vtau_h, vtau_s, vxc_h, &
444 vxc_s
445 REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s, vxg_h, vxg_s
446 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
447 TYPE(cell_type), POINTER :: cell
448 TYPE(cp_3d_r_cp_type), DIMENSION(3) :: composite_smooth_drho, composite_smooth_drhoa, &
449 composite_smooth_drhob, smooth_drho, smooth_drhoa, smooth_drhob
450 TYPE(dft_control_type), POINTER :: dft_control
451 TYPE(grid_atom_type), POINTER :: grid_atom
452 TYPE(gth_potential_type), POINTER :: gth_potential
453 TYPE(gto_basis_set_type), POINTER :: basis_1c
454 TYPE(harmonics_atom_type), POINTER :: harmonics
455 TYPE(mp_para_env_type), POINTER :: para_env
456 TYPE(native_grid_interpolation_stencil_type) :: interpolation_stencil
457 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
458 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: smooth_rho_g
459 TYPE(pw_env_type), POINTER :: pw_env
460 TYPE(pw_pool_type), POINTER :: auxbas_pw_pool
461 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: smooth_rho_r, smooth_tau_r, &
462 smooth_vxc_rho, smooth_vxc_tau
463 TYPE(qs_force_type), DIMENSION(:), POINTER :: force
464 TYPE(qs_kind_type), DIMENSION(:), POINTER :: my_kind_set
465 TYPE(qs_rho_type), POINTER :: rho_struct
466 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: cpc_h, cpc_s, dr_h, dr_s, int_hh, &
467 int_ss, r_h, r_s
468 TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
469 TYPE(rho_atom_type), DIMENSION(:), POINTER :: my_rho_atom_set
470 TYPE(rho_atom_type), POINTER :: rho_atom
471 TYPE(section_vals_type), POINTER :: gauxc_section, input, my_xc_section, &
472 xc_fun_section
473 TYPE(sgp_potential_type), POINTER :: sgp_potential
474 TYPE(tau_basis_cache_type) :: tau_basis_cache
475 TYPE(virial_type), POINTER :: virial
476 TYPE(xc_derivative_set_type) :: deriv_set
477 TYPE(xc_rho_cflags_type) :: needs
478 TYPE(xc_rho_set_type) :: rho_set_h, rho_set_s, smooth_rho_set
479
480! -------------------------------------------------------------------------
481
482 CALL timeset(routinen, handle)
483
484 NULLIFY (atom_list)
485 NULLIFY (auxbas_pw_pool)
486 NULLIFY (my_kind_set)
487 NULLIFY (atomic_kind_set)
488 NULLIFY (cell)
489 NULLIFY (grid_atom)
490 NULLIFY (gth_potential)
491 NULLIFY (force)
492 NULLIFY (harmonics)
493 NULLIFY (input)
494 NULLIFY (para_env)
495 NULLIFY (particle_set)
496 NULLIFY (pw_env)
497 NULLIFY (rho_atom)
498 NULLIFY (rho_struct)
499 NULLIFY (my_rho_atom_set)
500 NULLIFY (rho_nlcc)
501 NULLIFY (smooth_rho, smooth_rhoa, smooth_rhob, smooth_tau, smooth_tau_a, smooth_tau_b)
502 NULLIFY (composite_smooth_rho, composite_smooth_rhoa, composite_smooth_rhob, &
503 composite_smooth_tau, composite_smooth_tau_a, composite_smooth_tau_b)
504 NULLIFY (smooth_rho_g, smooth_rho_r, smooth_tau_r)
505 NULLIFY (smooth_vxc_rho, smooth_vxc_tau)
506 DO idir = 1, 3
507 NULLIFY (smooth_drho(idir)%array, smooth_drhoa(idir)%array, smooth_drhob(idir)%array)
508 NULLIFY (composite_smooth_drho(idir)%array, &
509 composite_smooth_drhoa(idir)%array, &
510 composite_smooth_drhob(idir)%array)
511 END DO
512 NULLIFY (sgp_potential)
513 NULLIFY (virial)
514 my_calculate_forces = .false.
515 IF (PRESENT(calculate_forces)) my_calculate_forces = calculate_forces
516 IF (PRESENT(composite_reference_active)) composite_reference_active = .false.
517 direct_valence_atom_composite = .false.
518 IF (PRESENT(direct_valence_atom_grid)) THEN
519 direct_valence_atom_composite = direct_valence_atom_grid
520 END IF
521 requested_atom_composite_grid = .false.
522 IF (PRESENT(atom_composite_grid)) requested_atom_composite_grid = atom_composite_grid
523
524 IF (PRESENT(adiabatic_rescale_factor)) THEN
525 my_adiabatic_rescale_factor = adiabatic_rescale_factor
526 ELSE
527 my_adiabatic_rescale_factor = 1.0_dp
528 END IF
529
530 CALL get_qs_env(qs_env=qs_env, &
531 dft_control=dft_control, &
532 cell=cell, &
533 para_env=para_env, &
534 atomic_kind_set=atomic_kind_set, &
535 qs_kind_set=my_kind_set, &
536 input=input, &
537 particle_set=particle_set, &
538 pw_env=pw_env, &
539 virial=virial, &
540 rho_atom_set=my_rho_atom_set, &
541 force=force)
542
543 IF (dft_control%qs_control%gapw_xc) THEN
544 CALL get_qs_env(qs_env=qs_env, rho_xc=rho_struct)
545 ELSE
546 CALL get_qs_env(qs_env=qs_env, rho=rho_struct)
547 END IF
548
549 IF (PRESENT(kind_set_external)) my_kind_set => kind_set_external
550 IF (PRESENT(rho_atom_set_external)) my_rho_atom_set => rho_atom_set_external
551
552 nlcc = has_nlcc(my_kind_set)
553 accint = dft_control%qs_control%gapw_control%accurate_xcint
554
555 my_xc_section => section_vals_get_subs_vals(input, "DFT%XC")
556
557 IF (PRESENT(xc_section_external)) my_xc_section => xc_section_external
558
559 xc_fun_section => section_vals_get_subs_vals(my_xc_section, "XC_FUNCTIONAL")
560 CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", &
561 i_val=myfun)
562 skala_atom_grid = xc_section_uses_gauxc_model(my_xc_section)
563 gapw_representation = skala_gapw_cp2k_default
564 atom_composite_diagnostic = .false.
565 atom_composite_reference = .false.
566 paw_pseudopotentials = .false.
567 native_grid_diagnostics = .false.
568 atom_composite_components = 1
569 feature_vxc_step = 3.0e-3_dp
570 IF (skala_atom_grid) THEN
571 gauxc_section => get_gauxc_section(my_xc_section)
572 cpassert(ASSOCIATED(gauxc_section))
573 CALL section_vals_val_get(gauxc_section, "PSEUDOPOTENTIAL_GAPW_REPRESENTATION", &
574 i_val=gapw_representation)
575 CALL section_vals_val_get(gauxc_section, "NATIVE_GRID_DIAGNOSTICS", &
576 l_val=native_grid_diagnostics)
577 END IF
578 IF (skala_atom_grid) THEN
579 DO ikind = 1, SIZE(my_kind_set)
580 NULLIFY (gth_potential, sgp_potential)
581 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
582 gth_potential=gth_potential, sgp_potential=sgp_potential)
583 paw_pseudopotentials = paw_pseudopotentials .OR. &
584 (paw_atom .AND. (ASSOCIATED(gth_potential) .OR. &
585 ASSOCIATED(sgp_potential)))
586 END DO
587 END IF
588 IF (skala_atom_grid .AND. xc_section_uses_native_skala_evaluator(my_xc_section)) THEN
589 CALL section_vals_val_get(gauxc_section, &
590 "NATIVE_GRID_GAPW_ATOM_COMPOSITE_DIAGNOSTIC", &
591 l_val=atom_composite_diagnostic)
592 CALL section_vals_val_get(gauxc_section, &
593 "NATIVE_GRID_GAPW_ATOM_COMPOSITE_REFERENCE", &
594 l_val=atom_composite_reference)
595 CALL section_vals_val_get(gauxc_section, &
596 "NATIVE_GRID_GAPW_ATOM_COMPOSITE_COMPONENTS", &
597 i_val=atom_composite_components)
598 CALL section_vals_val_get(gauxc_section, &
599 "NATIVE_GRID_GAPW_ATOM_COMPOSITE_FD_STEP", &
600 r_val=feature_vxc_step)
601 END IF
602 atom_composite_reference = atom_composite_reference .OR. &
603 (gapw_representation == skala_gapw_paw_one_center .AND. &
604 paw_pseudopotentials)
605 atom_composite_reference = atom_composite_reference .OR. requested_atom_composite_grid
606 atom_composite_reference = atom_composite_reference .OR. direct_valence_atom_composite
607 atom_composite_active = atom_composite_diagnostic .OR. atom_composite_reference
608 use_atom_composite_density = atom_composite_components <= 2
609 use_atom_composite_gradient = atom_composite_components <= 2
610 use_atom_composite_tau = atom_composite_components == 1 .OR. &
611 atom_composite_components == 3
612 IF (atom_composite_active) THEN
613 CALL ensure_native_skala_atom_grids(my_kind_set, dft_control)
614 END IF
615 IF (direct_valence_atom_composite) THEN
616 use_atom_composite_density = .false.
617 use_atom_composite_gradient = .false.
618 use_atom_composite_tau = .false.
619 END IF
620 ! CP2K's auxiliary PW fields are represented on one index-periodic cell even
621 ! when the physical Poisson problem is isolated or partially periodic.
622 image_partition_atom_composite = atom_composite_active
623 composite_image_periodicity = 1
624 IF (PRESENT(composite_reference_active)) composite_reference_active = atom_composite_reference
625 gapw_density_partition = skala_gapw_density_partition_hard_minus_soft
626 IF (skala_atom_grid) THEN
627 gapw_density_partition = native_skala_gapw_density_partition(my_xc_section)
628 END IF
629 use_virial = ASSOCIATED(virial)
630 IF (use_virial) use_virial = my_calculate_forces .AND. &
631 virial%pv_calculate .AND. (.NOT. virial%pv_numer)
632
633 IF (myfun == xc_none) THEN
634 exc1 = 0.0_dp
635 my_rho_atom_set(:)%exc_h = 0.0_dp
636 my_rho_atom_set(:)%exc_s = 0.0_dp
637 ELSE
638 CALL section_vals_val_get(my_xc_section, "DENSITY_CUTOFF", &
639 r_val=density_cut)
640 CALL section_vals_val_get(my_xc_section, "GRADIENT_CUTOFF", &
641 r_val=gradient_cut)
642 CALL section_vals_val_get(my_xc_section, "TAU_CUTOFF", &
643 r_val=tau_cut)
644
645 lsd = dft_control%lsd
646 nspins = dft_control%nspins
647 needs = xc_functionals_get_needs(xc_fun_section, &
648 lsd=lsd, &
649 calc_potential=.true.)
650
651 gradient_f = (needs%drho .OR. needs%drho_spin) .OR. skala_atom_grid
652 tau_f = (needs%tau .OR. needs%tau_spin) .OR. skala_atom_grid
653
654 IF (atom_composite_active) THEN
655 IF (lsd) THEN
656 needs%rho_spin = .true.
657 needs%drho_spin = .true.
658 needs%tau_spin = .true.
659 ELSE
660 needs%rho = .true.
661 needs%drho = .true.
662 needs%tau = .true.
663 END IF
664
665 ALLOCATE (composite_atomic_grid_sizes(SIZE(particle_set)), &
666 composite_atom_kind(SIZE(particle_set)), &
667 composite_atom_kind_index(SIZE(particle_set)), &
668 composite_atom_start(SIZE(particle_set)), &
669 composite_atom_end(SIZE(particle_set)), &
670 composite_atom_coords(3, SIZE(particle_set)), &
671 composite_partition_weights(SIZE(particle_set)), &
672 composite_partition_atom_coords(3, SIZE(particle_set)), &
673 composite_distances(SIZE(particle_set)))
674 composite_atomic_grid_sizes = 0_int_8
675 composite_atom_kind = 0
676 composite_atom_kind_index = 0
677 composite_atom_start = 0
678 composite_atom_end = 0
679 DO iatom = 1, SIZE(particle_set)
680 composite_atom_coords(:, iatom) = particle_set(iatom)%r
681 END DO
682 DO ikind = 1, SIZE(atomic_kind_set)
683 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
684 NULLIFY (gth_potential, sgp_potential)
685 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
686 gth_potential=gth_potential, grid_atom=grid_atom, &
687 sgp_potential=sgp_potential, zatom=zatom, zeff=zeff)
688 DO iat = 1, natom
689 iatom = atom_list(iat)
690 composite_atomic_grid_sizes(iatom) = int(grid_atom%nr*grid_atom%ng_sphere, kind=int_8)
691 composite_atom_kind(iatom) = ikind
692 composite_atom_kind_index(iatom) = iat
693 END DO
694 END DO
695 IF (any(composite_atomic_grid_sizes <= 0_int_8)) THEN
696 CALL cp_abort(__location__, &
697 "The atom-composite diagnostic requires a GAPW one-center grid for every atom.")
698 END IF
699
700 composite_local_natom = 0
701 DO ikind = 1, SIZE(atomic_kind_set)
702 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
703 NULLIFY (gth_potential, sgp_potential)
704 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
705 gth_potential=gth_potential, sgp_potential=sgp_potential, &
706 zatom=zatom, zeff=zeff)
707 bo = get_limit(natom, para_env%num_pe, para_env%mepos)
708 composite_local_natom = composite_local_natom + max(0, bo(2) - bo(1) + 1)
709 END DO
710 ALLOCATE (composite_local_atoms(composite_local_natom), &
711 composite_local_grid_sizes(composite_local_natom), &
712 composite_local_atom_coords(3, composite_local_natom))
713 composite_local_atom = 0
714 composite_nflat = 0
715 DO ikind = 1, SIZE(atomic_kind_set)
716 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
717 NULLIFY (gth_potential, sgp_potential)
718 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
719 gth_potential=gth_potential, sgp_potential=sgp_potential, &
720 zatom=zatom, zeff=zeff)
721 bo = get_limit(natom, para_env%num_pe, para_env%mepos)
722 DO iat = bo(1), bo(2)
723 iatom = atom_list(iat)
724 composite_local_atom = composite_local_atom + 1
725 composite_local_atoms(composite_local_atom) = iatom
726 composite_local_grid_sizes(composite_local_atom) = &
727 composite_atomic_grid_sizes(iatom)
728 composite_local_atom_coords(:, composite_local_atom) = &
729 composite_atom_coords(:, iatom)
730 composite_atom_start(iatom) = composite_nflat + 1
731 composite_nflat = composite_nflat + int(composite_atomic_grid_sizes(iatom))
732 composite_atom_end(iatom) = composite_nflat
733 END DO
734 END DO
735 cpassert(composite_local_atom == composite_local_natom)
736 ALLOCATE (composite_density(composite_nflat, 2), &
737 composite_grad(composite_nflat, 3, 2), &
738 composite_kin(composite_nflat, 2), &
739 composite_grid_atom(composite_nflat), &
740 composite_smooth_density_cache(composite_nflat, 2), &
741 composite_smooth_gradient_cache(composite_nflat, 3, 2), &
742 composite_smooth_kin_cache(composite_nflat, 2), &
743 composite_grid_coords(3, composite_nflat), &
744 composite_grid_weights(composite_nflat), &
745 composite_base_grid_weights(composite_nflat), &
746 composite_atomic_grid_weights(composite_nflat))
747 composite_density = 0.0_dp
748 composite_grad = 0.0_dp
749 composite_kin = 0.0_dp
750 DO composite_local_atom = 1, composite_local_natom
751 iatom = composite_local_atoms(composite_local_atom)
752 composite_grid_atom(composite_atom_start(iatom):composite_atom_end(iatom)) = iatom
753 END DO
754 composite_smooth_density_cache = 0.0_dp
755 composite_smooth_gradient_cache = 0.0_dp
756 composite_smooth_kin_cache = 0.0_dp
757 composite_grid_coords = 0.0_dp
758 composite_grid_weights = 0.0_dp
759 composite_base_grid_weights = 0.0_dp
760 composite_atomic_grid_weights = 0.0_dp
761
762 CALL qs_rho_get(rho_struct, rho_r=smooth_rho_r, rho_g=smooth_rho_g, &
763 tau_r=smooth_tau_r, rho_g_valid=rho_g_valid, &
764 tau_r_valid=tau_r_valid)
765 cpassert(rho_g_valid)
766 cpassert(tau_r_valid)
767 cpassert(ASSOCIATED(smooth_rho_r))
768 cpassert(ASSOCIATED(smooth_rho_g))
769 cpassert(ASSOCIATED(smooth_tau_r))
770 CALL pw_env_get(pw_env, auxbas_pw_pool=auxbas_pw_pool)
771 CALL section_vals_val_get(my_xc_section, "XC_GRID%XC_DERIV", &
772 i_val=xc_deriv_method_id)
773 CALL section_vals_val_get(my_xc_section, "XC_GRID%XC_SMOOTH_RHO", &
774 i_val=xc_rho_smooth_id)
775 CALL xc_rho_set_create(smooth_rho_set, smooth_rho_r(1)%pw_grid%bounds_local, &
776 rho_cutoff=section_get_rval(my_xc_section, "density_cutoff"), &
777 drho_cutoff=section_get_rval(my_xc_section, "gradient_cutoff"), &
778 tau_cutoff=section_get_rval(my_xc_section, "tau_cutoff"))
779 CALL xc_rho_set_update(smooth_rho_set, smooth_rho_r, smooth_rho_g, smooth_tau_r, needs, &
780 xc_deriv_method_id, xc_rho_smooth_id, auxbas_pw_pool)
781 IF (lsd) THEN
782 CALL xc_rho_set_get(smooth_rho_set, rhoa=smooth_rhoa, rhob=smooth_rhob, &
783 drhoa=smooth_drhoa, drhob=smooth_drhob, &
784 tau_a=smooth_tau_a, tau_b=smooth_tau_b)
785 CALL gather_native_grid_field(smooth_rhoa, smooth_rho_r(1)%pw_grid, para_env, &
786 composite_smooth_rhoa)
787 CALL gather_native_grid_field(smooth_rhob, smooth_rho_r(1)%pw_grid, para_env, &
788 composite_smooth_rhob)
789 CALL gather_native_grid_field(smooth_tau_a, smooth_rho_r(1)%pw_grid, para_env, &
790 composite_smooth_tau_a)
791 CALL gather_native_grid_field(smooth_tau_b, smooth_rho_r(1)%pw_grid, para_env, &
792 composite_smooth_tau_b)
793 DO idir = 1, 3
794 CALL gather_native_grid_field(smooth_drhoa(idir)%array, &
795 smooth_rho_r(1)%pw_grid, para_env, &
796 composite_smooth_drhoa(idir)%array)
797 CALL gather_native_grid_field(smooth_drhob(idir)%array, &
798 smooth_rho_r(1)%pw_grid, para_env, &
799 composite_smooth_drhob(idir)%array)
800 END DO
801 ELSE
802 CALL xc_rho_set_get(smooth_rho_set, rho=smooth_rho, drho=smooth_drho, &
803 tau=smooth_tau)
804 CALL gather_native_grid_field(smooth_rho, smooth_rho_r(1)%pw_grid, para_env, &
805 composite_smooth_rho)
806 CALL gather_native_grid_field(smooth_tau, smooth_rho_r(1)%pw_grid, para_env, &
807 composite_smooth_tau)
808 DO idir = 1, 3
809 CALL gather_native_grid_field(smooth_drho(idir)%array, &
810 smooth_rho_r(1)%pw_grid, para_env, &
811 composite_smooth_drho(idir)%array)
812 END DO
813 END IF
814 END IF
815
816 ! Initialize energy contribution from the one center XC terms to zero
817 exc1 = 0.0_dp
818
819 ! Nullify some pointers for work-arrays
820 NULLIFY (rho_h, drho_h, rho_s, drho_s, weight_h, weight_s)
821 NULLIFY (vxc_h, vxc_s, vxg_h, vxg_s)
822 NULLIFY (tau_h, tau_s)
823 NULLIFY (vtau_h, vtau_s)
824
825 ! Here starts the loop over all the atoms
826
827 DO ikind = 1, SIZE(atomic_kind_set)
828 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
829 NULLIFY (gth_potential, sgp_potential)
830 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
831 gth_potential=gth_potential, harmonics=harmonics, &
832 grid_atom=grid_atom, sgp_potential=sgp_potential, &
833 zatom=zatom, zeff=zeff)
834 one_center_kind = .NOT. direct_valence_atom_composite
835 IF (one_center_kind) THEN
836 CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
837 one_center_kind = paw_atom
838 IF (skala_atom_grid) THEN
839 one_center_kind = native_skala_uses_one_center_kind( &
840 paw_atom, gapw_representation, &
841 ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential), &
842 zeff, zatom)
843 END IF
844 END IF
845 IF (.NOT. one_center_kind .AND. .NOT. atom_composite_active) cycle
846
847 nr = grid_atom%nr
848 na = grid_atom%ng_sphere
849
850 IF (one_center_kind) THEN
851 ! Prepare the structures needed to calculate and store the one-center XC derivatives.
852
853 ! Array dimension: here anly one dimensional arrays are used,
854 ! i.e. only the first column of deriv_data is read.
855 ! The other to dimensions are set to size equal 1
856 bounds(1:2, 1:3) = 1
857 bounds(2, 1) = na
858 bounds(2, 2) = nr
859
860 ! set integration weights
861 IF (accint) THEN
862 weight_h => grid_atom%weight
863 alpha = dft_control%qs_control%gapw_control%aw(ikind)
864 IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
865 IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
866 END IF
867 IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
868 ALLOCATE (grid_atom%gapw_weight_s(na, nr))
869 DO ir = 1, nr
870 agr = 1.0_dp - exp(-alpha*grid_atom%rad2(ir))
871 grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
872 END DO
873 grid_atom%gapw_weight_alpha = alpha
874 END IF
875 weight_s => grid_atom%gapw_weight_s
876 ELSE
877 weight_h => grid_atom%weight
878 weight_s => grid_atom%weight
879 END IF
880
881 ! create a place where to put the derivatives
882 CALL xc_dset_create(deriv_set, local_bounds=bounds)
883 ! create the place where to store the argument for the functionals
884 CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
885 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
886 CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
887 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
888
889 ! allocate the required 3d arrays where to store rho and drho
890 CALL xc_rho_set_atom_update(rho_set_h, needs, nspins, bounds)
891 CALL xc_rho_set_atom_update(rho_set_s, needs, nspins, bounds)
892
893 CALL reallocate(rho_h, 1, na, 1, nr, 1, nspins)
894 CALL reallocate(rho_s, 1, na, 1, nr, 1, nspins)
895 CALL reallocate(vxc_h, 1, na, 1, nr, 1, nspins)
896 CALL reallocate(vxc_s, 1, na, 1, nr, 1, nspins)
897 !
898 IF (gradient_f) THEN
899 CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
900 CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
901 CALL reallocate(vxg_h, 1, 3, 1, na, 1, nr, 1, nspins)
902 CALL reallocate(vxg_s, 1, 3, 1, na, 1, nr, 1, nspins)
903 END IF
904
905 IF (tau_f) THEN
906 CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
907 CALL reallocate(tau_h, 1, na, 1, nr, 1, nspins)
908 CALL reallocate(tau_s, 1, na, 1, nr, 1, nspins)
909 CALL reallocate(vtau_h, 1, na, 1, nr, 1, nspins)
910 CALL reallocate(vtau_s, 1, na, 1, nr, 1, nspins)
911 END IF
912
913 ! NLCC for separate hard and soft one-center densities.
914 donlcc = .false.
915 IF (nlcc) THEN
916 NULLIFY (rho_nlcc)
917 rho_nlcc => my_kind_set(ikind)%nlcc_pot
918 IF (ASSOCIATED(rho_nlcc)) donlcc = .true.
919 END IF
920 END IF
921
922 ! Distribute the atoms of this kind
923
924 num_pe = para_env%num_pe
925 bo = get_limit(natom, para_env%num_pe, para_env%mepos)
926
927 DO iat = bo(1), bo(2)
928 iatom = atom_list(iat)
929
930 IF (one_center_kind) THEN
931 my_rho_atom_set(iatom)%exc_h = 0.0_dp
932 my_rho_atom_set(iatom)%exc_s = 0.0_dp
933
934 rho_atom => my_rho_atom_set(iatom)
935 rho_h = 0.0_dp
936 rho_s = 0.0_dp
937 IF (gradient_f) THEN
938 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
939 CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, &
940 rho_rad_s=r_s, drho_rad_h=dr_h, &
941 drho_rad_s=dr_s, rho_rad_h_d=r_h_d, &
942 rho_rad_s_d=r_s_d)
943 drho_h = 0.0_dp
944 drho_s = 0.0_dp
945 ELSE
946 NULLIFY (r_h, r_s)
947 CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s)
948 rho_d = 0.0_dp
949 END IF
950 IF (tau_f) THEN
951 CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
952 ELSE
953 tau_d = 0.0_dp
954 END IF
955
956 DO ir = 1, nr
957 CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
958 ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
959 r_h_d, r_s_d, drho_h, drho_s)
960 IF (donlcc) THEN
961 CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
962 ir, rho_nlcc(:, 1), rho_h, rho_s, &
963 rho_nlcc(:, 2), drho_h, drho_s)
964 END IF
965 END DO
966 END IF
967
968 IF (atom_composite_active) THEN
969 IF (image_partition_atom_composite) THEN
970 CALL build_periodic_atom_image_layout( &
971 composite_atom_coords, cell, iatom, composite_image_periodicity, &
972 composite_partition_image_coords, composite_partition_target_image)
973 CALL build_periodic_atom_image_layout( &
974 composite_atom_coords(:, iatom:iatom), cell, 1, &
975 composite_image_periodicity, composite_descriptor_image_coords, &
976 composite_descriptor_target_image)
977 END IF
978!$OMP PARALLEL DO COLLAPSE(2) IF (image_partition_atom_composite) SCHEDULE(STATIC) DEFAULT(NONE) &
979!$OMP PRIVATE(composite_row, composite_point, composite_smooth_density_value, &
980!$OMP composite_smooth_gradient_value, composite_smooth_kin_value, &
981!$OMP descriptor_window_weight, idir, ispin, &
982!$OMP gth_potential, nlcc_density, nlcc_gradient, nlcc_hessian, nlcc_spin_factor, &
983!$OMP interpolation_stencil, partition_scale, partition_weight, sgp_potential, source_atom) &
984!$OMP SHARED(atom_composite_reference, cell, composite_atom_coords, composite_atom_kind, &
985!$OMP composite_atom_start, composite_atomic_grid_weights, composite_base_grid_weights, &
986!$OMP composite_density, composite_descriptor_image_coords, &
987!$OMP composite_descriptor_target_image, composite_distances, composite_grad, &
988!$OMP composite_grid_coords, composite_grid_weights, composite_kin, &
989!$OMP composite_partition_atom_coords, composite_partition_image_coords, &
990!$OMP composite_partition_target_image, composite_partition_weights, &
991!$OMP composite_smooth_density_cache, composite_smooth_drho, composite_smooth_drhoa, &
992!$OMP composite_smooth_drhob, composite_smooth_gradient_cache, &
993!$OMP composite_smooth_kin_cache, composite_smooth_rho, composite_smooth_rhoa, &
994!$OMP composite_smooth_rhob, composite_smooth_tau, composite_smooth_tau_a, &
995!$OMP composite_smooth_tau_b, drho_h, drho_s, grid_atom, iatom, &
996!$OMP image_partition_atom_composite, lsd, my_kind_set, na, nlcc, nr, one_center_kind, &
997!$OMP particle_set, rho_h, rho_s, smooth_rho_r, tau_h, tau_s, &
998!$OMP use_atom_composite_density, use_atom_composite_gradient, use_atom_composite_tau)
999 DO ir = 1, nr
1000 DO ia = 1, na
1001 composite_row = composite_atom_start(iatom) + (ir - 1)*na + ia - 1
1002 composite_point(1) = particle_set(iatom)%r(1) + grid_atom%rad(ir)* &
1003 grid_atom%sin_pol(ia)*grid_atom%cos_azi(ia)
1004 composite_point(2) = particle_set(iatom)%r(2) + grid_atom%rad(ir)* &
1005 grid_atom%sin_pol(ia)*grid_atom%sin_azi(ia)
1006 composite_point(3) = particle_set(iatom)%r(3) + &
1007 grid_atom%rad(ir)*grid_atom%cos_pol(ia)
1008 composite_grid_coords(:, composite_row) = composite_point
1009 IF (image_partition_atom_composite) THEN
1010 CALL periodic_atom_image_partition_from_layout( &
1011 composite_point, composite_partition_image_coords, &
1012 composite_partition_target_image, partition_weight)
1013 ! The self-image partition defines a smooth atom-centered periodic
1014 ! descriptor domain without truncating it at neighboring atoms.
1015 CALL periodic_atom_image_partition_from_layout( &
1016 composite_point, composite_descriptor_image_coords, &
1017 composite_descriptor_target_image, descriptor_window_weight)
1018 partition_scale = smooth_partition_atomic_weight_scale( &
1019 descriptor_window_weight)
1020 ELSE
1021 CALL smooth_atom_partition( &
1022 composite_point, composite_atom_coords, cell, &
1023 composite_partition_weights, composite_partition_atom_coords, &
1024 composite_distances)
1025 partition_weight = composite_partition_weights(iatom)
1026 partition_scale = 1.0_dp
1027 END IF
1028 composite_base_grid_weights(composite_row) = grid_atom%weight(ia, ir)
1029 composite_atomic_grid_weights(composite_row) = &
1030 composite_base_grid_weights(composite_row)*partition_scale
1031 composite_grid_weights(composite_row) = &
1032 composite_base_grid_weights(composite_row)* &
1033 partition_weight
1034 CALL create_native_grid_interpolation_stencil( &
1035 interpolation_stencil, smooth_rho_r(1)%pw_grid, cell, composite_point, &
1036 image_partition_atom_composite)
1037 IF (lsd) THEN
1038 CALL interpolate_native_grid_fields( &
1039 composite_smooth_rhoa, composite_smooth_drhoa(1)%array, &
1040 composite_smooth_drhoa(2)%array, composite_smooth_drhoa(3)%array, &
1041 composite_smooth_tau_a, interpolation_stencil, &
1042 composite_smooth_density_value(1), &
1043 composite_smooth_gradient_value(:, 1), &
1044 composite_smooth_kin_value(1))
1045 CALL interpolate_native_grid_fields( &
1046 composite_smooth_rhob, composite_smooth_drhob(1)%array, &
1047 composite_smooth_drhob(2)%array, composite_smooth_drhob(3)%array, &
1048 composite_smooth_tau_b, interpolation_stencil, &
1049 composite_smooth_density_value(2), &
1050 composite_smooth_gradient_value(:, 2), &
1051 composite_smooth_kin_value(2))
1052 composite_smooth_density_cache(composite_row, :) = &
1053 composite_smooth_density_value
1054 composite_smooth_gradient_cache(composite_row, :, :) = &
1055 composite_smooth_gradient_value
1056 composite_smooth_kin_cache(composite_row, :) = &
1057 composite_smooth_kin_value
1058 DO ispin = 1, 2
1059 composite_density(composite_row, ispin) = &
1060 composite_smooth_density_value(ispin)
1061 composite_grad(composite_row, :, ispin) = &
1062 composite_smooth_gradient_value(:, ispin)
1063 composite_kin(composite_row, ispin) = &
1064 composite_smooth_kin_value(ispin)
1065 IF (one_center_kind .AND. use_atom_composite_density) THEN
1066 composite_density(composite_row, ispin) = &
1067 composite_density(composite_row, ispin) + &
1068 rho_h(ia, ir, ispin) - rho_s(ia, ir, ispin)
1069 END IF
1070 IF (one_center_kind .AND. use_atom_composite_gradient) THEN
1071 DO idir = 1, 3
1072 composite_grad(composite_row, idir, ispin) = &
1073 composite_grad(composite_row, idir, ispin) + &
1074 drho_h(idir, ia, ir, ispin) - drho_s(idir, ia, ir, ispin)
1075 END DO
1076 END IF
1077 IF (one_center_kind .AND. use_atom_composite_tau) THEN
1078 composite_kin(composite_row, ispin) = &
1079 composite_kin(composite_row, ispin) + &
1080 tau_h(ia, ir, ispin) - tau_s(ia, ir, ispin)
1081 END IF
1082 END DO
1083 ELSE
1084 CALL interpolate_native_grid_fields( &
1085 composite_smooth_rho, composite_smooth_drho(1)%array, &
1086 composite_smooth_drho(2)%array, composite_smooth_drho(3)%array, &
1087 composite_smooth_tau, interpolation_stencil, &
1088 composite_smooth_density_value(1), &
1089 composite_smooth_gradient_value(:, 1), &
1090 composite_smooth_kin_value(1))
1091 composite_smooth_density_cache(composite_row, 1) = &
1092 composite_smooth_density_value(1)
1093 composite_smooth_gradient_cache(composite_row, :, 1) = &
1094 composite_smooth_gradient_value(:, 1)
1095 composite_smooth_kin_cache(composite_row, 1) = &
1096 composite_smooth_kin_value(1)
1097 composite_density(composite_row, :) = &
1098 0.5_dp*composite_smooth_density_value(1)
1099 DO idir = 1, 3
1100 composite_grad(composite_row, idir, :) = &
1101 0.5_dp*composite_smooth_gradient_value(idir, 1)
1102 END DO
1103 composite_kin(composite_row, :) = &
1104 0.5_dp*composite_smooth_kin_value(1)
1105 IF (one_center_kind .AND. use_atom_composite_density) THEN
1106 composite_density(composite_row, :) = &
1107 composite_density(composite_row, :) + &
1108 0.5_dp*(rho_h(ia, ir, 1) - rho_s(ia, ir, 1))
1109 END IF
1110 IF (one_center_kind .AND. use_atom_composite_gradient) THEN
1111 DO idir = 1, 3
1112 composite_grad(composite_row, idir, :) = &
1113 composite_grad(composite_row, idir, :) + &
1114 0.5_dp*(drho_h(idir, ia, ir, 1) - &
1115 drho_s(idir, ia, ir, 1))
1116 END DO
1117 END IF
1118 IF (one_center_kind .AND. use_atom_composite_tau) THEN
1119 composite_kin(composite_row, :) = composite_kin(composite_row, :) + &
1120 0.5_dp*(tau_h(ia, ir, 1) - &
1121 tau_s(ia, ir, 1))
1122 END IF
1123 END IF
1124 IF (atom_composite_reference .AND. nlcc) THEN
1125 nlcc_spin_factor = merge(1.0_dp, 0.5_dp, lsd)
1126 DO source_atom = 1, SIZE(particle_set)
1127 NULLIFY (gth_potential, sgp_potential)
1128 CALL get_qs_kind(my_kind_set(composite_atom_kind(source_atom)), &
1129 gth_potential=gth_potential, &
1130 sgp_potential=sgp_potential)
1131 CALL evaluate_nlcc_primitive_fields( &
1132 composite_point, particle_set(source_atom)%r, &
1133 gth_potential, sgp_potential, nlcc_density, &
1134 nlcc_gradient, nlcc_hessian)
1135 composite_density(composite_row, :) = &
1136 composite_density(composite_row, :) + &
1137 nlcc_spin_factor*nlcc_density
1138 DO idir = 1, 3
1139 composite_grad(composite_row, idir, :) = &
1140 composite_grad(composite_row, idir, :) + &
1141 nlcc_spin_factor*nlcc_gradient(idir)
1142 END DO
1143 END DO
1144 END IF
1145 END DO
1146 END DO
1147!$OMP END PARALLEL DO
1148 IF (image_partition_atom_composite) THEN
1149 DEALLOCATE (composite_descriptor_image_coords, composite_partition_image_coords)
1150 END IF
1151 cpassert(nr*na == composite_atom_end(iatom) - composite_atom_start(iatom) + 1)
1152 END IF
1153
1154 IF (.NOT. one_center_kind) cycle
1155
1156 DO ir = 1, nr
1157 IF (tau_f) THEN
1158 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
1159 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
1160 ELSE IF (gradient_f) THEN
1161 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_d, na, ir)
1162 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_d, na, ir)
1163 ELSE
1164 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, rho_d, tau_d, na, ir)
1165 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, rho_d, tau_d, na, ir)
1166 END IF
1167 END DO
1168
1169 evaluate_hard = .true.
1170 evaluate_soft = .true.
1171 skala_atom_force_h = 0.0_dp
1172 skala_atom_force_s = 0.0_dp
1173 skala_atom_virial_h = 0.0_dp
1174 skala_atom_virial_s = 0.0_dp
1175 IF (skala_atom_grid) THEN
1176 SELECT CASE (gapw_density_partition)
1177 CASE (skala_gapw_density_partition_hard_minus_soft)
1178 CONTINUE
1179 CASE (skala_gapw_density_partition_hard_only)
1180 evaluate_soft = .false.
1181 CASE (skala_gapw_density_partition_soft_only)
1182 evaluate_hard = .false.
1183 CASE (skala_gapw_density_partition_none)
1184 evaluate_hard = .false.
1185 evaluate_soft = .false.
1186 CASE DEFAULT
1187 CALL cp_abort(__location__, &
1188 "Unknown GAUXC%NATIVE_GRID_GAPW_DENSITY_PARTITION value.")
1189 END SELECT
1190 END IF
1191 IF (atom_composite_reference) THEN
1192 evaluate_hard = .false.
1193 evaluate_soft = .false.
1194 END IF
1195
1196 !-------------------!
1197 ! hard atom density !
1198 !-------------------!
1199 CALL xc_dset_zero_all(deriv_set)
1200 IF (.NOT. evaluate_hard) THEN
1201 exc_h = 0.0_dp
1202 IF (.NOT. energy_only) THEN
1203 vxc_h = 0.0_dp
1204 IF (ASSOCIATED(vxg_h)) vxg_h = 0.0_dp
1205 IF (ASSOCIATED(vtau_h)) vtau_h = 0.0_dp
1206 END IF
1207 ELSE IF (skala_atom_grid) THEN
1208 CALL skala_gapw_atom_vxc_of_r( &
1209 my_xc_section, grid_atom, para_env, particle_set(iatom)%r, &
1210 rho_h, drho_h, tau_h, weight_h, lsd, nspins, na, nr, &
1211 exc_h, vxc_h, vxg_h, vtau_h, energy_only=energy_only, &
1212 atom_force=skala_atom_force_h, atom_virial=skala_atom_virial_h)
1213 ELSE
1214 CALL vxc_of_r_new(xc_fun_section, rho_set_h, deriv_set, 1, needs, weight_h, &
1215 lsd, na, nr, exc_h, vxc_h, vxg_h, vtau_h, energy_only=energy_only, &
1216 adiabatic_rescale_factor=my_adiabatic_rescale_factor)
1217 END IF
1218 rho_atom%exc_h = rho_atom%exc_h + exc_h
1219
1220 !-------------------!
1221 ! soft atom density !
1222 !-------------------!
1223 CALL xc_dset_zero_all(deriv_set)
1224 IF (.NOT. evaluate_soft) THEN
1225 exc_s = 0.0_dp
1226 IF (.NOT. energy_only) THEN
1227 vxc_s = 0.0_dp
1228 IF (ASSOCIATED(vxg_s)) vxg_s = 0.0_dp
1229 IF (ASSOCIATED(vtau_s)) vtau_s = 0.0_dp
1230 END IF
1231 ELSE IF (skala_atom_grid) THEN
1232 CALL skala_gapw_atom_vxc_of_r( &
1233 my_xc_section, grid_atom, para_env, particle_set(iatom)%r, &
1234 rho_s, drho_s, tau_s, weight_s, lsd, nspins, na, nr, &
1235 exc_s, vxc_s, vxg_s, vtau_s, energy_only=energy_only, &
1236 atom_force=skala_atom_force_s, atom_virial=skala_atom_virial_s)
1237 ELSE
1238 CALL vxc_of_r_new(xc_fun_section, rho_set_s, deriv_set, 1, needs, weight_s, &
1239 lsd, na, nr, exc_s, vxc_s, vxg_s, vtau_s, energy_only=energy_only, &
1240 adiabatic_rescale_factor=my_adiabatic_rescale_factor)
1241 END IF
1242 rho_atom%exc_s = rho_atom%exc_s + exc_s
1243
1244 ! Add contributions to the exc energy
1245
1246 exc1 = exc1 + rho_atom%exc_h - rho_atom%exc_s
1247 IF (skala_atom_grid .AND. my_calculate_forces .AND. ASSOCIATED(force)) THEN
1248 force(ikind)%rho_elec(:, iat) = force(ikind)%rho_elec(:, iat) + &
1249 skala_atom_force_h - skala_atom_force_s
1250 END IF
1251 IF (skala_atom_grid .AND. use_virial) THEN
1252 skala_atom_virial = skala_atom_virial_h - skala_atom_virial_s
1253 DO idir = 1, 3
1254 DO jdir = 1, 3
1255 virial%pv_gapw(idir, jdir) = virial%pv_gapw(idir, jdir) + &
1256 skala_atom_virial(idir, jdir)
1257 virial%pv_virial(idir, jdir) = virial%pv_virial(idir, jdir) + &
1258 skala_atom_virial(idir, jdir)
1259 END DO
1260 END DO
1261 END IF
1262
1263 ! Integration to get the matrix elements relative to the vxc_atom
1264 ! here the products with the primitives is done: gaVxcgb
1265 ! internal transformation to get the integral in cartesian Gaussians
1266
1267 IF (.NOT. energy_only) THEN
1268 NULLIFY (int_hh, int_ss)
1269 CALL get_rho_atom(rho_atom=rho_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
1270 IF (gradient_f) THEN
1271 CALL gavxcgb_gc(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
1272 grid_atom, basis_1c, harmonics, nspins)
1273 ELSE
1274 CALL gavxcgb_nogc(vxc_h, vxc_s, int_hh, int_ss, &
1275 grid_atom, basis_1c, harmonics, nspins)
1276 END IF
1277 IF (tau_f) THEN
1278 CALL dgavtaudgb(vtau_h, vtau_s, int_hh, int_ss, tau_basis_cache, nspins)
1279 END IF
1280 END IF ! energy_only
1281 NULLIFY (r_h, r_s, dr_h, dr_s)
1282 END DO ! iat
1283
1284 IF (one_center_kind) THEN
1285 IF (tau_f) CALL release_tau_basis_cache(tau_basis_cache)
1286
1287 CALL xc_dset_release(deriv_set)
1288 CALL xc_rho_set_release(rho_set_h)
1289 CALL xc_rho_set_release(rho_set_s)
1290 END IF
1291 END DO ! ikind
1292
1293 IF (atom_composite_active) THEN
1294 ALLOCATE (composite_cross_density(composite_nflat, 2), &
1295 composite_cross_grad(composite_nflat, 3, 2), &
1296 composite_cross_kin(composite_nflat, 2))
1297 composite_cross_density = 0.0_dp
1298 composite_cross_grad = 0.0_dp
1299 composite_cross_kin = 0.0_dp
1300 composite_cross_cutoff_max = 0.0_dp
1301 IF (.NOT. direct_valence_atom_composite) THEN
1302 DO ikind = 1, SIZE(atomic_kind_set)
1303 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
1304 NULLIFY (gth_potential, sgp_potential)
1305 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
1306 gth_potential=gth_potential, harmonics=harmonics, &
1307 grid_atom=grid_atom, sgp_potential=sgp_potential, &
1308 zatom=zatom, zeff=zeff)
1309 CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
1310 IF (.NOT. native_skala_uses_one_center_kind( &
1311 paw_atom, gapw_representation, &
1312 ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential), &
1313 zeff, zatom)) cycle
1314
1315 CALL replicate_rho_atom_radial( &
1316 para_env, my_rho_atom_set, my_kind_set(ikind), atom_list, natom, nspins)
1317 nr = grid_atom%nr
1318 na = grid_atom%ng_sphere
1319 CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
1320 CALL reallocate(rho_h, 1, na, 1, nr, 1, nspins)
1321 CALL reallocate(rho_s, 1, na, 1, nr, 1, nspins)
1322 CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
1323 CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
1324 CALL reallocate(tau_h, 1, na, 1, nr, 1, nspins)
1325 CALL reallocate(tau_s, 1, na, 1, nr, 1, nspins)
1326
1327 ! The one-center density matrices are already globally reduced. Distribute the
1328 ! overlap work by target atom so that every rank constructs only its model rows.
1329 DO iat = 1, natom
1330 source_atom = atom_list(iat)
1331 rho_atom => my_rho_atom_set(source_atom)
1332 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
1333 CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s, &
1334 drho_rad_h=dr_h, drho_rad_s=dr_s, &
1335 rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
1336 rho_h = 0.0_dp
1337 rho_s = 0.0_dp
1338 drho_h = 0.0_dp
1339 drho_s = 0.0_dp
1340 CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
1341 DO ir = 1, nr
1342 CALL calc_rho_angular(grid_atom, harmonics, nspins, .true., &
1343 ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
1344 r_h_d, r_s_d, drho_h, drho_s)
1345 END DO
1346
1347 cross_cutoff = gapw_atom_grid_support_radius( &
1348 grid_atom, rho_h, rho_s, drho_h, drho_s, tau_h, tau_s)
1349 IF (cross_cutoff <= 0.0_dp) cycle
1350 composite_cross_cutoff_max = max(composite_cross_cutoff_max, cross_cutoff)
1351 image_shell = 0
1352 DO idir = 1, 3
1353 IF (cell%perd(idir) == 1) THEN
1354 image_shell(idir) = ceiling( &
1355 cross_cutoff*sqrt(sum(cell%h_inv(idir, :)**2))) + 1
1356 END IF
1357 END DO
1358
1359!$OMP PARALLEL DO DEFAULT(NONE) SCHEDULE(STATIC) &
1360!$OMP PRIVATE(base_shift, composite_row, cross_density, cross_density_spatial, &
1361!$OMP cross_displacement, cross_grad, cross_grad_spatial, cross_kin, &
1362!$OMP cross_kin_spatial, fractional, idir, image_i1, image_i2, image_i3, jdir, &
1363!$OMP image_shift, image_translation, target_atom) &
1364!$OMP SHARED(cell, composite_cross_density, composite_cross_grad, composite_cross_kin, &
1365!$OMP composite_grid_atom, composite_grid_coords, composite_nflat, cross_cutoff, &
1366!$OMP drho_h, drho_s, grid_atom, harmonics, image_shell, lsd, nspins, &
1367!$OMP particle_set, rho_h, rho_s, source_atom, tau_h, tau_s, &
1368!$OMP use_atom_composite_density, use_atom_composite_gradient, use_atom_composite_tau)
1369 DO composite_row = 1, composite_nflat
1370 target_atom = composite_grid_atom(composite_row)
1371 fractional = 0.0_dp
1372 DO idir = 1, 3
1373 DO jdir = 1, 3
1374 fractional(idir) = fractional(idir) + cell%h_inv(idir, jdir)* &
1375 (composite_grid_coords(jdir, composite_row) - &
1376 particle_set(source_atom)%r(jdir))
1377 END DO
1378 END DO
1379 DO idir = 1, 3
1380 base_shift(idir) = cell%perd(idir)*nint(fractional(idir))
1381 END DO
1382 DO image_i3 = base_shift(3) - image_shell(3), &
1383 base_shift(3) + image_shell(3)
1384 DO image_i2 = base_shift(2) - image_shell(2), &
1385 base_shift(2) + image_shell(2)
1386 DO image_i1 = base_shift(1) - image_shell(1), &
1387 base_shift(1) + image_shell(1)
1388 image_shift = [image_i1, image_i2, image_i3]
1389 IF (target_atom == source_atom .AND. &
1390 all(image_shift == 0)) cycle
1391 image_translation = matmul( &
1392 cell%hmat, real(image_shift, dp))
1393 cross_displacement = composite_grid_coords(:, composite_row) - &
1394 particle_set(source_atom)%r - &
1395 image_translation
1396 CALL interpolate_gapw_atom_grid_fields( &
1397 grid_atom, harmonics, cross_displacement, cross_cutoff, nspins, &
1398 rho_h, rho_s, drho_h, drho_s, tau_h, tau_s, &
1399 cross_density, cross_grad, cross_kin, cross_density_spatial, &
1400 cross_grad_spatial, cross_kin_spatial)
1401 IF (lsd) THEN
1402 IF (use_atom_composite_density) THEN
1403 composite_cross_density(composite_row, 1:2) = &
1404 composite_cross_density(composite_row, 1:2) + &
1405 cross_density(1:2)
1406 END IF
1407 IF (use_atom_composite_gradient) THEN
1408 composite_cross_grad(composite_row, :, 1:2) = &
1409 composite_cross_grad(composite_row, :, 1:2) + &
1410 cross_grad(:, 1:2)
1411 END IF
1412 IF (use_atom_composite_tau) THEN
1413 composite_cross_kin(composite_row, 1:2) = &
1414 composite_cross_kin(composite_row, 1:2) + cross_kin(1:2)
1415 END IF
1416 ELSE
1417 IF (use_atom_composite_density) THEN
1418 composite_cross_density(composite_row, :) = &
1419 composite_cross_density(composite_row, :) + &
1420 0.5_dp*cross_density(1)
1421 END IF
1422 IF (use_atom_composite_gradient) THEN
1423 DO idir = 1, 3
1424 composite_cross_grad(composite_row, idir, :) = &
1425 composite_cross_grad(composite_row, idir, :) + &
1426 0.5_dp*cross_grad(idir, 1)
1427 END DO
1428 END IF
1429 IF (use_atom_composite_tau) THEN
1430 composite_cross_kin(composite_row, :) = &
1431 composite_cross_kin(composite_row, :) + &
1432 0.5_dp*cross_kin(1)
1433 END IF
1434 END IF
1435 END DO
1436 END DO
1437 END DO
1438 END DO
1439!$OMP END PARALLEL DO
1440 END DO
1441
1442 CALL release_tau_basis_cache(tau_basis_cache)
1443 END DO
1444 END IF
1445
1446 IF (native_grid_diagnostics) THEN
1447 composite_cross_density_max = maxval(abs(composite_cross_density))
1448 composite_cross_grad_max = maxval(abs(composite_cross_grad))
1449 composite_cross_kin_max = maxval(abs(composite_cross_kin))
1450 CALL para_env%max(composite_cross_cutoff_max)
1451 CALL para_env%max(composite_cross_density_max)
1452 CALL para_env%max(composite_cross_grad_max)
1453 CALL para_env%max(composite_cross_kin_max)
1454 iw = cp_logger_get_default_io_unit()
1455 IF (iw > 0) THEN
1456 WRITE (unit=iw, fmt="(T2,A,4(1X,ES20.12))") &
1457 "SKALA_GPW| Atom-composite cross support/maxima", &
1458 composite_cross_cutoff_max, composite_cross_density_max, &
1459 composite_cross_grad_max, composite_cross_kin_max
1460 END IF
1461 END IF
1462 composite_density(:, :) = composite_density(:, :) + composite_cross_density(:, :)
1463 composite_grad(:, :, :) = composite_grad(:, :, :) + composite_cross_grad(:, :, :)
1464 composite_kin(:, :) = composite_kin(:, :) + composite_cross_kin(:, :)
1465 DEALLOCATE (composite_cross_density, composite_cross_grad, composite_cross_kin)
1466
1467 cpassert(all(composite_grid_weights >= 0.0_dp))
1468 atom_composite_nelec = sum(composite_grid_weights* &
1469 (composite_density(:, 1) + composite_density(:, 2)))
1470 CALL para_env%sum(atom_composite_nelec)
1471 IF (atom_composite_reference .AND. my_calculate_forces) THEN
1472 CALL skala_gapw_atom_composite_energy( &
1473 my_xc_section, para_env, composite_density, composite_grad, composite_kin, &
1474 composite_grid_coords, composite_grid_weights, composite_atomic_grid_weights, &
1475 composite_local_grid_sizes, composite_local_atom_coords, atom_composite_exc, &
1476 composite_density_grad, composite_grad_grad, composite_kin_grad, &
1477 composite_grid_coord_grad, composite_grid_weight_grad, &
1478 composite_atomic_grid_weight_grad, composite_atom_coord_grad)
1479 ALLOCATE (composite_cross_force(3, SIZE(particle_set)), &
1480 composite_explicit_force(3, SIZE(particle_set)), &
1481 composite_grid_coord_force(3, SIZE(particle_set)), &
1482 composite_model_atom_force(3, SIZE(particle_set)), &
1483 composite_moving_smooth_force(3, SIZE(particle_set)), &
1484 composite_nlcc_center_force(3, SIZE(particle_set)), &
1485 composite_nlcc_target_force(3, SIZE(particle_set)), &
1486 composite_partition_force(3, SIZE(particle_set)), &
1487 composite_partition_included(SIZE(particle_set)), &
1488 composite_partition_datom(3, SIZE(particle_set), SIZE(particle_set)), &
1489 composite_partition_dstrain(3, 3, SIZE(particle_set)))
1490 composite_cross_force = 0.0_dp
1491 composite_cross_image_virial = 0.0_dp
1492 composite_model_atom_force = 0.0_dp
1493 composite_grid_coord_force = 0.0_dp
1494 composite_moving_smooth_force = 0.0_dp
1495 composite_nlcc_center_force = 0.0_dp
1496 composite_nlcc_target_force = 0.0_dp
1497 composite_partition_force = 0.0_dp
1498 composite_explicit_virial = 0.0_dp
1499 composite_feature_virial = 0.0_dp
1500 composite_interpolation_virial = 0.0_dp
1501 composite_partition_strain_virial = 0.0_dp
1502!$OMP PARALLEL DO IF (image_partition_atom_composite) SCHEDULE(STATIC) DEFAULT(NONE) &
1503!$OMP PRIVATE(composite_local_atom, composite_row, composite_smooth_gradient_value, &
1504!$OMP iatom, idir, ispin, jdir) &
1505!$OMP SHARED(cell, composite_atom_end, composite_atom_start, composite_grad_grad, &
1506!$OMP composite_grid_coords, composite_local_atoms, composite_local_natom, &
1507!$OMP composite_smooth_drho, composite_smooth_drhoa, composite_smooth_drhob, &
1508!$OMP image_partition_atom_composite, lsd, smooth_rho_r) &
1509!$OMP REDUCTION(+:composite_feature_virial)
1510 DO composite_local_atom = 1, composite_local_natom
1511 iatom = composite_local_atoms(composite_local_atom)
1512 DO composite_row = composite_atom_start(iatom), composite_atom_end(iatom)
1513 IF (lsd) THEN
1514 DO jdir = 1, 3
1515 composite_smooth_gradient_value(jdir, 1) = &
1516 interpolate_native_grid( &
1517 composite_smooth_drhoa(jdir)%array, smooth_rho_r(1)%pw_grid, &
1518 cell, composite_grid_coords(:, composite_row), &
1519 image_partition_atom_composite)
1520 composite_smooth_gradient_value(jdir, 2) = &
1521 interpolate_native_grid( &
1522 composite_smooth_drhob(jdir)%array, smooth_rho_r(1)%pw_grid, &
1523 cell, composite_grid_coords(:, composite_row), &
1524 image_partition_atom_composite)
1525 END DO
1526 ELSE
1527 DO jdir = 1, 3
1528 composite_smooth_gradient_value(jdir, :) = 0.5_dp* &
1529 interpolate_native_grid( &
1530 composite_smooth_drho(jdir)%array, smooth_rho_r(1)%pw_grid, &
1531 cell, composite_grid_coords(:, composite_row), &
1532 image_partition_atom_composite)
1533 END DO
1534 END IF
1535 DO ispin = 1, 2
1536 DO idir = 1, 3
1537 DO jdir = 1, 3
1538 composite_feature_virial(jdir, idir) = &
1539 composite_feature_virial(jdir, idir) - &
1540 composite_grad_grad(composite_row, idir, ispin)* &
1541 composite_smooth_gradient_value(jdir, ispin)
1542 END DO
1543 END DO
1544 END DO
1545 END DO
1546 END DO
1547!$OMP END PARALLEL DO
1548!$OMP PARALLEL IF (image_partition_atom_composite) DEFAULT(NONE) &
1549!$OMP PRIVATE(composite_local_atom, composite_row, descriptor_window_adjoint, &
1550!$OMP descriptor_window_weight, gth_potential, iatom, idir, ispin, jdir, &
1551!$OMP nlcc_density, nlcc_gradient, nlcc_hessian, nlcc_spatial_derivative, &
1552!$OMP nlcc_spin_factor, partition_adjoint, composite_nlcc_center_force_local, &
1553!$OMP composite_partition_force_local, local_descriptor_datom, &
1554!$OMP local_descriptor_dstrain, local_partition_datom, local_partition_dstrain, &
1555!$OMP local_partition_weight, sgp_potential, source_atom, &
1556!$OMP spatial_derivative, target_atom, target_partition_adjoint) &
1557!$OMP REDUCTION(+:composite_interpolation_virial, composite_partition_strain_virial) &
1558!$OMP SHARED(cell, composite_atom_coord_grad, composite_atom_coords, composite_atom_end, &
1559!$OMP composite_atom_kind, composite_atom_start, composite_atomic_grid_weight_grad, &
1560!$OMP composite_atomic_grid_weights, composite_base_grid_weights, composite_density_grad, &
1561!$OMP composite_grad_grad, composite_grid_coord_force, composite_grid_coord_grad, &
1562!$OMP composite_grid_coords, composite_grid_weight_grad, composite_image_periodicity, &
1563!$OMP composite_kin_grad, composite_local_atoms, composite_local_natom, &
1564!$OMP composite_model_atom_force, composite_moving_smooth_force, &
1565!$OMP composite_nlcc_center_force, composite_nlcc_target_force, composite_partition_datom, &
1566!$OMP composite_partition_dstrain, composite_partition_force, composite_partition_included, &
1567!$OMP composite_partition_weights, composite_smooth_drho, composite_smooth_drhoa, &
1568!$OMP composite_smooth_drhob, composite_smooth_rho, composite_smooth_rhoa, &
1569!$OMP composite_smooth_rhob, composite_smooth_tau, composite_smooth_tau_a, &
1570!$OMP composite_smooth_tau_b, image_partition_atom_composite, lsd, my_kind_set, nlcc, &
1571!$OMP particle_set, smooth_rho_r)
1572 ALLOCATE (composite_nlcc_center_force_local(3, SIZE(particle_set)), &
1573 composite_partition_force_local(3, SIZE(particle_set)), &
1574 local_partition_datom(3, SIZE(particle_set)))
1575 composite_nlcc_center_force_local = 0.0_dp
1576 composite_partition_force_local = 0.0_dp
1577!$OMP DO SCHEDULE(DYNAMIC)
1578 DO composite_local_atom = 1, composite_local_natom
1579 iatom = composite_local_atoms(composite_local_atom)
1580 composite_model_atom_force(:, iatom) = &
1581 composite_atom_coord_grad(:, composite_local_atom)
1582 DO composite_row = composite_atom_start(iatom), composite_atom_end(iatom)
1583 composite_grid_coord_force(:, iatom) = &
1584 composite_grid_coord_force(:, iatom) + &
1585 composite_grid_coord_grad(:, composite_row)
1586 IF (lsd) THEN
1587 spatial_derivative = &
1588 composite_density_grad(composite_row, 1)* &
1589 interpolate_native_grid_gradient( &
1590 composite_smooth_rhoa, smooth_rho_r(1)%pw_grid, cell, &
1591 composite_grid_coords(:, composite_row), &
1592 image_partition_atom_composite) + &
1593 composite_density_grad(composite_row, 2)* &
1594 interpolate_native_grid_gradient( &
1595 composite_smooth_rhob, smooth_rho_r(1)%pw_grid, cell, &
1596 composite_grid_coords(:, composite_row), &
1597 image_partition_atom_composite) + &
1598 composite_kin_grad(composite_row, 1)* &
1599 interpolate_native_grid_gradient( &
1600 composite_smooth_tau_a, smooth_rho_r(1)%pw_grid, cell, &
1601 composite_grid_coords(:, composite_row), &
1602 image_partition_atom_composite) + &
1603 composite_kin_grad(composite_row, 2)* &
1604 interpolate_native_grid_gradient( &
1605 composite_smooth_tau_b, smooth_rho_r(1)%pw_grid, cell, &
1606 composite_grid_coords(:, composite_row), &
1607 image_partition_atom_composite)
1608 DO idir = 1, 3
1609 spatial_derivative = spatial_derivative + &
1610 composite_grad_grad(composite_row, idir, 1)* &
1611 interpolate_native_grid_gradient( &
1612 composite_smooth_drhoa(idir)%array, &
1613 smooth_rho_r(1)%pw_grid, cell, &
1614 composite_grid_coords(:, composite_row), &
1615 image_partition_atom_composite) + &
1616 composite_grad_grad(composite_row, idir, 2)* &
1617 interpolate_native_grid_gradient( &
1618 composite_smooth_drhob(idir)%array, &
1619 smooth_rho_r(1)%pw_grid, cell, &
1620 composite_grid_coords(:, composite_row), &
1621 image_partition_atom_composite)
1622 END DO
1623 ELSE
1624 spatial_derivative = 0.5_dp*sum( &
1625 composite_density_grad(composite_row, :))* &
1626 interpolate_native_grid_gradient( &
1627 composite_smooth_rho, smooth_rho_r(1)%pw_grid, cell, &
1628 composite_grid_coords(:, composite_row), &
1629 image_partition_atom_composite) + &
1630 0.5_dp*sum(composite_kin_grad(composite_row, :))* &
1631 interpolate_native_grid_gradient( &
1632 composite_smooth_tau, smooth_rho_r(1)%pw_grid, cell, &
1633 composite_grid_coords(:, composite_row), &
1634 image_partition_atom_composite)
1635 DO idir = 1, 3
1636 spatial_derivative = spatial_derivative + 0.5_dp*sum( &
1637 composite_grad_grad(composite_row, idir, :))* &
1638 interpolate_native_grid_gradient( &
1639 composite_smooth_drho(idir)%array, &
1640 smooth_rho_r(1)%pw_grid, &
1641 cell, composite_grid_coords(:, composite_row), &
1642 image_partition_atom_composite)
1643 END DO
1644 END IF
1645 DO idir = 1, 3
1646 DO jdir = 1, 3
1647 composite_interpolation_virial(idir, jdir) = &
1648 composite_interpolation_virial(idir, jdir) + &
1649 spatial_derivative(idir)*( &
1650 composite_grid_coords(jdir, composite_row) - &
1651 particle_set(iatom)%r(jdir))
1652 END DO
1653 END DO
1654 composite_moving_smooth_force(:, iatom) = &
1655 composite_moving_smooth_force(:, iatom) + spatial_derivative
1656 IF (nlcc) THEN
1657 nlcc_spin_factor = merge(1.0_dp, 0.5_dp, lsd)
1658 DO source_atom = 1, SIZE(particle_set)
1659 NULLIFY (gth_potential, sgp_potential)
1660 CALL get_qs_kind(my_kind_set(composite_atom_kind(source_atom)), &
1661 gth_potential=gth_potential, &
1662 sgp_potential=sgp_potential)
1663 CALL evaluate_nlcc_primitive_fields( &
1664 composite_grid_coords(:, composite_row), &
1665 particle_set(source_atom)%r, gth_potential, sgp_potential, &
1666 nlcc_density, nlcc_gradient, nlcc_hessian)
1667 nlcc_spatial_derivative = 0.0_dp
1668 DO ispin = 1, 2
1669 nlcc_spatial_derivative = nlcc_spatial_derivative + &
1670 nlcc_spin_factor*composite_density_grad(composite_row, ispin)* &
1671 nlcc_gradient
1672 DO idir = 1, 3
1673 DO jdir = 1, 3
1674 nlcc_spatial_derivative(jdir) = &
1675 nlcc_spatial_derivative(jdir) + nlcc_spin_factor* &
1676 composite_grad_grad(composite_row, idir, ispin)* &
1677 nlcc_hessian(idir, jdir)
1678 END DO
1679 END DO
1680 END DO
1681 composite_nlcc_target_force(:, iatom) = &
1682 composite_nlcc_target_force(:, iatom) + nlcc_spatial_derivative
1683 composite_nlcc_center_force_local(:, source_atom) = &
1684 composite_nlcc_center_force_local(:, source_atom) - nlcc_spatial_derivative
1685 END DO
1686 END IF
1687 IF (image_partition_atom_composite) THEN
1688 CALL periodic_atom_image_partition( &
1689 composite_grid_coords(:, composite_row), composite_atom_coords, cell, &
1690 iatom, local_partition_weight, local_partition_datom, &
1691 local_partition_dstrain, composite_image_periodicity)
1692 CALL periodic_atom_image_partition( &
1693 composite_grid_coords(:, composite_row), &
1694 composite_atom_coords(:, iatom:iatom), cell, 1, &
1695 descriptor_window_weight, local_descriptor_datom, &
1696 local_descriptor_dstrain, composite_image_periodicity)
1697 ! Its atom derivative cancels against the moving target grid; periodic
1698 ! image strain remains an explicit contribution to the virial.
1699 target_partition_adjoint = composite_base_grid_weights(composite_row)* &
1700 composite_grid_weight_grad(composite_row)
1701 descriptor_window_adjoint = composite_base_grid_weights(composite_row)* &
1702 composite_atomic_grid_weight_grad(composite_row)* &
1703 smooth_partition_atomic_weight_scale_derivative( &
1704 descriptor_window_weight)
1705 DO target_atom = 1, SIZE(particle_set)
1706 composite_partition_force_local(:, target_atom) = &
1707 composite_partition_force_local(:, target_atom) + &
1708 target_partition_adjoint*local_partition_datom(:, target_atom)
1709 END DO
1710 composite_partition_force_local(:, iatom) = &
1711 composite_partition_force_local(:, iatom) - target_partition_adjoint* &
1712 sum(local_partition_datom, dim=2)
1713 composite_partition_strain_virial = &
1714 composite_partition_strain_virial - target_partition_adjoint* &
1715 local_partition_dstrain - descriptor_window_adjoint* &
1716 local_descriptor_dstrain
1717 ELSE
1718 CALL skala_gpw_smooth_partition_derivatives( &
1719 composite_grid_coords(:, composite_row), composite_atom_coords, cell, &
1720 composite_partition_weights, composite_partition_included, &
1721 composite_partition_datom, composite_partition_dstrain)
1722 partition_adjoint = composite_grid_weight_grad(composite_row)* &
1723 composite_atomic_grid_weights(composite_row)
1724 DO target_atom = 1, SIZE(particle_set)
1725 composite_partition_force_local(:, target_atom) = &
1726 composite_partition_force_local(:, target_atom) + &
1727 partition_adjoint* &
1728 composite_partition_datom(:, target_atom, iatom)
1729 END DO
1730 composite_partition_force_local(:, iatom) = &
1731 composite_partition_force_local(:, iatom) - partition_adjoint* &
1732 sum(composite_partition_datom(:, :, iatom), dim=2)
1733 END IF
1734 END DO
1735 END DO
1736!$OMP END DO
1737!$OMP CRITICAL(skala_atom_composite_force_reduction)
1738 composite_nlcc_center_force(:, :) = composite_nlcc_center_force(:, :) + &
1739 composite_nlcc_center_force_local
1740 composite_partition_force(:, :) = composite_partition_force(:, :) + &
1741 composite_partition_force_local
1742!$OMP END CRITICAL(skala_atom_composite_force_reduction)
1743 DEALLOCATE (composite_nlcc_center_force_local, composite_partition_force_local, &
1744 local_partition_datom)
1745!$OMP END PARALLEL
1746 ! The target atom grids can overlap augmentation regions of other atoms
1747 ! and periodic images. Differentiate the same discrete interpolation used
1748 ! in the forward composite fields, including the explicit image strain.
1749 IF (.NOT. direct_valence_atom_composite) THEN
1750 DO ikind = 1, SIZE(atomic_kind_set)
1751 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
1752 NULLIFY (gth_potential, sgp_potential)
1753 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
1754 gth_potential=gth_potential, harmonics=harmonics, &
1755 grid_atom=grid_atom, sgp_potential=sgp_potential, &
1756 zatom=zatom, zeff=zeff)
1757 CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
1758 IF (.NOT. native_skala_uses_one_center_kind( &
1759 paw_atom, gapw_representation, &
1760 ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential), &
1761 zeff, zatom)) cycle
1762
1763 nr = grid_atom%nr
1764 na = grid_atom%ng_sphere
1765 CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
1766 CALL reallocate(rho_h, 1, na, 1, nr, 1, nspins)
1767 CALL reallocate(rho_s, 1, na, 1, nr, 1, nspins)
1768 CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
1769 CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
1770 CALL reallocate(tau_h, 1, na, 1, nr, 1, nspins)
1771 CALL reallocate(tau_s, 1, na, 1, nr, 1, nspins)
1772
1773 DO iat = 1, natom
1774 source_atom = atom_list(iat)
1775 rho_atom => my_rho_atom_set(source_atom)
1776 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
1777 CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s, &
1778 drho_rad_h=dr_h, drho_rad_s=dr_s, &
1779 rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
1780 rho_h = 0.0_dp
1781 rho_s = 0.0_dp
1782 drho_h = 0.0_dp
1783 drho_s = 0.0_dp
1784 CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
1785 DO ir = 1, nr
1786 CALL calc_rho_angular(grid_atom, harmonics, nspins, .true., &
1787 ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
1788 r_h_d, r_s_d, drho_h, drho_s)
1789 END DO
1790
1791 cross_cutoff = gapw_atom_grid_support_radius( &
1792 grid_atom, rho_h, rho_s, drho_h, drho_s, tau_h, tau_s)
1793 IF (cross_cutoff <= 0.0_dp) cycle
1794 image_shell = 0
1795 DO idir = 1, 3
1796 IF (cell%perd(idir) == 1) THEN
1797 image_shell(idir) = ceiling( &
1798 cross_cutoff*sqrt(sum(cell%h_inv(idir, :)**2))) + 1
1799 END IF
1800 END DO
1801
1802!$OMP PARALLEL DEFAULT(NONE) &
1803!$OMP PRIVATE(base_shift, composite_cross_force_local, composite_cross_image_virial_local, &
1804!$OMP composite_row, cross_density, cross_density_adjoint, cross_density_spatial, &
1805!$OMP cross_displacement, cross_grad, cross_grad_adjoint, cross_grad_spatial, &
1806!$OMP cross_kin, cross_kin_adjoint, cross_kin_spatial, cross_spatial_derivative, &
1807!$OMP fractional, idir, image_i1, image_i2, image_i3, image_shift, image_translation, &
1808!$OMP ispin, jdir, target_atom) &
1809!$OMP SHARED(cell, composite_cross_force, composite_cross_image_virial, &
1810!$OMP composite_density_grad, composite_grad_grad, composite_grid_atom, &
1811!$OMP composite_grid_coords, composite_kin_grad, composite_nflat, cross_cutoff, &
1812!$OMP drho_h, drho_s, grid_atom, harmonics, image_shell, lsd, nspins, &
1813!$OMP particle_set, rho_h, rho_s, source_atom, tau_h, tau_s, &
1814!$OMP use_atom_composite_density, use_atom_composite_gradient, use_atom_composite_tau)
1815 ALLOCATE (composite_cross_force_local(3, SIZE(particle_set)))
1816 composite_cross_force_local = 0.0_dp
1817 composite_cross_image_virial_local = 0.0_dp
1818!$OMP DO SCHEDULE(STATIC)
1819 DO composite_row = 1, composite_nflat
1820 target_atom = composite_grid_atom(composite_row)
1821 IF (lsd) THEN
1822 cross_density_adjoint = 0.0_dp
1823 cross_grad_adjoint = 0.0_dp
1824 cross_kin_adjoint = 0.0_dp
1825 IF (use_atom_composite_density) THEN
1826 cross_density_adjoint(1:2) = &
1827 composite_density_grad(composite_row, 1:2)
1828 END IF
1829 IF (use_atom_composite_gradient) THEN
1830 cross_grad_adjoint(:, 1:2) = &
1831 composite_grad_grad(composite_row, :, 1:2)
1832 END IF
1833 IF (use_atom_composite_tau) THEN
1834 cross_kin_adjoint(1:2) = &
1835 composite_kin_grad(composite_row, 1:2)
1836 END IF
1837 ELSE
1838 cross_density_adjoint = 0.0_dp
1839 cross_grad_adjoint = 0.0_dp
1840 cross_kin_adjoint = 0.0_dp
1841 IF (use_atom_composite_density) THEN
1842 cross_density_adjoint(1) = 0.5_dp* &
1843 sum(composite_density_grad(composite_row, :))
1844 END IF
1845 IF (use_atom_composite_gradient) THEN
1846 DO idir = 1, 3
1847 cross_grad_adjoint(idir, 1) = 0.5_dp* &
1848 sum(composite_grad_grad(composite_row, idir, :))
1849 END DO
1850 END IF
1851 IF (use_atom_composite_tau) THEN
1852 cross_kin_adjoint(1) = 0.5_dp* &
1853 sum(composite_kin_grad(composite_row, :))
1854 END IF
1855 END IF
1856
1857 fractional = 0.0_dp
1858 DO idir = 1, 3
1859 DO jdir = 1, 3
1860 fractional(idir) = fractional(idir) + cell%h_inv(idir, jdir)* &
1861 (composite_grid_coords(jdir, composite_row) - &
1862 particle_set(source_atom)%r(jdir))
1863 END DO
1864 END DO
1865 DO idir = 1, 3
1866 base_shift(idir) = cell%perd(idir)*nint(fractional(idir))
1867 END DO
1868 DO image_i3 = base_shift(3) - image_shell(3), &
1869 base_shift(3) + image_shell(3)
1870 DO image_i2 = base_shift(2) - image_shell(2), &
1871 base_shift(2) + image_shell(2)
1872 DO image_i1 = base_shift(1) - image_shell(1), &
1873 base_shift(1) + image_shell(1)
1874 image_shift = [image_i1, image_i2, image_i3]
1875 IF (target_atom == source_atom .AND. &
1876 all(image_shift == 0)) cycle
1877 image_translation = matmul( &
1878 cell%hmat, real(image_shift, dp))
1879 cross_displacement = &
1880 composite_grid_coords(:, composite_row) - &
1881 particle_set(source_atom)%r - image_translation
1882 CALL interpolate_gapw_atom_grid_fields( &
1883 grid_atom, harmonics, cross_displacement, cross_cutoff, &
1884 nspins, rho_h, rho_s, drho_h, drho_s, tau_h, tau_s, &
1885 cross_density, cross_grad, cross_kin, cross_density_spatial, &
1886 cross_grad_spatial, cross_kin_spatial)
1887 cross_spatial_derivative = 0.0_dp
1888 DO ispin = 1, nspins
1889 DO idir = 1, 3
1890 cross_spatial_derivative(idir) = &
1891 cross_spatial_derivative(idir) + &
1892 cross_density_adjoint(ispin)* &
1893 cross_density_spatial(idir, ispin) + &
1894 cross_kin_adjoint(ispin)* &
1895 cross_kin_spatial(idir, ispin)
1896 DO jdir = 1, 3
1897 cross_spatial_derivative(idir) = &
1898 cross_spatial_derivative(idir) + &
1899 cross_grad_adjoint(jdir, ispin)* &
1900 cross_grad_spatial(jdir, idir, ispin)
1901 END DO
1902 END DO
1903 END DO
1904 composite_cross_force_local(:, target_atom) = &
1905 composite_cross_force_local(:, target_atom) + &
1906 cross_spatial_derivative
1907 composite_cross_force_local(:, source_atom) = &
1908 composite_cross_force_local(:, source_atom) - &
1909 cross_spatial_derivative
1910 DO idir = 1, 3
1911 DO jdir = 1, 3
1912 composite_cross_image_virial_local(idir, jdir) = &
1913 composite_cross_image_virial_local(idir, jdir) + &
1914 cross_spatial_derivative(idir)*image_translation(jdir)
1915 END DO
1916 END DO
1917 END DO
1918 END DO
1919 END DO
1920 END DO
1921!$OMP END DO
1922!$OMP CRITICAL(skala_atom_composite_cross_reduction)
1923 composite_cross_force(:, :) = &
1924 composite_cross_force(:, :) + composite_cross_force_local(:, :)
1925 composite_cross_image_virial = composite_cross_image_virial + &
1926 composite_cross_image_virial_local
1927!$OMP END CRITICAL(skala_atom_composite_cross_reduction)
1928 DEALLOCATE (composite_cross_force_local)
1929!$OMP END PARALLEL
1930 END DO
1931 CALL release_tau_basis_cache(tau_basis_cache)
1932 END DO
1933 END IF
1934
1935 composite_explicit_force(:, :) = composite_model_atom_force(:, :) + &
1936 composite_grid_coord_force(:, :) + &
1937 composite_moving_smooth_force(:, :) + &
1938 composite_cross_force(:, :) + &
1939 composite_nlcc_center_force(:, :) + &
1940 composite_nlcc_target_force(:, :) + &
1941 composite_partition_force(:, :)
1942 ! CP2K stores +dE/dR in the electronic force components, while the
1943 ! virial is -dE/dstrain. Model coordinates, atom-grid centers,
1944 ! NLCC centers, and partition centers move affinely with their atoms.
1945 ! The smooth-field interpolation force is excluded here: its affine
1946 ! response is already in the PW stress and its non-affine local-grid
1947 ! correction is composite_interpolation_virial.
1948 DO iatom = 1, SIZE(particle_set)
1949 DO idir = 1, 3
1950 DO jdir = 1, 3
1951 composite_explicit_virial(idir, jdir) = &
1952 composite_explicit_virial(idir, jdir) - ( &
1953 composite_model_atom_force(idir, iatom) + &
1954 composite_grid_coord_force(idir, iatom) + &
1955 composite_cross_force(idir, iatom) + &
1956 composite_nlcc_center_force(idir, iatom) + &
1957 composite_nlcc_target_force(idir, iatom) + &
1958 composite_partition_force(idir, iatom))*particle_set(iatom)%r(jdir)
1959 END DO
1960 END DO
1961 END DO
1962 composite_explicit_virial = composite_explicit_virial + &
1963 composite_partition_strain_virial + &
1964 composite_cross_image_virial
1965 IF (ASSOCIATED(force)) THEN
1966 DO iatom = 1, SIZE(particle_set)
1967 ikind = composite_atom_kind(iatom)
1968 iat = composite_atom_kind_index(iatom)
1969 cpassert(ikind > 0 .AND. iat > 0)
1970 force(ikind)%rho_elec(:, iat) = force(ikind)%rho_elec(:, iat) + &
1971 composite_explicit_force(:, iatom)
1972 END DO
1973 END IF
1974 IF (use_virial) THEN
1975 ! The local radial vectors of the atom-centered quadrature do not
1976 ! deform with the periodic cell. Correct the standard PW response,
1977 ! which follows fixed fractional coordinates, by the corresponding
1978 ! non-affine interpolation derivative.
1979 virial%pv_xc = composite_feature_virial - composite_interpolation_virial
1980 virial%pv_gapw = virial%pv_gapw + composite_explicit_virial
1981 virial%pv_virial = virial%pv_virial + composite_explicit_virial
1982 END IF
1983 IF (native_grid_diagnostics) THEN
1984 CALL para_env%sum(composite_cross_force)
1985 CALL para_env%sum(composite_cross_image_virial)
1986 CALL para_env%sum(composite_model_atom_force)
1987 CALL para_env%sum(composite_grid_coord_force)
1988 CALL para_env%sum(composite_moving_smooth_force)
1989 CALL para_env%sum(composite_nlcc_center_force)
1990 CALL para_env%sum(composite_nlcc_target_force)
1991 CALL para_env%sum(composite_partition_force)
1992 CALL para_env%sum(composite_explicit_force)
1993 CALL para_env%sum(composite_explicit_virial)
1994 CALL para_env%sum(composite_feature_virial)
1995 CALL para_env%sum(composite_interpolation_virial)
1996 iw = cp_logger_get_default_io_unit()
1997 IF (iw > 0) THEN
1998 DO iatom = 1, SIZE(particle_set)
1999 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES20.12))") &
2000 "SKALA_GPW| Atom-composite model-atom force", iatom, &
2001 composite_model_atom_force(:, iatom)
2002 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES20.12))") &
2003 "SKALA_GPW| Atom-composite grid-coordinate force", iatom, &
2004 composite_grid_coord_force(:, iatom)
2005 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES20.12))") &
2006 "SKALA_GPW| Atom-composite moving-smooth force", iatom, &
2007 composite_moving_smooth_force(:, iatom)
2008 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES20.12))") &
2009 "SKALA_GPW| Atom-composite cross-region force", iatom, &
2010 composite_cross_force(:, iatom)
2011 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES20.12))") &
2012 "SKALA_GPW| Atom-composite NLCC-center force", iatom, &
2013 composite_nlcc_center_force(:, iatom)
2014 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES20.12))") &
2015 "SKALA_GPW| Atom-composite NLCC-target force", iatom, &
2016 composite_nlcc_target_force(:, iatom)
2017 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES20.12))") &
2018 "SKALA_GPW| Atom-composite partition force", iatom, &
2019 composite_partition_force(:, iatom)
2020 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES20.12))") &
2021 "SKALA_GPW| Atom-composite explicit force", iatom, &
2022 composite_explicit_force(:, iatom)
2023 END DO
2024 WRITE (unit=iw, fmt="(T2,A)") &
2025 "SKALA_GPW| Atom-composite explicit virial"
2026 DO idir = 1, 3
2027 WRITE (unit=iw, fmt="(T2,A,1X,3ES20.10)") &
2028 "SKALA_GPW|", composite_explicit_virial(idir, :)
2029 END DO
2030 WRITE (unit=iw, fmt="(T2,A)") &
2031 "SKALA_GPW| Atom-composite cross-image virial"
2032 DO idir = 1, 3
2033 WRITE (unit=iw, fmt="(T2,A,1X,3ES20.10)") &
2034 "SKALA_GPW|", composite_cross_image_virial(idir, :)
2035 END DO
2036 WRITE (unit=iw, fmt="(T2,A)") &
2037 "SKALA_GPW| Atom-composite feature virial"
2038 DO idir = 1, 3
2039 WRITE (unit=iw, fmt="(T2,A,1X,3ES20.10)") &
2040 "SKALA_GPW|", composite_feature_virial(idir, :)
2041 END DO
2042 WRITE (unit=iw, fmt="(T2,A)") &
2043 "SKALA_GPW| Atom-composite interpolation virial"
2044 DO idir = 1, 3
2045 WRITE (unit=iw, fmt="(T2,A,1X,3ES20.10)") &
2046 "SKALA_GPW|", composite_interpolation_virial(idir, :)
2047 END DO
2048 END IF
2049 END IF
2050 DEALLOCATE (composite_atom_coord_grad, composite_atomic_grid_weight_grad, &
2051 composite_cross_force, &
2052 composite_explicit_force, composite_grid_coord_force, &
2053 composite_grid_coord_grad, composite_grid_weight_grad, &
2054 composite_model_atom_force, composite_moving_smooth_force, &
2055 composite_nlcc_center_force, &
2056 composite_nlcc_target_force, &
2057 composite_partition_datom, composite_partition_dstrain, &
2058 composite_partition_force, composite_partition_included)
2059 ELSE
2060 CALL skala_gapw_atom_composite_energy( &
2061 my_xc_section, para_env, composite_density, composite_grad, composite_kin, &
2062 composite_grid_coords, composite_grid_weights, composite_atomic_grid_weights, &
2063 composite_local_grid_sizes, composite_local_atom_coords, atom_composite_exc, &
2064 composite_density_grad, composite_grad_grad, composite_kin_grad)
2065 END IF
2066 composite_pw_nflat = product(smooth_rho_r(1)%pw_grid%npts)
2067 adjoint_nchannels = merge(2, 1, lsd)
2068 ALLOCATE (smooth_density_adjoint_storage(composite_pw_nflat, adjoint_nchannels), &
2069 smooth_grad_adjoint_storage(composite_pw_nflat, 3, adjoint_nchannels), &
2070 smooth_kin_adjoint_storage(composite_pw_nflat, adjoint_nchannels))
2071 smooth_density_adjoint_storage = 0.0_dp
2072 smooth_grad_adjoint_storage = 0.0_dp
2073 smooth_kin_adjoint_storage = 0.0_dp
2074 CALL build_native_grid_adjoint_bins( &
2075 smooth_rho_r(1)%pw_grid, cell, composite_grid_coords, &
2076 image_partition_atom_composite, adjoint_tile_count, adjoint_bin_offsets, &
2077 adjoint_bin_rows)
2078 adjoint_nbins = SIZE(adjoint_bin_offsets) - 1
2079!$OMP PARALLEL DO SCHEDULE(DYNAMIC) DEFAULT(NONE) &
2080!$OMP PRIVATE(adjoint_entry, composite_row, composite_smooth_density_adjoint_value, &
2081!$OMP composite_smooth_gradient_adjoint_value, composite_smooth_kin_adjoint_value, &
2082!$OMP adjoint_tile_lower, adjoint_tile_upper, interpolation_stencil) &
2083!$OMP SHARED(adjoint_bin_offsets, adjoint_bin_rows, adjoint_nbins, adjoint_nchannels, &
2084!$OMP adjoint_tile_count, cell, composite_density_grad, composite_grad_grad, &
2085!$OMP composite_grid_coords, composite_kin_grad, image_partition_atom_composite, lsd, &
2086!$OMP smooth_density_adjoint_storage, smooth_grad_adjoint_storage, &
2087!$OMP smooth_kin_adjoint_storage, smooth_rho_r)
2088 DO adjoint_bin = 1, adjoint_nbins
2089 CALL native_grid_adjoint_tile_bounds( &
2090 smooth_rho_r(1)%pw_grid, adjoint_bin, adjoint_tile_count, &
2091 adjoint_tile_lower, adjoint_tile_upper)
2092 DO adjoint_entry = adjoint_bin_offsets(adjoint_bin), &
2093 adjoint_bin_offsets(adjoint_bin + 1) - 1
2094 composite_row = adjoint_bin_rows(adjoint_entry)
2095 CALL create_native_grid_interpolation_stencil( &
2096 interpolation_stencil, smooth_rho_r(1)%pw_grid, cell, &
2097 composite_grid_coords(:, composite_row), image_partition_atom_composite)
2098 IF (lsd) THEN
2099 composite_smooth_density_adjoint_value = &
2100 composite_density_grad(composite_row, :)
2101 composite_smooth_gradient_adjoint_value = &
2102 composite_grad_grad(composite_row, :, :)
2103 composite_smooth_kin_adjoint_value = composite_kin_grad(composite_row, :)
2104 ELSE
2105 composite_smooth_density_adjoint_value = 0.0_dp
2106 composite_smooth_gradient_adjoint_value = 0.0_dp
2107 composite_smooth_kin_adjoint_value = 0.0_dp
2108 composite_smooth_density_adjoint_value(1) = &
2109 sum(composite_density_grad(composite_row, :))
2110 composite_smooth_gradient_adjoint_value(:, 1) = &
2111 sum(composite_grad_grad(composite_row, :, :), dim=2)
2112 composite_smooth_kin_adjoint_value(1) = &
2113 sum(composite_kin_grad(composite_row, :))
2114 END IF
2115 CALL add_native_grid_fields_adjoint_tile( &
2116 smooth_density_adjoint_storage, smooth_grad_adjoint_storage, &
2117 smooth_kin_adjoint_storage, smooth_rho_r(1)%pw_grid, interpolation_stencil, &
2118 composite_smooth_density_adjoint_value, &
2119 composite_smooth_gradient_adjoint_value, &
2120 composite_smooth_kin_adjoint_value, adjoint_nchannels, &
2121 adjoint_tile_lower, adjoint_tile_upper)
2122 END DO
2123 END DO
2124!$OMP END PARALLEL DO
2125 DEALLOCATE (adjoint_bin_offsets, adjoint_bin_rows)
2126 smooth_input_contraction = 0.0_dp
2127!$OMP PARALLEL DO SCHEDULE(STATIC) REDUCTION(+:smooth_input_contraction) DEFAULT(NONE) &
2128!$OMP PRIVATE(composite_smooth_density_value, composite_smooth_gradient_value, &
2129!$OMP composite_smooth_kin_value, idir, ispin) &
2130!$OMP SHARED(composite_density_grad, composite_grad_grad, composite_kin_grad, composite_nflat, &
2131!$OMP composite_smooth_density_cache, composite_smooth_gradient_cache, &
2132!$OMP composite_smooth_kin_cache, lsd)
2133 DO composite_row = 1, composite_nflat
2134 composite_smooth_density_value = composite_smooth_density_cache(composite_row, :)
2135 composite_smooth_gradient_value = &
2136 composite_smooth_gradient_cache(composite_row, :, :)
2137 composite_smooth_kin_value = composite_smooth_kin_cache(composite_row, :)
2138 DO ispin = 1, 2
2139 IF (lsd) THEN
2140 smooth_input_contraction = smooth_input_contraction + &
2141 composite_density_grad(composite_row, ispin)* &
2142 composite_smooth_density_value(ispin) + &
2143 composite_kin_grad(composite_row, ispin)* &
2144 composite_smooth_kin_value(ispin)
2145 DO idir = 1, 3
2146 smooth_input_contraction = smooth_input_contraction + &
2147 composite_grad_grad(composite_row, idir, ispin)* &
2148 composite_smooth_gradient_value(idir, ispin)
2149 END DO
2150 ELSE
2151 smooth_input_contraction = smooth_input_contraction + 0.5_dp*( &
2152 composite_density_grad(composite_row, ispin)* &
2153 composite_smooth_density_value(1) + &
2154 composite_kin_grad(composite_row, ispin)* &
2155 composite_smooth_kin_value(1))
2156 DO idir = 1, 3
2157 smooth_input_contraction = smooth_input_contraction + 0.5_dp* &
2158 composite_grad_grad(composite_row, idir, ispin)* &
2159 composite_smooth_gradient_value(idir, 1)
2160 END DO
2161 END IF
2162 END DO
2163 END DO
2164!$OMP END PARALLEL DO
2165 smooth_density_adjoint => smooth_density_adjoint_storage
2166 smooth_grad_adjoint => smooth_grad_adjoint_storage
2167 smooth_kin_adjoint => smooth_kin_adjoint_storage
2168 ! The interpolation transpose still uses CP2K's global FFT-grid layout. Reduce only
2169 ! this PW adjoint; atom-grid feature rows and their model derivatives stay rank-local.
2170 CALL para_env%sum(smooth_density_adjoint)
2171 CALL para_env%sum(smooth_grad_adjoint)
2172 CALL para_env%sum(smooth_kin_adjoint)
2173 CALL para_env%sum(smooth_input_contraction)
2174 CALL build_vxc_from_feature_grads( &
2175 smooth_vxc_rho, smooth_vxc_tau, smooth_rho_r, auxbas_pw_pool, &
2176 smooth_density_adjoint, smooth_grad_adjoint, smooth_kin_adjoint, &
2177 xc_deriv_method_id, global_grid_layout=.true.)
2178 NULLIFY (smooth_density_adjoint, smooth_grad_adjoint, smooth_kin_adjoint)
2179 DEALLOCATE (smooth_density_adjoint_storage, smooth_grad_adjoint_storage, &
2180 smooth_kin_adjoint_storage)
2181 smooth_grid_contraction = 0.0_dp
2182 DO ispin = 1, nspins
2183 smooth_grid_contraction = smooth_grid_contraction + smooth_rho_r(1)%pw_grid%dvol* &
2184 (sum(smooth_vxc_rho(ispin)%array* &
2185 smooth_rho_r(ispin)%array) + &
2186 sum(smooth_vxc_tau(ispin)%array* &
2187 smooth_tau_r(ispin)%array))
2188 IF (atom_composite_reference) THEN
2189 cpassert(PRESENT(composite_vxc_rho))
2190 cpassert(PRESENT(composite_vxc_tau))
2191 cpassert(ASSOCIATED(composite_vxc_rho))
2192 cpassert(ASSOCIATED(composite_vxc_tau))
2193 cpassert(SIZE(composite_vxc_rho) == nspins)
2194 cpassert(SIZE(composite_vxc_tau) == nspins)
2195 CALL pw_axpy(smooth_vxc_rho(ispin), composite_vxc_rho(ispin), 1.0_dp)
2196 CALL pw_axpy(smooth_vxc_tau(ispin), composite_vxc_tau(ispin), 1.0_dp)
2197 END IF
2198 CALL auxbas_pw_pool%give_back_pw(smooth_vxc_rho(ispin))
2199 CALL auxbas_pw_pool%give_back_pw(smooth_vxc_tau(ispin))
2200 END DO
2201 CALL para_env%sum(smooth_grid_contraction)
2202 DEALLOCATE (smooth_vxc_rho, smooth_vxc_tau)
2203
2204 one_center_field_contraction = 0.0_dp
2205 one_center_matrix_contraction = 0.0_dp
2206 one_center_density_field_contraction = 0.0_dp
2207 one_center_density_matrix_contraction = 0.0_dp
2208 one_center_gradient_field_contraction = 0.0_dp
2209 one_center_gradient_matrix_contraction = 0.0_dp
2210 one_center_rho_grad_field_contraction = 0.0_dp
2211 one_center_rho_grad_matrix_contraction = 0.0_dp
2212 one_center_tau_field_contraction = 0.0_dp
2213 one_center_tau_matrix_contraction = 0.0_dp
2214 IF (.NOT. direct_valence_atom_composite) THEN
2215 DO ikind = 1, SIZE(atomic_kind_set)
2216 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
2217 NULLIFY (gth_potential, sgp_potential)
2218 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
2219 gth_potential=gth_potential, harmonics=harmonics, &
2220 grid_atom=grid_atom, sgp_potential=sgp_potential, &
2221 zatom=zatom, zeff=zeff)
2222 CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
2223 IF (.NOT. native_skala_uses_one_center_kind( &
2224 paw_atom, gapw_representation, &
2225 ASSOCIATED(gth_potential) .OR. ASSOCIATED(sgp_potential), &
2226 zeff, zatom)) cycle
2227
2228 nr = grid_atom%nr
2229 na = grid_atom%ng_sphere
2230 CALL reallocate(rho_h, 1, na, 1, nr, 1, nspins)
2231 CALL reallocate(rho_s, 1, na, 1, nr, 1, nspins)
2232 CALL reallocate(vxc_h, 1, na, 1, nr, 1, nspins)
2233 CALL reallocate(vxc_s, 1, na, 1, nr, 1, nspins)
2234 CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
2235 CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
2236 CALL reallocate(vxg_h, 1, 3, 1, na, 1, nr, 1, nspins)
2237 CALL reallocate(vxg_s, 1, 3, 1, na, 1, nr, 1, nspins)
2238 CALL reallocate(tau_h, 1, na, 1, nr, 1, nspins)
2239 CALL reallocate(tau_s, 1, na, 1, nr, 1, nspins)
2240 CALL reallocate(vtau_h, 1, na, 1, nr, 1, nspins)
2241 CALL reallocate(vtau_s, 1, na, 1, nr, 1, nspins)
2242 CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
2243
2244 bo = get_limit(natom, para_env%num_pe, para_env%mepos)
2245 DO iat = 1, natom
2246 iatom = atom_list(iat)
2247 source_matrix_local = iat >= bo(1) .AND. iat <= bo(2)
2248 rho_atom => my_rho_atom_set(iatom)
2249 NULLIFY (cpc_h, cpc_s, r_h, r_s, dr_h, dr_s, r_h_d, r_s_d, int_hh, int_ss)
2250 CALL get_rho_atom(rho_atom=rho_atom, cpc_h=cpc_h, cpc_s=cpc_s, &
2251 rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
2252 drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d, &
2253 ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
2254 rho_h = 0.0_dp
2255 rho_s = 0.0_dp
2256 drho_h = 0.0_dp
2257 drho_s = 0.0_dp
2258 CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
2259 DO ir = 1, nr
2260 CALL calc_rho_angular(grid_atom, harmonics, nspins, .true., &
2261 ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
2262 r_h_d, r_s_d, drho_h, drho_s)
2263 END DO
2264
2265 vxc_h = 0.0_dp
2266 vxc_s = 0.0_dp
2267 vxg_h = 0.0_dp
2268 vxg_s = 0.0_dp
2269 vtau_h = 0.0_dp
2270 vtau_s = 0.0_dp
2271 IF (source_matrix_local) THEN
2272 composite_row = composite_atom_start(iatom) - 1
2273 DO ir = 1, nr
2274 DO ia = 1, na
2275 composite_row = composite_row + 1
2276 IF (lsd) THEN
2277 IF (use_atom_composite_density) THEN
2278 vxc_h(ia, ir, 1:2) = composite_density_grad(composite_row, 1:2)
2279 vxc_s(ia, ir, 1:2) = composite_density_grad(composite_row, 1:2)
2280 END IF
2281 IF (use_atom_composite_gradient) THEN
2282 DO idir = 1, 3
2283 vxg_h(idir, ia, ir, 1:2) = &
2284 composite_grad_grad(composite_row, idir, 1:2)
2285 vxg_s(idir, ia, ir, 1:2) = &
2286 composite_grad_grad(composite_row, idir, 1:2)
2287 END DO
2288 END IF
2289 IF (use_atom_composite_tau) THEN
2290 vtau_h(ia, ir, 1:2) = composite_kin_grad(composite_row, 1:2)
2291 vtau_s(ia, ir, 1:2) = composite_kin_grad(composite_row, 1:2)
2292 END IF
2293 ELSE
2294 IF (use_atom_composite_density) THEN
2295 vxc_h(ia, ir, 1) = 0.5_dp* &
2296 sum(composite_density_grad(composite_row, :))
2297 vxc_s(ia, ir, 1) = vxc_h(ia, ir, 1)
2298 END IF
2299 IF (use_atom_composite_gradient) THEN
2300 DO idir = 1, 3
2301 vxg_h(idir, ia, ir, 1) = 0.5_dp* &
2302 sum(composite_grad_grad( &
2303 composite_row, idir, :))
2304 vxg_s(idir, ia, ir, 1) = vxg_h(idir, ia, ir, 1)
2305 END DO
2306 END IF
2307 IF (use_atom_composite_tau) THEN
2308 vtau_h(ia, ir, 1) = 0.5_dp* &
2309 sum(composite_kin_grad(composite_row, :))
2310 vtau_s(ia, ir, 1) = vtau_h(ia, ir, 1)
2311 END IF
2312 END IF
2313 END DO
2314 END DO
2315 cpassert(composite_row == composite_atom_end(iatom))
2316 END IF
2317
2318 cross_cutoff = gapw_atom_grid_support_radius( &
2319 grid_atom, rho_h, rho_s, drho_h, drho_s, tau_h, tau_s)
2320 IF (cross_cutoff > 0.0_dp) THEN
2321 image_shell = 0
2322 DO idir = 1, 3
2323 IF (cell%perd(idir) == 1) THEN
2324 image_shell(idir) = ceiling( &
2325 cross_cutoff*sqrt(sum(cell%h_inv(idir, :)**2))) + 1
2326 END IF
2327 END DO
2328 DO composite_local_atom = 1, composite_local_natom
2329 target_atom = composite_local_atoms(composite_local_atom)
2330 DO composite_row = composite_atom_start(target_atom), &
2331 composite_atom_end(target_atom)
2332 cross_density_adjoint = 0.0_dp
2333 cross_grad_adjoint = 0.0_dp
2334 cross_kin_adjoint = 0.0_dp
2335 IF (lsd) THEN
2336 IF (use_atom_composite_density) THEN
2337 cross_density_adjoint(1:2) = &
2338 composite_density_grad(composite_row, 1:2)
2339 END IF
2340 IF (use_atom_composite_gradient) THEN
2341 cross_grad_adjoint(:, 1:2) = &
2342 composite_grad_grad(composite_row, :, 1:2)
2343 END IF
2344 IF (use_atom_composite_tau) THEN
2345 cross_kin_adjoint(1:2) = &
2346 composite_kin_grad(composite_row, 1:2)
2347 END IF
2348 ELSE
2349 IF (use_atom_composite_density) THEN
2350 cross_density_adjoint(1) = 0.5_dp* &
2351 sum(composite_density_grad(composite_row, :))
2352 END IF
2353 IF (use_atom_composite_gradient) THEN
2354 DO idir = 1, 3
2355 cross_grad_adjoint(idir, 1) = 0.5_dp* &
2356 sum(composite_grad_grad(composite_row, idir, :))
2357 END DO
2358 END IF
2359 IF (use_atom_composite_tau) THEN
2360 cross_kin_adjoint(1) = 0.5_dp* &
2361 sum(composite_kin_grad(composite_row, :))
2362 END IF
2363 END IF
2364 fractional = 0.0_dp
2365 DO idir = 1, 3
2366 DO jdir = 1, 3
2367 fractional(idir) = fractional(idir) + cell%h_inv(idir, jdir)* &
2368 (composite_grid_coords(jdir, composite_row) - &
2369 particle_set(iatom)%r(jdir))
2370 END DO
2371 END DO
2372 DO idir = 1, 3
2373 base_shift(idir) = cell%perd(idir)*nint(fractional(idir))
2374 END DO
2375 DO image_i3 = base_shift(3) - image_shell(3), &
2376 base_shift(3) + image_shell(3)
2377 DO image_i2 = base_shift(2) - image_shell(2), &
2378 base_shift(2) + image_shell(2)
2379 DO image_i1 = base_shift(1) - image_shell(1), &
2380 base_shift(1) + image_shell(1)
2381 image_shift = [image_i1, image_i2, image_i3]
2382 IF (target_atom == iatom .AND. all(image_shift == 0)) cycle
2383 image_translation = matmul( &
2384 cell%hmat, real(image_shift, dp))
2385 cross_displacement = &
2386 composite_grid_coords(:, composite_row) - &
2387 particle_set(iatom)%r - image_translation
2388 CALL add_gapw_atom_grid_interpolation_adjoint( &
2389 grid_atom, harmonics, cross_displacement, cross_cutoff, &
2390 nspins, cross_density_adjoint, cross_grad_adjoint, &
2391 cross_kin_adjoint, vxc_h, vxc_s, vxg_h, vxg_s, &
2392 vtau_h, vtau_s)
2393 END DO
2394 END DO
2395 END DO
2396 END DO
2397 END DO
2398 END IF
2399
2400 ! Model rows are distributed by target atom, while CP2K stores each
2401 ! one-center matrix on the rank owning its source atom. Sum the exact
2402 ! interpolation transpose before forming that matrix.
2403 CALL para_env%sum(vxc_h)
2404 CALL para_env%sum(vxc_s)
2405 CALL para_env%sum(vxg_h)
2406 CALL para_env%sum(vxg_s)
2407 CALL para_env%sum(vtau_h)
2408 CALL para_env%sum(vtau_s)
2409 IF (.NOT. source_matrix_local) cycle
2410
2411 one_center_rho_grad_field_contraction = &
2412 one_center_rho_grad_field_contraction + sum(vxc_h*(rho_h - rho_s)) + &
2413 sum(vxg_h*(drho_h(1:3, :, :, :) - drho_s(1:3, :, :, :)))
2414 one_center_density_field_contraction = one_center_density_field_contraction + &
2415 sum(vxc_h*(rho_h - rho_s))
2416 one_center_gradient_field_contraction = one_center_gradient_field_contraction + &
2417 sum(vxg_h*(drho_h(1:3, :, :, :) - &
2418 drho_s(1:3, :, :, :)))
2419 one_center_tau_field_contraction = one_center_tau_field_contraction + &
2420 sum(vtau_h*(tau_h - tau_s))
2421
2422 ALLOCATE (composite_int_h(SIZE(int_hh(1)%r_coef, 1), &
2423 SIZE(int_hh(1)%r_coef, 2), nspins), &
2424 composite_int_s(SIZE(int_ss(1)%r_coef, 1), &
2425 SIZE(int_ss(1)%r_coef, 2), nspins))
2426 DO ispin = 1, nspins
2427 composite_int_h(:, :, ispin) = int_hh(ispin)%r_coef
2428 composite_int_s(:, :, ispin) = int_ss(ispin)%r_coef
2429 int_hh(ispin)%r_coef = 0.0_dp
2430 int_ss(ispin)%r_coef = 0.0_dp
2431 END DO
2432 CALL gavxcgb_nogc(vxc_h, vxc_s, int_hh, int_ss, &
2433 grid_atom, basis_1c, harmonics, nspins)
2434 DO ispin = 1, nspins
2435 one_center_density_matrix_contraction = &
2436 one_center_density_matrix_contraction + &
2437 contract_one_center_matrix(cpc_h(ispin)%r_coef, &
2438 int_hh(ispin)%r_coef, &
2439 tau_basis_cache%n2oindex) - &
2440 contract_one_center_matrix(cpc_s(ispin)%r_coef, &
2441 int_ss(ispin)%r_coef, &
2442 tau_basis_cache%n2oindex)
2443 int_hh(ispin)%r_coef = 0.0_dp
2444 int_ss(ispin)%r_coef = 0.0_dp
2445 END DO
2446 CALL gavxcgb_gc(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
2447 grid_atom, basis_1c, harmonics, nspins)
2448 DO ispin = 1, nspins
2449 one_center_rho_grad_matrix_contraction = &
2450 one_center_rho_grad_matrix_contraction + &
2451 contract_one_center_matrix(cpc_h(ispin)%r_coef, &
2452 int_hh(ispin)%r_coef, &
2453 tau_basis_cache%n2oindex) - &
2454 contract_one_center_matrix(cpc_s(ispin)%r_coef, &
2455 int_ss(ispin)%r_coef, &
2456 tau_basis_cache%n2oindex)
2457 END DO
2458 CALL dgavtaudgb(vtau_h, vtau_s, int_hh, int_ss, tau_basis_cache, nspins)
2459 DO ispin = 1, nspins
2460 one_center_matrix_contraction = one_center_matrix_contraction + &
2461 contract_one_center_matrix(cpc_h(ispin)%r_coef, &
2462 int_hh(ispin)%r_coef, &
2463 tau_basis_cache%n2oindex) - &
2464 contract_one_center_matrix(cpc_s(ispin)%r_coef, &
2465 int_ss(ispin)%r_coef, &
2466 tau_basis_cache%n2oindex)
2467 IF (.NOT. atom_composite_reference) THEN
2468 int_hh(ispin)%r_coef = composite_int_h(:, :, ispin)
2469 int_ss(ispin)%r_coef = composite_int_s(:, :, ispin)
2470 END IF
2471 END DO
2472 DEALLOCATE (composite_int_h, composite_int_s)
2473 END DO
2474 CALL release_tau_basis_cache(tau_basis_cache)
2475 END DO
2476 END IF
2477 CALL para_env%sum(one_center_density_field_contraction)
2478 CALL para_env%sum(one_center_density_matrix_contraction)
2479 CALL para_env%sum(one_center_gradient_field_contraction)
2480 CALL para_env%sum(one_center_matrix_contraction)
2481 CALL para_env%sum(one_center_rho_grad_field_contraction)
2482 CALL para_env%sum(one_center_rho_grad_matrix_contraction)
2483 CALL para_env%sum(one_center_tau_field_contraction)
2484 one_center_field_contraction = one_center_rho_grad_field_contraction + &
2485 one_center_tau_field_contraction
2486 one_center_gradient_matrix_contraction = one_center_rho_grad_matrix_contraction - &
2487 one_center_density_matrix_contraction
2488 one_center_tau_matrix_contraction = one_center_matrix_contraction - &
2489 one_center_rho_grad_matrix_contraction
2490 feature_component_analytic(1) = sum(composite_density_grad*composite_density)
2491 feature_component_analytic(2) = sum(composite_grad_grad*composite_grad)
2492 feature_component_analytic(3) = sum(composite_kin_grad*composite_kin)
2493 feature_component_analytic(4) = sum(feature_component_analytic(1:3))
2494 CALL para_env%sum(feature_component_analytic)
2495 one_center_tensor_contraction = feature_component_analytic(4) - &
2496 smooth_input_contraction
2497 IF (atom_composite_diagnostic) THEN
2498 DO icomponent = 1, 4
2499 SELECT CASE (icomponent)
2500 CASE (1)
2501 composite_density = (1.0_dp + feature_vxc_step)*composite_density
2502 CASE (2)
2503 composite_grad = (1.0_dp + feature_vxc_step)*composite_grad
2504 CASE (3)
2505 composite_kin = (1.0_dp + feature_vxc_step)*composite_kin
2506 CASE (4)
2507 composite_density = (1.0_dp + feature_vxc_step)*composite_density
2508 composite_grad = (1.0_dp + feature_vxc_step)*composite_grad
2509 composite_kin = (1.0_dp + feature_vxc_step)*composite_kin
2510 END SELECT
2511 CALL skala_gapw_atom_composite_energy( &
2512 my_xc_section, para_env, composite_density, composite_grad, composite_kin, &
2513 composite_grid_coords, composite_grid_weights, composite_atomic_grid_weights, &
2514 composite_local_grid_sizes, composite_local_atom_coords, feature_vxc_plus)
2515 SELECT CASE (icomponent)
2516 CASE (1)
2517 composite_density = ((1.0_dp - feature_vxc_step)/ &
2518 (1.0_dp + feature_vxc_step))*composite_density
2519 CASE (2)
2520 composite_grad = ((1.0_dp - feature_vxc_step)/ &
2521 (1.0_dp + feature_vxc_step))*composite_grad
2522 CASE (3)
2523 composite_kin = ((1.0_dp - feature_vxc_step)/ &
2524 (1.0_dp + feature_vxc_step))*composite_kin
2525 CASE (4)
2526 composite_density = ((1.0_dp - feature_vxc_step)/ &
2527 (1.0_dp + feature_vxc_step))*composite_density
2528 composite_grad = ((1.0_dp - feature_vxc_step)/ &
2529 (1.0_dp + feature_vxc_step))*composite_grad
2530 composite_kin = ((1.0_dp - feature_vxc_step)/ &
2531 (1.0_dp + feature_vxc_step))*composite_kin
2532 END SELECT
2533 CALL skala_gapw_atom_composite_energy( &
2534 my_xc_section, para_env, composite_density, composite_grad, composite_kin, &
2535 composite_grid_coords, composite_grid_weights, composite_atomic_grid_weights, &
2536 composite_local_grid_sizes, composite_local_atom_coords, feature_vxc_minus)
2537 SELECT CASE (icomponent)
2538 CASE (1)
2539 composite_density = composite_density/(1.0_dp - feature_vxc_step)
2540 CASE (2)
2541 composite_grad = composite_grad/(1.0_dp - feature_vxc_step)
2542 CASE (3)
2543 composite_kin = composite_kin/(1.0_dp - feature_vxc_step)
2544 CASE (4)
2545 composite_density = composite_density/(1.0_dp - feature_vxc_step)
2546 composite_grad = composite_grad/(1.0_dp - feature_vxc_step)
2547 composite_kin = composite_kin/(1.0_dp - feature_vxc_step)
2548 END SELECT
2549 feature_component_fd(icomponent) = &
2550 (feature_vxc_plus - feature_vxc_minus)/(2.0_dp*feature_vxc_step)
2551 END DO
2552 feature_vxc_analytic = feature_component_analytic(4)
2553 feature_vxc_fd = feature_component_fd(4)
2554 iw = cp_logger_get_default_io_unit()
2555 IF (iw > 0) THEN
2556 WRITE (unit=iw, fmt="(T2,A,1X,I0)") &
2557 "SKALA_GPW| Atom-composite reference components", atom_composite_components
2558 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2559 "SKALA_GPW| Atom-composite reference electrons", atom_composite_nelec
2560 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2561 "SKALA_GPW| Atom-composite reference XC energy", atom_composite_exc
2562 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2563 "SKALA_GPW| Atom-composite feature VXC contraction", feature_vxc_analytic
2564 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2565 "SKALA_GPW| Atom-composite feature finite difference", feature_vxc_fd
2566 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2567 "SKALA_GPW| Atom-composite feature VXC error", &
2568 feature_vxc_analytic - feature_vxc_fd
2569 WRITE (unit=iw, fmt="(T2,A,3(1X,ES24.16))") &
2570 "SKALA_GPW| Atom-composite smooth PW adjoint", smooth_input_contraction, &
2571 smooth_grid_contraction, smooth_grid_contraction - smooth_input_contraction
2572 WRITE (unit=iw, fmt="(T2,A,4(1X,ES24.16))") &
2573 "SKALA_GPW| Atom-composite one-center adjoint", one_center_tensor_contraction, &
2574 one_center_field_contraction, one_center_matrix_contraction, &
2575 one_center_matrix_contraction - one_center_tensor_contraction
2576 WRITE (unit=iw, fmt="(T2,A,4(1X,ES24.16))") &
2577 "SKALA_GPW| Atom-composite one-center channels", &
2578 one_center_rho_grad_field_contraction, one_center_rho_grad_matrix_contraction, &
2579 one_center_tau_field_contraction, one_center_tau_matrix_contraction
2580 WRITE (unit=iw, fmt="(T2,A,4(1X,ES24.16))") &
2581 "SKALA_GPW| Atom-composite one-center rho-gradient", &
2582 one_center_density_field_contraction, one_center_density_matrix_contraction, &
2583 one_center_gradient_field_contraction, one_center_gradient_matrix_contraction
2584 DO icomponent = 1, 3
2585 WRITE (unit=iw, fmt="(T2,A,1X,I0,3(1X,ES24.16))") &
2586 "SKALA_GPW| Atom-composite component VXC", icomponent, &
2587 feature_component_analytic(icomponent), feature_component_fd(icomponent), &
2588 feature_component_analytic(icomponent) - feature_component_fd(icomponent)
2589 END DO
2590 END IF
2591 END IF
2592 IF (atom_composite_reference) THEN
2593 exc1 = atom_composite_exc
2594 IF (native_grid_diagnostics) THEN
2595 IF (composite_nflat > 0) THEN
2596 composite_density_min = minval(composite_density)
2597 composite_density_max = maxval(composite_density)
2598 composite_kin_min = minval(composite_kin)
2599 composite_kin_max = maxval(composite_kin)
2600 composite_grad_max = maxval(abs(composite_grad))
2601 ELSE
2602 composite_density_min = huge(1.0_dp)
2603 composite_density_max = -huge(1.0_dp)
2604 composite_kin_min = huge(1.0_dp)
2605 composite_kin_max = -huge(1.0_dp)
2606 composite_grad_max = 0.0_dp
2607 END IF
2608 composite_tau_integral = &
2609 sum(composite_grid_weights*sum(composite_kin, dim=2))
2610 CALL para_env%min(composite_density_min)
2611 CALL para_env%max(composite_density_max)
2612 CALL para_env%min(composite_kin_min)
2613 CALL para_env%max(composite_kin_max)
2614 CALL para_env%max(composite_grad_max)
2615 CALL para_env%sum(composite_tau_integral)
2616 END IF
2617 iw = cp_logger_get_default_io_unit()
2618 IF (iw > 0) THEN
2619 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2620 "SKALA_GPW| Active atom-composite XC energy", atom_composite_exc
2621 IF (native_grid_diagnostics) THEN
2622 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2623 "SKALA_GPW| Active atom-composite electrons", atom_composite_nelec
2624 WRITE (unit=iw, fmt="(T2,A,2(1X,ES24.16))") &
2625 "SKALA_GPW| Active atom-composite density range", &
2626 composite_density_min, composite_density_max
2627 WRITE (unit=iw, fmt="(T2,A,2(1X,ES24.16))") &
2628 "SKALA_GPW| Active atom-composite tau range", &
2629 composite_kin_min, composite_kin_max
2630 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2631 "SKALA_GPW| Active atom-composite tau integral", &
2632 composite_tau_integral
2633 WRITE (unit=iw, fmt="(T2,A,1X,ES24.16)") &
2634 "SKALA_GPW| Active atom-composite max gradient", &
2635 composite_grad_max
2636 END IF
2637 END IF
2638 END IF
2639 CALL xc_rho_set_release(smooth_rho_set, pw_pool=auxbas_pw_pool)
2640 DEALLOCATE (composite_atomic_grid_sizes, composite_atom_kind, &
2641 composite_atom_kind_index, composite_atom_start, composite_atom_end, &
2642 composite_atom_coords, composite_local_atoms, composite_local_grid_sizes, &
2643 composite_local_atom_coords, composite_grid_atom, &
2644 composite_partition_weights, composite_partition_atom_coords, &
2645 composite_distances, composite_density, composite_grad, composite_kin, &
2646 composite_smooth_density_cache, composite_smooth_gradient_cache, &
2647 composite_smooth_kin_cache, &
2648 composite_density_grad, composite_grad_grad, composite_kin_grad, &
2649 composite_grid_coords, composite_grid_weights, &
2650 composite_base_grid_weights, composite_atomic_grid_weights)
2651 IF (lsd) THEN
2652 DEALLOCATE (composite_smooth_rhoa, composite_smooth_rhob, &
2653 composite_smooth_tau_a, composite_smooth_tau_b)
2654 DO idir = 1, 3
2655 DEALLOCATE (composite_smooth_drhoa(idir)%array, &
2656 composite_smooth_drhob(idir)%array)
2657 END DO
2658 ELSE
2659 DEALLOCATE (composite_smooth_rho, composite_smooth_tau)
2660 DO idir = 1, 3
2661 DEALLOCATE (composite_smooth_drho(idir)%array)
2662 END DO
2663 END IF
2664 END IF
2665
2666 IF (.NOT. atom_composite_reference) CALL para_env%sum(exc1)
2667
2668 IF (ASSOCIATED(rho_h)) DEALLOCATE (rho_h)
2669 IF (ASSOCIATED(rho_s)) DEALLOCATE (rho_s)
2670 IF (ASSOCIATED(vxc_h)) DEALLOCATE (vxc_h)
2671 IF (ASSOCIATED(vxc_s)) DEALLOCATE (vxc_s)
2672
2673 IF (gradient_f) THEN
2674 IF (ASSOCIATED(drho_h)) DEALLOCATE (drho_h)
2675 IF (ASSOCIATED(drho_s)) DEALLOCATE (drho_s)
2676 IF (ASSOCIATED(vxg_h)) DEALLOCATE (vxg_h)
2677 IF (ASSOCIATED(vxg_s)) DEALLOCATE (vxg_s)
2678 END IF
2679
2680 IF (tau_f) THEN
2681 IF (ASSOCIATED(tau_h)) DEALLOCATE (tau_h)
2682 IF (ASSOCIATED(tau_s)) DEALLOCATE (tau_s)
2683 IF (ASSOCIATED(vtau_h)) DEALLOCATE (vtau_h)
2684 IF (ASSOCIATED(vtau_s)) DEALLOCATE (vtau_s)
2685 END IF
2686
2687 END IF !xc_none
2688
2689 CALL timestop(handle)
2690
2691 END SUBROUTINE calculate_vxc_atom
2692
2693! **************************************************************************************************
2694!> \brief Add the GAPW one-center correction to CDFT values and operators.
2695!> \param qs_env Quickstep environment
2696!> \param energy_only skip construction of the CDFT one-center operator
2697!> \param calculate_forces evaluate explicit derivatives of the partition weights
2698!> \param values constraint values from the hard-minus-soft one-center densities
2699!> \param electronic_charge optional one-center corrections to atomic populations
2700!> \param operator_group optional group for which to build the unscaled weight operator
2701!> \param rho_atom_operator_set optional destination for the one-center operator integrals
2702! **************************************************************************************************
2703 SUBROUTINE gapw_cdft_one_center(qs_env, energy_only, calculate_forces, values, &
2704 electronic_charge, operator_group, rho_atom_operator_set)
2705 TYPE(qs_environment_type), POINTER :: qs_env
2706 LOGICAL, INTENT(IN) :: energy_only, calculate_forces
2707 REAL(kind=dp), DIMENSION(:), INTENT(OUT) :: values
2708 REAL(kind=dp), DIMENSION(:, :), INTENT(OUT), &
2709 OPTIONAL :: electronic_charge
2710 INTEGER, INTENT(IN), OPTIONAL :: operator_group
2711 TYPE(rho_atom_type), DIMENSION(:), POINTER, &
2712 OPTIONAL :: rho_atom_operator_set
2713
2714 INTEGER :: atom, channel, ia, iat, igroup, ikind, &
2715 ir, natom, natom_kind, nspins
2716 INTEGER, DIMENSION(2) :: atom_bounds
2717 INTEGER, DIMENSION(:), POINTER :: atom_list
2718 LOGICAL :: lsd, paw_atom
2719 REAL(kind=dp) :: delta_density, point_factor, spin_factor
2720 REAL(kind=dp), ALLOCATABLE, DIMENSION(:) :: atomic_weights, group_weights
2721 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :) :: explicit_derivative, &
2722 group_point_derivative
2723 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :) :: group_atom_derivative
2724 REAL(kind=dp), DIMENSION(3) :: point
2725 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: rho_h, rho_s
2726 REAL(kind=dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s
2727 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: vlocal_h, vlocal_s
2728 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
2729 TYPE(cdft_control_type), POINTER :: cdft_control
2730 TYPE(cdft_point_context_type) :: context
2731 TYPE(dft_control_type), POINTER :: dft_control
2732 TYPE(grid_atom_type), POINTER :: grid_atom
2733 TYPE(gto_basis_set_type), POINTER :: basis_1c
2734 TYPE(harmonics_atom_type), POINTER :: harmonics
2735 TYPE(mp_para_env_type), POINTER :: para_env
2736 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set
2737 TYPE(qs_force_type), DIMENSION(:), POINTER :: force
2738 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set
2739 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s, int_hh, int_ss, r_h, r_s
2740 TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
2741 TYPE(rho_atom_type), DIMENSION(:), POINTER :: operator_atom_set, rho_atom_set
2742 TYPE(rho_atom_type), POINTER :: operator_atom, rho_atom
2743
2744 NULLIFY (atom_list, atomic_kind_set, basis_1c, cdft_control, dft_control, force, &
2745 grid_atom, harmonics, int_hh, int_ss, para_env, particle_set, r_h, r_s, &
2746 dr_h, dr_s, r_h_d, r_s_d, rho_h, rho_s, drho_h, drho_s, &
2747 operator_atom, operator_atom_set, rho_atom, rho_atom_set, qs_kind_set, &
2748 vlocal_h, vlocal_s)
2749 CALL get_qs_env(qs_env, atomic_kind_set=atomic_kind_set, dft_control=dft_control, &
2750 force=force, natom=natom, para_env=para_env, particle_set=particle_set, &
2751 qs_kind_set=qs_kind_set, rho_atom_set=rho_atom_set)
2752 cpassert(ASSOCIATED(atomic_kind_set))
2753 cpassert(ASSOCIATED(dft_control))
2754 cpassert(ASSOCIATED(para_env))
2755 cpassert(ASSOCIATED(particle_set))
2756 cpassert(ASSOCIATED(qs_kind_set))
2757 cpassert(ASSOCIATED(rho_atom_set))
2758 operator_atom_set => rho_atom_set
2759 IF (PRESENT(rho_atom_operator_set)) operator_atom_set => rho_atom_operator_set
2760 cpassert(ASSOCIATED(operator_atom_set))
2761 cdft_control => dft_control%qs_control%cdft_control
2762 cpassert(ASSOCIATED(cdft_control))
2763 nspins = dft_control%nspins
2764 lsd = dft_control%lsd
2765 cpassert(SIZE(values) == SIZE(cdft_control%group))
2766 IF (PRESENT(operator_group)) THEN
2767 cpassert(operator_group >= 1 .AND. operator_group <= SIZE(cdft_control%group))
2768 END IF
2769 IF (PRESENT(electronic_charge)) THEN
2770 cpassert(SIZE(electronic_charge, 1) == natom)
2771 cpassert(SIZE(electronic_charge, 2) == nspins)
2772 END IF
2773
2774 CALL cdft_point_context_create(qs_env, context, calculate_forces)
2775 ALLOCATE (group_weights(context%ngroup), group_point_derivative(3, context%ngroup), &
2776 group_atom_derivative(3, natom, context%ngroup), &
2777 explicit_derivative(3, natom))
2778 IF (PRESENT(electronic_charge)) ALLOCATE (atomic_weights(natom))
2779 values = 0.0_dp
2780 explicit_derivative = 0.0_dp
2781 IF (PRESENT(electronic_charge)) electronic_charge = 0.0_dp
2782
2783 DO ikind = 1, SIZE(atomic_kind_set)
2784 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom_kind)
2785 CALL get_qs_kind(qs_kind_set(ikind), paw_atom=paw_atom, grid_atom=grid_atom, &
2786 harmonics=harmonics)
2787 IF (.NOT. paw_atom) cycle
2788 CALL get_qs_kind(qs_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
2789 cpassert(ASSOCIATED(grid_atom))
2790 cpassert(ASSOCIATED(harmonics))
2791 cpassert(ASSOCIATED(basis_1c))
2792 ALLOCATE (vlocal_h(grid_atom%ng_sphere, grid_atom%nr, nspins), &
2793 vlocal_s(grid_atom%ng_sphere, grid_atom%nr, nspins))
2794
2795 atom_bounds = get_limit(natom_kind, para_env%num_pe, para_env%mepos)
2796 DO iat = atom_bounds(1), atom_bounds(2)
2797 atom = atom_list(iat)
2798 rho_atom => rho_atom_set(atom)
2799 NULLIFY (r_h, r_s)
2800 CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s)
2801 CALL reallocate(rho_h, 1, grid_atom%ng_sphere, 1, grid_atom%nr, 1, nspins)
2802 CALL reallocate(rho_s, 1, grid_atom%ng_sphere, 1, grid_atom%nr, 1, nspins)
2803 rho_h = 0.0_dp
2804 rho_s = 0.0_dp
2805 DO ir = 1, grid_atom%nr
2806 CALL calc_rho_angular(grid_atom, harmonics, nspins, .false., ir, r_h, r_s, &
2807 rho_h, rho_s, dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s)
2808 END DO
2809 vlocal_h = 0.0_dp
2810 vlocal_s = 0.0_dp
2811
2812 DO ir = 1, grid_atom%nr
2813 DO ia = 1, grid_atom%ng_sphere
2814 point(1) = particle_set(atom)%r(1) + grid_atom%rad(ir)* &
2815 grid_atom%sin_pol(ia)*grid_atom%cos_azi(ia)
2816 point(2) = particle_set(atom)%r(2) + grid_atom%rad(ir)* &
2817 grid_atom%sin_pol(ia)*grid_atom%sin_azi(ia)
2818 point(3) = particle_set(atom)%r(3) + grid_atom%rad(ir)*grid_atom%cos_pol(ia)
2819 IF (PRESENT(electronic_charge)) THEN
2820 CALL cdft_point_weights(context, point, group_weights, &
2821 group_point_derivative, group_atom_derivative, &
2822 atomic_weights)
2823 ELSE
2824 CALL cdft_point_weights(context, point, group_weights, &
2825 group_point_derivative, group_atom_derivative)
2826 END IF
2827 DO channel = 1, nspins
2828 delta_density = rho_h(ia, ir, channel) - rho_s(ia, ir, channel)
2829 IF (PRESENT(electronic_charge)) THEN
2830 electronic_charge(:, channel) = electronic_charge(:, channel) + &
2831 grid_atom%weight(ia, ir)*atomic_weights* &
2832 delta_density
2833 END IF
2834 point_factor = 0.0_dp
2835 DO igroup = 1, context%ngroup
2836 spin_factor = cdft_spin_factor( &
2837 cdft_control%group(igroup)%constraint_type, channel, lsd)
2838 IF (PRESENT(operator_group)) THEN
2839 IF (igroup == operator_group) THEN
2840 point_factor = point_factor + group_weights(igroup)
2841 END IF
2842 ELSE
2843 point_factor = point_factor + cdft_control%strength(igroup)* &
2844 group_weights(igroup)*spin_factor
2845 END IF
2846 values(igroup) = values(igroup) + grid_atom%weight(ia, ir)* &
2847 group_weights(igroup)*delta_density*spin_factor
2848 IF (calculate_forces) THEN
2849 explicit_derivative(:, :) = &
2850 explicit_derivative + grid_atom%weight(ia, ir)* &
2851 cdft_control%strength(igroup)*delta_density* &
2852 spin_factor*group_atom_derivative(:, :, igroup)
2853 explicit_derivative(:, atom) = explicit_derivative(:, atom) + &
2854 grid_atom%weight(ia, ir)* &
2855 cdft_control%strength(igroup)*delta_density* &
2856 spin_factor*group_point_derivative(:, igroup)
2857 END IF
2858 END DO
2859 vlocal_h(ia, ir, channel) = grid_atom%weight(ia, ir)*point_factor
2860 vlocal_s(ia, ir, channel) = vlocal_h(ia, ir, channel)
2861 END DO
2862 END DO
2863 END DO
2864
2865 IF (.NOT. energy_only) THEN
2866 NULLIFY (int_hh, int_ss)
2867 operator_atom => operator_atom_set(atom)
2868 CALL get_rho_atom(rho_atom=operator_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
2869 CALL gavxcgb_nogc(vlocal_h, vlocal_s, int_hh, int_ss, grid_atom, &
2870 basis_1c, harmonics, nspins)
2871 END IF
2872 END DO
2873 DEALLOCATE (vlocal_h, vlocal_s)
2874 END DO
2875
2876 CALL para_env%sum(values)
2877 CALL para_env%sum(explicit_derivative)
2878 IF (PRESENT(electronic_charge)) CALL para_env%sum(electronic_charge)
2879 IF (calculate_forces .AND. ASSOCIATED(force) .AND. para_env%is_source()) THEN
2880 DO ikind = 1, SIZE(atomic_kind_set)
2881 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom_kind)
2882 DO iat = 1, natom_kind
2883 atom = atom_list(iat)
2884 force(ikind)%rho_elec(:, iat) = force(ikind)%rho_elec(:, iat) + &
2885 explicit_derivative(:, atom)
2886 END DO
2887 END DO
2888 END IF
2889
2890 IF (ASSOCIATED(rho_h)) DEALLOCATE (rho_h)
2891 IF (ASSOCIATED(rho_s)) DEALLOCATE (rho_s)
2892 IF (ALLOCATED(atomic_weights)) DEALLOCATE (atomic_weights)
2893 DEALLOCATE (explicit_derivative, group_atom_derivative, group_point_derivative, group_weights)
2894 CALL cdft_point_context_release(context)
2895
2896 CONTAINS
2897
2898! **************************************************************************************************
2899!> \brief ...
2900!> \param constraint_type ...
2901!> \param channel ...
2902!> \param lsd ...
2903!> \return ...
2904! **************************************************************************************************
2905 FUNCTION cdft_spin_factor(constraint_type, channel, lsd) RESULT(factor)
2906 INTEGER, INTENT(IN) :: constraint_type, channel
2907 LOGICAL, INTENT(IN) :: lsd
2908 REAL(kind=dp) :: factor
2909
2910 SELECT CASE (constraint_type)
2911 CASE (cdft_charge_constraint)
2912 factor = 1.0_dp
2913 CASE (cdft_magnetization_constraint)
2914 cpassert(lsd)
2915 factor = merge(1.0_dp, -1.0_dp, channel == 1)
2916 CASE (cdft_alpha_constraint)
2917 cpassert(lsd)
2918 factor = merge(1.0_dp, 0.0_dp, channel == 1)
2919 CASE (cdft_beta_constraint)
2920 cpassert(lsd)
2921 factor = merge(1.0_dp, 0.0_dp, channel == 2)
2922 CASE DEFAULT
2923 cpabort("Unknown CDFT constraint type.")
2924 END SELECT
2925 END FUNCTION cdft_spin_factor
2926
2927 END SUBROUTINE gapw_cdft_one_center
2928
2929! **************************************************************************************************
2930!> \brief Contract a compact one-center density matrix with an integral in the padded old basis.
2931!> \param density_matrix ...
2932!> \param integral_matrix ...
2933!> \param new_to_old ...
2934!> \return ...
2935! **************************************************************************************************
2936 FUNCTION contract_one_center_matrix(density_matrix, integral_matrix, new_to_old) RESULT(value)
2937 REAL(kind=dp), DIMENSION(:, :), INTENT(IN) :: density_matrix, integral_matrix
2938 INTEGER, DIMENSION(:), INTENT(IN) :: new_to_old
2939 REAL(kind=dp) :: value
2940
2941 INTEGER :: ibas, jbas, nbas
2942
2943 nbas = SIZE(density_matrix, 1)
2944 cpassert(SIZE(density_matrix, 2) == nbas)
2945 cpassert(SIZE(new_to_old) >= nbas)
2946 cpassert(minval(new_to_old(1:nbas)) >= 1)
2947 cpassert(maxval(new_to_old(1:nbas)) <= SIZE(integral_matrix, 1))
2948 cpassert(maxval(new_to_old(1:nbas)) <= SIZE(integral_matrix, 2))
2949
2950 value = 0.0_dp
2951 DO jbas = 1, nbas
2952 DO ibas = 1, nbas
2953 value = value + density_matrix(ibas, jbas)* &
2954 integral_matrix(new_to_old(ibas), new_to_old(jbas))
2955 END DO
2956 END DO
2957
2958 END FUNCTION contract_one_center_matrix
2959
2960! **************************************************************************************************
2961!> \brief Replicate a distributed real-space field for atom-grid interpolation.
2962!> \param local_values ...
2963!> \param pw_grid ...
2964!> \param group ...
2965!> \param global_values ...
2966! **************************************************************************************************
2967 SUBROUTINE gather_native_grid_field(local_values, pw_grid, group, global_values)
2968 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN), &
2969 POINTER :: local_values
2970 TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
2971 TYPE(mp_para_env_type), INTENT(IN) :: group
2972 REAL(kind=dp), DIMENSION(:, :, :), INTENT(OUT), &
2973 POINTER :: global_values
2974
2975 INTEGER, DIMENSION(2, 3) :: bo
2976
2977 cpassert(ASSOCIATED(local_values))
2978 cpassert(ASSOCIATED(pw_grid))
2979 cpassert(.NOT. ASSOCIATED(global_values))
2980 bo = pw_grid%bounds_local
2981 ALLOCATE (global_values(pw_grid%bounds(1, 1):pw_grid%bounds(2, 1), &
2982 pw_grid%bounds(1, 2):pw_grid%bounds(2, 2), &
2983 pw_grid%bounds(1, 3):pw_grid%bounds(2, 3)))
2984 global_values = 0.0_dp
2985 global_values(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), bo(1, 3):bo(2, 3)) = &
2986 local_values
2987 CALL group%sum(global_values)
2988
2989 END SUBROUTINE gather_native_grid_field
2990
2991! **************************************************************************************************
2992!> \brief Build the tensor-product interpolation stencil for one Cartesian point.
2993!> \param stencil ...
2994!> \param pw_grid ...
2995!> \param cell ...
2996!> \param point ...
2997!> \param wrap_auxiliary_cell wrap all auxiliary-grid directions
2998!> \param indices_only skip interpolation weights when only grid indices are needed
2999! **************************************************************************************************
3000 SUBROUTINE create_native_grid_interpolation_stencil(stencil, pw_grid, cell, point, &
3001 wrap_auxiliary_cell, indices_only)
3002 TYPE(native_grid_interpolation_stencil_type), &
3003 INTENT(OUT) :: stencil
3004 TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
3005 TYPE(cell_type), INTENT(IN), POINTER :: cell
3006 REAL(kind=dp), DIMENSION(3), INTENT(IN) :: point
3007 LOGICAL, INTENT(IN), OPTIONAL :: wrap_auxiliary_cell, indices_only
3008
3009 INTEGER :: idir, inode, relative_index
3010 INTEGER, DIMENSION(3) :: base
3011 LOGICAL :: build_weights, wrap_grid
3012 REAL(kind=dp), DIMENSION(3) :: fraction, relative
3013
3014 cpassert(ASSOCIATED(pw_grid))
3015 cpassert(ASSOCIATED(cell))
3016 stencil%active = .false.
3017 stencil%valid = .false.
3018 stencil%weight = 0.0_dp
3019 build_weights = .true.
3020 IF (PRESENT(indices_only)) build_weights = .NOT. indices_only
3021 wrap_grid = any(cell%perd == 0)
3022 IF (PRESENT(wrap_auxiliary_cell)) wrap_grid = wrap_auxiliary_cell
3023 relative = matmul(pw_grid%dh_inv, point)
3024 DO idir = 1, 3
3025 IF (cell%perd(idir) == 1 .OR. wrap_grid) THEN
3026 relative(idir) = modulo(relative(idir), real(pw_grid%npts(idir), kind=dp))
3027 ELSE IF (relative(idir) <= -real(native_grid_interp_offset_max, dp) .OR. &
3028 relative(idir) >= real(pw_grid%npts(idir) - &
3029 native_grid_interp_offset_min, kind=dp)) THEN
3030 RETURN
3031 END IF
3032 base(idir) = floor(relative(idir))
3033 fraction(idir) = relative(idir) - real(base(idir), kind=dp)
3034 IF (build_weights) THEN
3035 CALL native_grid_lagrange_weights(fraction(idir), stencil%weight(:, idir))
3036 END IF
3037 DO inode = 1, native_grid_interp_npts
3038 relative_index = base(idir) + native_grid_interp_offset_min + inode - 1
3039 IF (cell%perd(idir) == 1 .OR. wrap_grid) THEN
3040 relative_index = modulo(relative_index, pw_grid%npts(idir))
3041 stencil%valid(inode, idir) = .true.
3042 ELSE IF (relative_index >= 0 .AND. relative_index < pw_grid%npts(idir)) THEN
3043 stencil%valid(inode, idir) = .true.
3044 END IF
3045 stencil%relative_index(inode, idir) = relative_index
3046 END DO
3047 END DO
3048 stencil%active = .true.
3049
3050 END SUBROUTINE create_native_grid_interpolation_stencil
3051
3052! **************************************************************************************************
3053!> \brief Interpolate density, gradient, and kinetic-density fields in one stencil traversal.
3054!> \param density ...
3055!> \param grad_x ...
3056!> \param grad_y ...
3057!> \param grad_z ...
3058!> \param kin ...
3059!> \param stencil ...
3060!> \param density_value ...
3061!> \param grad_value ...
3062!> \param kin_value ...
3063! **************************************************************************************************
3064 SUBROUTINE interpolate_native_grid_fields(density, grad_x, grad_y, grad_z, kin, stencil, &
3065 density_value, grad_value, kin_value)
3066 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: density, grad_x, grad_y, grad_z, kin
3067 TYPE(native_grid_interpolation_stencil_type), &
3068 INTENT(IN) :: stencil
3069 REAL(kind=dp), INTENT(OUT) :: density_value
3070 REAL(kind=dp), DIMENSION(3), INTENT(OUT) :: grad_value
3071 REAL(kind=dp), INTENT(OUT) :: kin_value
3072
3073 INTEGER :: inode_x, inode_y, inode_z
3074 INTEGER, DIMENSION(3) :: index, lower_bound
3075 REAL(kind=dp) :: coefficient
3076
3077 cpassert(all(shape(grad_x) == shape(density)))
3078 cpassert(all(shape(grad_y) == shape(density)))
3079 cpassert(all(shape(grad_z) == shape(density)))
3080 cpassert(all(shape(kin) == shape(density)))
3081 density_value = 0.0_dp
3082 grad_value = 0.0_dp
3083 kin_value = 0.0_dp
3084 IF (.NOT. stencil%active) RETURN
3085 lower_bound = lbound(density)
3086 DO inode_z = 1, native_grid_interp_npts
3087 IF (.NOT. stencil%valid(inode_z, 3)) cycle
3088 index(3) = lower_bound(3) + stencil%relative_index(inode_z, 3)
3089 DO inode_y = 1, native_grid_interp_npts
3090 IF (.NOT. stencil%valid(inode_y, 2)) cycle
3091 index(2) = lower_bound(2) + stencil%relative_index(inode_y, 2)
3092 DO inode_x = 1, native_grid_interp_npts
3093 IF (.NOT. stencil%valid(inode_x, 1)) cycle
3094 index(1) = lower_bound(1) + stencil%relative_index(inode_x, 1)
3095 coefficient = stencil%weight(inode_x, 1)* &
3096 stencil%weight(inode_y, 2)* &
3097 stencil%weight(inode_z, 3)
3098 density_value = density_value + coefficient*density(index(1), index(2), index(3))
3099 grad_value(1) = grad_value(1) + coefficient*grad_x(index(1), index(2), index(3))
3100 grad_value(2) = grad_value(2) + coefficient*grad_y(index(1), index(2), index(3))
3101 grad_value(3) = grad_value(3) + coefficient*grad_z(index(1), index(2), index(3))
3102 kin_value = kin_value + coefficient*kin(index(1), index(2), index(3))
3103 END DO
3104 END DO
3105 END DO
3106
3107 END SUBROUTINE interpolate_native_grid_fields
3108
3109! **************************************************************************************************
3110!> \brief Group atom-grid rows by the disjoint PW tiles touched by their interpolation stencils.
3111!> \param pw_grid ...
3112!> \param cell ...
3113!> \param points atom-grid coordinates
3114!> \param wrap_auxiliary_cell wrap all auxiliary-grid directions
3115!> \param tile_count number of tiles along each PW-grid direction
3116!> \param bin_offsets CSR offsets into bin_rows
3117!> \param bin_rows atom-grid rows touching each tile
3118! **************************************************************************************************
3119 SUBROUTINE build_native_grid_adjoint_bins(pw_grid, cell, points, wrap_auxiliary_cell, &
3120 tile_count, bin_offsets, bin_rows)
3121 TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
3122 TYPE(cell_type), INTENT(IN), POINTER :: cell
3123 REAL(kind=dp), DIMENSION(:, :), INTENT(IN) :: points
3124 LOGICAL, INTENT(IN) :: wrap_auxiliary_cell
3125 INTEGER, DIMENSION(3), INTENT(OUT) :: tile_count
3126 INTEGER, ALLOCATABLE, DIMENSION(:), INTENT(OUT) :: bin_offsets, bin_rows
3127
3128 INTEGER :: candidate, ibin, idir, inode, irow, ix, &
3129 iy, iz, nbin, ntouched, position
3130 INTEGER, ALLOCATABLE, DIMENSION(:) :: bin_counts, bin_cursor, row_bin_count
3131 INTEGER, ALLOCATABLE, DIMENSION(:, :) :: row_bins
3132 INTEGER, DIMENSION(3) :: touched_count
3133 INTEGER, DIMENSION(& native_grid_adjoint_max_tiles_per_direction, 3) :: touched_tiles
3134 TYPE(native_grid_interpolation_stencil_type) :: stencil
3135
3136 cpassert(ASSOCIATED(pw_grid))
3137 cpassert(ASSOCIATED(cell))
3138 cpassert(SIZE(points, 1) == 3)
3139 tile_count = (pw_grid%npts + native_grid_adjoint_tile_edge - 1)/ &
3140 native_grid_adjoint_tile_edge
3141 nbin = product(tile_count)
3142 ALLOCATE (row_bin_count(SIZE(points, 2)), &
3143 row_bins(native_grid_adjoint_max_bins_per_row, SIZE(points, 2)))
3144 row_bin_count = 0
3145 row_bins = 0
3146!$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
3147!$OMP PRIVATE(candidate, idir, inode, ix, iy, iz, ntouched, stencil, &
3148!$OMP touched_count, touched_tiles) &
3149!$OMP SHARED(cell, points, pw_grid, row_bin_count, row_bins, tile_count, wrap_auxiliary_cell)
3150 DO irow = 1, SIZE(points, 2)
3151 CALL create_native_grid_interpolation_stencil( &
3152 stencil, pw_grid, cell, points(:, irow), wrap_auxiliary_cell, indices_only=.true.)
3153 IF (.NOT. stencil%active) cycle
3154 touched_count = 0
3155 touched_tiles = 0
3156 DO idir = 1, 3
3157 DO inode = 1, native_grid_interp_npts
3158 IF (.NOT. stencil%valid(inode, idir)) cycle
3159 candidate = stencil%relative_index(inode, idir)/native_grid_adjoint_tile_edge + 1
3160 IF (all(touched_tiles(1:touched_count(idir), idir) /= candidate)) THEN
3161 touched_count(idir) = touched_count(idir) + 1
3162 cpassert(touched_count(idir) <= SIZE(touched_tiles, 1))
3163 touched_tiles(touched_count(idir), idir) = candidate
3164 END IF
3165 END DO
3166 END DO
3167 ntouched = 0
3168 DO iz = 1, touched_count(3)
3169 DO iy = 1, touched_count(2)
3170 DO ix = 1, touched_count(1)
3171 ntouched = ntouched + 1
3172 cpassert(ntouched <= native_grid_adjoint_max_bins_per_row)
3173 row_bins(ntouched, irow) = 1 + touched_tiles(ix, 1) - 1 + tile_count(1)*( &
3174 touched_tiles(iy, 2) - 1 + tile_count(2)*( &
3175 touched_tiles(iz, 3) - 1))
3176 END DO
3177 END DO
3178 END DO
3179 row_bin_count(irow) = ntouched
3180 END DO
3181!$OMP END PARALLEL DO
3182
3183 ALLOCATE (bin_counts(nbin), bin_cursor(nbin), bin_offsets(nbin + 1))
3184 bin_counts = 0
3185 DO irow = 1, SIZE(points, 2)
3186 DO ibin = 1, row_bin_count(irow)
3187 bin_counts(row_bins(ibin, irow)) = bin_counts(row_bins(ibin, irow)) + 1
3188 END DO
3189 END DO
3190 bin_offsets(1) = 1
3191 DO ibin = 1, nbin
3192 bin_offsets(ibin + 1) = bin_offsets(ibin) + bin_counts(ibin)
3193 END DO
3194 ALLOCATE (bin_rows(bin_offsets(nbin + 1) - 1))
3195 bin_cursor(:) = bin_offsets(1:nbin)
3196 DO irow = 1, SIZE(points, 2)
3197 DO ibin = 1, row_bin_count(irow)
3198 candidate = row_bins(ibin, irow)
3199 position = bin_cursor(candidate)
3200 bin_rows(position) = irow
3201 bin_cursor(candidate) = position + 1
3202 END DO
3203 END DO
3204 DEALLOCATE (bin_counts, bin_cursor, row_bin_count, row_bins)
3205
3206 END SUBROUTINE build_native_grid_adjoint_bins
3207
3208! **************************************************************************************************
3209!> \brief Return the inclusive PW-grid bounds owned by one linear tile index.
3210!> \param pw_grid ...
3211!> \param tile_index linear tile index
3212!> \param tile_count number of tiles along each PW-grid direction
3213!> \param tile_lower zero-based lower grid index
3214!> \param tile_upper zero-based upper grid index
3215! **************************************************************************************************
3216 SUBROUTINE native_grid_adjoint_tile_bounds(pw_grid, tile_index, tile_count, &
3217 tile_lower, tile_upper)
3218 TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
3219 INTEGER, INTENT(IN) :: tile_index
3220 INTEGER, DIMENSION(3), INTENT(IN) :: tile_count
3221 INTEGER, DIMENSION(3), INTENT(OUT) :: tile_lower, tile_upper
3222
3223 INTEGER :: linear_tile
3224 INTEGER, DIMENSION(3) :: expected_tile_count, tile_coord
3225
3226 cpassert(ASSOCIATED(pw_grid))
3227 expected_tile_count = (pw_grid%npts + native_grid_adjoint_tile_edge - 1)/ &
3228 native_grid_adjoint_tile_edge
3229 cpassert(all(tile_count == expected_tile_count))
3230 cpassert(tile_index >= 1 .AND. tile_index <= product(tile_count))
3231 linear_tile = tile_index - 1
3232 tile_coord(1) = mod(linear_tile, tile_count(1))
3233 linear_tile = linear_tile/tile_count(1)
3234 tile_coord(2) = mod(linear_tile, tile_count(2))
3235 tile_coord(3) = linear_tile/tile_count(2)
3236 tile_lower = tile_coord*native_grid_adjoint_tile_edge
3237 tile_upper = min(tile_lower + native_grid_adjoint_tile_edge - 1, pw_grid%npts - 1)
3238
3239 END SUBROUTINE native_grid_adjoint_tile_bounds
3240
3241! **************************************************************************************************
3242!> \brief Apply the primitive-field interpolation transpose inside one disjoint PW tile.
3243!> \param density ...
3244!> \param grad ...
3245!> \param kin ...
3246!> \param pw_grid ...
3247!> \param stencil ...
3248!> \param density_value ...
3249!> \param grad_value ...
3250!> \param kin_value ...
3251!> \param nchannels number of spin channels accumulated by the adjoint
3252!> \param tile_lower zero-based lower grid index owned by this call
3253!> \param tile_upper zero-based upper grid index owned by this call
3254! **************************************************************************************************
3255 SUBROUTINE add_native_grid_fields_adjoint_tile( &
3256 density, grad, kin, pw_grid, stencil, density_value, grad_value, kin_value, nchannels, &
3257 tile_lower, tile_upper)
3258 REAL(kind=dp), DIMENSION(:, :), INTENT(INOUT) :: density
3259 REAL(kind=dp), DIMENSION(:, :, :), INTENT(INOUT) :: grad
3260 REAL(kind=dp), DIMENSION(:, :), INTENT(INOUT) :: kin
3261 TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
3262 TYPE(native_grid_interpolation_stencil_type), &
3263 INTENT(IN) :: stencil
3264 REAL(kind=dp), DIMENSION(:), INTENT(IN) :: density_value
3265 REAL(kind=dp), DIMENSION(:, :), INTENT(IN) :: grad_value
3266 REAL(kind=dp), DIMENSION(:), INTENT(IN) :: kin_value
3267 INTEGER, INTENT(IN) :: nchannels
3268 INTEGER, DIMENSION(3), INTENT(IN) :: tile_lower, tile_upper
3269
3270 INTEGER :: idir, inode_x, inode_y, inode_z, ipt, &
3271 ispin
3272 INTEGER, DIMENSION(3) :: relative_index
3273 REAL(kind=dp) :: coefficient
3274
3275 cpassert(ASSOCIATED(pw_grid))
3276 cpassert(SIZE(density, 1) == product(pw_grid%npts))
3277 cpassert(SIZE(density, 2) == nchannels)
3278 cpassert(SIZE(grad, 1) == product(pw_grid%npts))
3279 cpassert(SIZE(grad, 2) == 3)
3280 cpassert(SIZE(grad, 3) == nchannels)
3281 cpassert(SIZE(kin, 1) == product(pw_grid%npts))
3282 cpassert(SIZE(kin, 2) == nchannels)
3283 cpassert(SIZE(density_value) == 2)
3284 cpassert(all(shape(grad_value) == [3, 2]))
3285 cpassert(SIZE(kin_value) == 2)
3286 cpassert(nchannels >= 1 .AND. nchannels <= 2)
3287 cpassert(all(tile_lower >= 0))
3288 cpassert(all(tile_upper >= tile_lower))
3289 cpassert(all(tile_upper < pw_grid%npts))
3290 IF (.NOT. stencil%active) RETURN
3291 DO inode_z = 1, native_grid_interp_npts
3292 IF (.NOT. stencil%valid(inode_z, 3)) cycle
3293 relative_index(3) = stencil%relative_index(inode_z, 3)
3294 IF (relative_index(3) < tile_lower(3) .OR. relative_index(3) > tile_upper(3)) cycle
3295 DO inode_y = 1, native_grid_interp_npts
3296 IF (.NOT. stencil%valid(inode_y, 2)) cycle
3297 relative_index(2) = stencil%relative_index(inode_y, 2)
3298 IF (relative_index(2) < tile_lower(2) .OR. relative_index(2) > tile_upper(2)) cycle
3299 DO inode_x = 1, native_grid_interp_npts
3300 IF (.NOT. stencil%valid(inode_x, 1)) cycle
3301 relative_index(1) = stencil%relative_index(inode_x, 1)
3302 IF (relative_index(1) < tile_lower(1) .OR. relative_index(1) > tile_upper(1)) cycle
3303 ipt = 1 + relative_index(1) + pw_grid%npts(1)*( &
3304 relative_index(2) + pw_grid%npts(2)*relative_index(3))
3305 coefficient = stencil%weight(inode_x, 1)* &
3306 stencil%weight(inode_y, 2)* &
3307 stencil%weight(inode_z, 3)
3308 DO ispin = 1, nchannels
3309 density(ipt, ispin) = density(ipt, ispin) + coefficient*density_value(ispin)
3310 DO idir = 1, 3
3311 grad(ipt, idir, ispin) = grad(ipt, idir, ispin) + &
3312 coefficient*grad_value(idir, ispin)
3313 END DO
3314 kin(ipt, ispin) = kin(ipt, ispin) + coefficient*kin_value(ispin)
3315 END DO
3316 END DO
3317 END DO
3318 END DO
3319
3320 END SUBROUTINE add_native_grid_fields_adjoint_tile
3321
3322! **************************************************************************************************
3323!> \brief Interpolate a replicated native-grid field at a Cartesian point.
3324!> \param values ...
3325!> \param pw_grid ...
3326!> \param cell ...
3327!> \param point ...
3328!> \param wrap_auxiliary_cell wrap all auxiliary-grid directions
3329!> \return ...
3330! **************************************************************************************************
3331 FUNCTION interpolate_native_grid(values, pw_grid, cell, point, wrap_auxiliary_cell) RESULT(value)
3332 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: values
3333 TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
3334 TYPE(cell_type), INTENT(IN), POINTER :: cell
3335 REAL(kind=dp), DIMENSION(3), INTENT(IN) :: point
3336 LOGICAL, INTENT(IN), OPTIONAL :: wrap_auxiliary_cell
3337 REAL(kind=dp) :: value
3338
3339 INTEGER :: corner_x, corner_y, corner_z, idir
3340 INTEGER, DIMENSION(3) :: base, index, relative_index
3341 LOGICAL :: wrap_grid
3342 REAL(kind=dp) :: coefficient
3343 REAL(kind=dp), DIMENSION(3) :: fraction, relative
3344 REAL(kind=dp), &
3345 DIMENSION(native_grid_interp_npts, 3) :: weights
3346
3347 cpassert(ASSOCIATED(pw_grid))
3348 cpassert(ASSOCIATED(cell))
3349 DO idir = 1, 3
3350 cpassert(SIZE(values, idir) == pw_grid%npts(idir))
3351 END DO
3352
3353 wrap_grid = any(cell%perd == 0)
3354 IF (PRESENT(wrap_auxiliary_cell)) wrap_grid = wrap_auxiliary_cell
3355 relative = matmul(pw_grid%dh_inv, point)
3356 DO idir = 1, 3
3357 IF (cell%perd(idir) == 1 .OR. wrap_grid) THEN
3358 relative(idir) = modulo(relative(idir), real(pw_grid%npts(idir), kind=dp))
3359 ELSE IF (relative(idir) <= -real(native_grid_interp_offset_max, dp) .OR. &
3360 relative(idir) >= real(pw_grid%npts(idir) - &
3361 native_grid_interp_offset_min, kind=dp)) THEN
3362 value = 0.0_dp
3363 RETURN
3364 END IF
3365 base(idir) = floor(relative(idir))
3366 fraction(idir) = relative(idir) - real(base(idir), kind=dp)
3367 CALL native_grid_lagrange_weights(fraction(idir), weights(:, idir))
3368 END DO
3369
3370 value = 0.0_dp
3371 DO corner_z = native_grid_interp_offset_min, native_grid_interp_offset_max
3372 DO corner_y = native_grid_interp_offset_min, native_grid_interp_offset_max
3373 DO corner_x = native_grid_interp_offset_min, native_grid_interp_offset_max
3374 relative_index = base + [corner_x, corner_y, corner_z]
3375 coefficient = weights(corner_x - native_grid_interp_offset_min + 1, 1)* &
3376 weights(corner_y - native_grid_interp_offset_min + 1, 2)* &
3377 weights(corner_z - native_grid_interp_offset_min + 1, 3)
3378 DO idir = 1, 3
3379 IF (cell%perd(idir) == 1 .OR. wrap_grid) THEN
3380 relative_index(idir) = modulo(relative_index(idir), pw_grid%npts(idir))
3381 ELSE IF (relative_index(idir) < 0 .OR. &
3382 relative_index(idir) >= pw_grid%npts(idir)) THEN
3383 coefficient = 0.0_dp
3384 END IF
3385 END DO
3386 IF (coefficient == 0.0_dp) cycle
3387 index = lbound(values) + relative_index
3388 value = value + coefficient*values(index(1), index(2), index(3))
3389 END DO
3390 END DO
3391 END DO
3392
3393 END FUNCTION interpolate_native_grid
3394
3395! **************************************************************************************************
3396!> \brief Return the Cartesian gradient of native-grid interpolation at one point.
3397!> \param values ...
3398!> \param pw_grid ...
3399!> \param cell ...
3400!> \param point ...
3401!> \param wrap_auxiliary_cell wrap all auxiliary-grid directions
3402!> \return ...
3403! **************************************************************************************************
3404 FUNCTION interpolate_native_grid_gradient(values, pw_grid, cell, point, &
3405 wrap_auxiliary_cell) RESULT(gradient)
3406 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: values
3407 TYPE(pw_grid_type), INTENT(IN), POINTER :: pw_grid
3408 TYPE(cell_type), INTENT(IN), POINTER :: cell
3409 REAL(kind=dp), DIMENSION(3), INTENT(IN) :: point
3410 LOGICAL, INTENT(IN), OPTIONAL :: wrap_auxiliary_cell
3411 REAL(kind=dp), DIMENSION(3) :: gradient
3412
3413 INTEGER :: corner_x, corner_y, corner_z, idir, jdir
3414 INTEGER, DIMENSION(3) :: base, corner_index, index, relative_index
3415 LOGICAL :: wrap_grid
3416 REAL(kind=dp) :: coefficient
3417 REAL(kind=dp), DIMENSION(3) :: fraction, gradient_relative, relative
3418 REAL(kind=dp), &
3419 DIMENSION(native_grid_interp_npts, 3) :: derivative_weights, weights
3420
3421 cpassert(ASSOCIATED(pw_grid))
3422 cpassert(ASSOCIATED(cell))
3423 DO idir = 1, 3
3424 cpassert(SIZE(values, idir) == pw_grid%npts(idir))
3425 END DO
3426
3427 wrap_grid = any(cell%perd == 0)
3428 IF (PRESENT(wrap_auxiliary_cell)) wrap_grid = wrap_auxiliary_cell
3429 relative = matmul(pw_grid%dh_inv, point)
3430 DO idir = 1, 3
3431 IF (cell%perd(idir) == 1 .OR. wrap_grid) THEN
3432 relative(idir) = modulo(relative(idir), real(pw_grid%npts(idir), kind=dp))
3433 ELSE IF (relative(idir) <= -real(native_grid_interp_offset_max, dp) .OR. &
3434 relative(idir) >= real(pw_grid%npts(idir) - &
3435 native_grid_interp_offset_min, kind=dp)) THEN
3436 gradient = 0.0_dp
3437 RETURN
3438 END IF
3439 base(idir) = floor(relative(idir))
3440 fraction(idir) = relative(idir) - real(base(idir), kind=dp)
3441 CALL native_grid_lagrange_weights( &
3442 fraction(idir), weights(:, idir), derivative_weights(:, idir))
3443 END DO
3444
3445 gradient_relative = 0.0_dp
3446 DO corner_z = native_grid_interp_offset_min, native_grid_interp_offset_max
3447 DO corner_y = native_grid_interp_offset_min, native_grid_interp_offset_max
3448 DO corner_x = native_grid_interp_offset_min, native_grid_interp_offset_max
3449 relative_index = base + [corner_x, corner_y, corner_z]
3450 corner_index = [corner_x, corner_y, corner_z] - &
3451 native_grid_interp_offset_min + 1
3452 DO idir = 1, 3
3453 IF (cell%perd(idir) == 1 .OR. wrap_grid) THEN
3454 relative_index(idir) = modulo(relative_index(idir), pw_grid%npts(idir))
3455 ELSE IF (relative_index(idir) < 0 .OR. &
3456 relative_index(idir) >= pw_grid%npts(idir)) THEN
3457 EXIT
3458 END IF
3459 END DO
3460 IF (idir <= 3) cycle
3461 index = lbound(values) + relative_index
3462 DO idir = 1, 3
3463 coefficient = 1.0_dp
3464 DO jdir = 1, 3
3465 IF (jdir == idir) THEN
3466 coefficient = coefficient*derivative_weights( &
3467 corner_index(jdir), jdir)
3468 ELSE
3469 coefficient = coefficient*weights( &
3470 corner_index(jdir), jdir)
3471 END IF
3472 END DO
3473 gradient_relative(idir) = gradient_relative(idir) + &
3474 coefficient*values(index(1), index(2), index(3))
3475 END DO
3476 END DO
3477 END DO
3478 END DO
3479 gradient = matmul(transpose(pw_grid%dh_inv), gradient_relative)
3480
3481 END FUNCTION interpolate_native_grid_gradient
3482
3483! **************************************************************************************************
3484!> \brief Build the value and optional derivative weights for the native-grid interpolation.
3485!> \param fraction fractional coordinate between two grid points
3486!> \param weights interpolation weights
3487!> \param derivative_weights optional derivatives with respect to fraction
3488! **************************************************************************************************
3489 SUBROUTINE native_grid_lagrange_weights(fraction, weights, derivative_weights)
3490 REAL(kind=dp), INTENT(IN) :: fraction
3491 REAL(kind=dp), DIMENSION(:), INTENT(OUT) :: weights
3492 REAL(kind=dp), DIMENSION(:), INTENT(OUT), OPTIONAL :: derivative_weights
3493
3494 INTEGER :: inode, jnode, knode, npoints
3495 REAL(kind=dp) :: denominator, derivative, numerator
3496 REAL(kind=dp), DIMENSION(SIZE(weights)) :: nodes
3497
3498 npoints = SIZE(weights)
3499 IF (PRESENT(derivative_weights)) THEN
3500 cpassert(SIZE(derivative_weights) == npoints)
3501 END IF
3502 DO inode = 1, npoints
3503 nodes(inode) = real(native_grid_interp_offset_min + inode - 1, dp)
3504 END DO
3505 DO inode = 1, npoints
3506 denominator = 1.0_dp
3507 numerator = 1.0_dp
3508 DO jnode = 1, npoints
3509 IF (jnode == inode) cycle
3510 denominator = denominator*(nodes(inode) - nodes(jnode))
3511 numerator = numerator*(fraction - nodes(jnode))
3512 END DO
3513 weights(inode) = numerator/denominator
3514 IF (PRESENT(derivative_weights)) THEN
3515 derivative = 0.0_dp
3516 DO knode = 1, npoints
3517 IF (knode == inode) cycle
3518 numerator = 1.0_dp
3519 DO jnode = 1, npoints
3520 IF (jnode == inode .OR. jnode == knode) cycle
3521 numerator = numerator*(fraction - nodes(jnode))
3522 END DO
3523 derivative = derivative + numerator/denominator
3524 END DO
3525 derivative_weights(inode) = derivative
3526 END IF
3527 END DO
3528
3529 END SUBROUTINE native_grid_lagrange_weights
3530
3531! **************************************************************************************************
3532!> \brief Compact support radius of one hard-minus-soft atom-grid field.
3533!> \param grid_atom radial and angular source grid
3534!> \param rho_h hard one-center density values
3535!> \param rho_s soft one-center density values
3536!> \param drho_h hard one-center density-gradient values
3537!> \param drho_s soft one-center density-gradient values
3538!> \param tau_h hard one-center kinetic-energy-density values
3539!> \param tau_s soft one-center kinetic-energy-density values
3540!> \return outermost radius required by any primitive hard-minus-soft field
3541! **************************************************************************************************
3542 FUNCTION gapw_atom_grid_support_radius( &
3543 grid_atom, rho_h, rho_s, drho_h, drho_s, tau_h, tau_s) RESULT(cutoff)
3544 TYPE(grid_atom_type), POINTER :: grid_atom
3545 REAL(dp), DIMENSION(:, :, :), INTENT(IN) :: rho_h, rho_s
3546 REAL(dp), DIMENSION(:, :, :, :), INTENT(IN) :: drho_h, drho_s
3547 REAL(dp), DIMENSION(:, :, :), INTENT(IN) :: tau_h, tau_s
3548 REAL(dp) :: cutoff
3549
3550 INTEGER :: ir, support_ir
3551 LOGICAL :: descending
3552 REAL(dp) :: amplitude
3553
3554 cutoff = 0.0_dp
3555 descending = grid_atom%rad(1) > grid_atom%rad(grid_atom%nr)
3556 IF (descending) THEN
3557 DO ir = 1, grid_atom%nr
3558 amplitude = max( &
3559 maxval(abs(rho_h(:, ir, :) - rho_s(:, ir, :))), &
3560 maxval(abs(drho_h(1:3, :, ir, :) - drho_s(1:3, :, ir, :))), &
3561 maxval(abs(tau_h(:, ir, :) - tau_s(:, ir, :))))
3562 IF (amplitude > 1.0e-12_dp) THEN
3563 support_ir = max(1, ir - 2)
3564 cutoff = grid_atom%rad(support_ir)
3565 RETURN
3566 END IF
3567 END DO
3568 ELSE
3569 DO ir = grid_atom%nr, 1, -1
3570 amplitude = max( &
3571 maxval(abs(rho_h(:, ir, :) - rho_s(:, ir, :))), &
3572 maxval(abs(drho_h(1:3, :, ir, :) - drho_s(1:3, :, ir, :))), &
3573 maxval(abs(tau_h(:, ir, :) - tau_s(:, ir, :))))
3574 IF (amplitude > 1.0e-12_dp) THEN
3575 support_ir = min(grid_atom%nr, ir + 2)
3576 cutoff = grid_atom%rad(support_ir)
3577 RETURN
3578 END IF
3579 END DO
3580 END IF
3581
3582 END FUNCTION gapw_atom_grid_support_radius
3583
3584! **************************************************************************************************
3585!> \brief Express one radial node's first and second derivatives as linear combinations of the
3586!> local node values used by the C2-continuous quintic Hermite interpolant.
3587!> \param grid_atom radial source grid
3588!> \param descending whether radial nodes are stored in descending order
3589!> \param node logical index of the node whose derivatives are required
3590!> \param logical_start first logical index represented by the coefficient arrays
3591!> \param slope coefficients of the first derivative
3592!> \param curvature coefficients of the second derivative
3593! **************************************************************************************************
3594 SUBROUTINE radial_node_derivative_coefficients( &
3595 grid_atom, descending, node, logical_start, slope, curvature)
3596 TYPE(grid_atom_type), POINTER :: grid_atom
3597 LOGICAL, INTENT(IN) :: descending
3598 INTEGER, INTENT(IN) :: node, logical_start
3599 REAL(dp), DIMENSION(4), INTENT(OUT) :: slope, curvature
3600
3601 INTEGER :: center, hi, lo, n
3602 REAL(dp) :: h_hi, h_lo, x_center, x_hi, x_lo
3603
3604 n = grid_atom%nr
3605 slope = 0.0_dp
3606 curvature = 0.0_dp
3607 IF (node == 1) THEN
3608 lo = 1
3609 hi = 2
3610 ELSE IF (node == n) THEN
3611 lo = n - 1
3612 hi = n
3613 ELSE
3614 lo = node - 1
3615 hi = node + 1
3616 END IF
3617 x_lo = grid_atom%rad(merge(n + 1 - lo, lo, descending))
3618 x_hi = grid_atom%rad(merge(n + 1 - hi, hi, descending))
3619 slope(lo - logical_start + 1) = -1.0_dp/(x_hi - x_lo)
3620 slope(hi - logical_start + 1) = 1.0_dp/(x_hi - x_lo)
3621
3622 IF (n < 3) RETURN
3623 center = min(max(node, 2), n - 1)
3624 lo = center - 1
3625 hi = center + 1
3626 x_lo = grid_atom%rad(merge(n + 1 - lo, lo, descending))
3627 x_center = grid_atom%rad(merge(n + 1 - center, center, descending))
3628 x_hi = grid_atom%rad(merge(n + 1 - hi, hi, descending))
3629 h_lo = x_center - x_lo
3630 h_hi = x_hi - x_center
3631 curvature(lo - logical_start + 1) = 2.0_dp/(h_lo*(h_lo + h_hi))
3632 curvature(center - logical_start + 1) = &
3633 -2.0_dp*(1.0_dp/h_lo + 1.0_dp/h_hi)/(h_lo + h_hi)
3634 curvature(hi - logical_start + 1) = 2.0_dp/(h_hi*(h_lo + h_hi))
3635
3636 END SUBROUTINE radial_node_derivative_coefficients
3637
3638! **************************************************************************************************
3639!> \brief Build mutually consistent value and Cartesian-derivative weights for interpolation from
3640!> a GAPW radial/Lebedev atom grid to one arbitrary local displacement.
3641!> \param grid_atom source atom grid
3642!> \param harmonics source spherical harmonics
3643!> \param displacement point minus source-image coordinate
3644!> \param cutoff compact support radius
3645!> \param radial_indices active radial nodes
3646!> \param radial_weights interpolation weights on the active radial nodes
3647!> \param radial_derivative_weights radial derivatives of the interpolation weights
3648!> \param nradial number of active radial nodes
3649!> \param angular_weights angular interpolation weights
3650!> \param angular_derivative_weights Cartesian derivatives of the angular weights
3651!> \param active whether the point lies inside the compact support
3652! **************************************************************************************************
3653 SUBROUTINE atom_grid_interpolation_weights( &
3654 grid_atom, harmonics, displacement, cutoff, radial_indices, radial_weights, &
3655 radial_derivative_weights, nradial, angular_weights, angular_derivative_weights, active)
3656 TYPE(grid_atom_type), POINTER :: grid_atom
3657 TYPE(harmonics_atom_type), POINTER :: harmonics
3658 REAL(dp), DIMENSION(3), INTENT(IN) :: displacement
3659 REAL(dp), INTENT(IN) :: cutoff
3660 INTEGER, DIMENSION(4), INTENT(OUT) :: radial_indices
3661 REAL(dp), DIMENSION(4), INTENT(OUT) :: radial_weights, radial_derivative_weights
3662 INTEGER, INTENT(OUT) :: nradial
3663 REAL(dp), DIMENSION(:), INTENT(OUT) :: angular_weights
3664 REAL(dp), DIMENSION(:, :), INTENT(OUT) :: angular_derivative_weights
3665 LOGICAL, INTENT(OUT) :: active
3666
3667 INTEGER :: ia, ic, inode, iso, l, left, left_pos, &
3668 logical_end, logical_start, lx, ly, &
3669 lz, n, right_pos, shell_index
3670 LOGICAL :: descending
3671 REAL(dp) :: dh00, dh01, dh10, dh11, dh20, dh21, h00, &
3672 h01, h10, h11, h20, h21, h_interval, &
3673 monomial, radius, solid_derivative, t, &
3674 x1, x2
3675 REAL(dp), DIMENSION(3) :: direction
3676 REAL(dp), DIMENSION(harmonics%max_s_harm) :: angular_values
3677 REAL(dp), DIMENSION(4) :: curvature_left, curvature_right, &
3678 slope_left, slope_right
3679 REAL(dp), DIMENSION(3, harmonics%max_s_harm) :: angular_value_derivatives
3680
3681 cpassert(ASSOCIATED(grid_atom))
3682 cpassert(ASSOCIATED(harmonics))
3683 cpassert(SIZE(angular_weights) == grid_atom%ng_sphere)
3684 cpassert(SIZE(angular_derivative_weights, 1) == 3)
3685 cpassert(SIZE(angular_derivative_weights, 2) == grid_atom%ng_sphere)
3686
3687 radial_indices = 0
3688 radial_weights = 0.0_dp
3689 radial_derivative_weights = 0.0_dp
3690 angular_weights = 0.0_dp
3691 angular_derivative_weights = 0.0_dp
3692 nradial = 0
3693 active = .false.
3694 n = grid_atom%nr
3695 descending = grid_atom%rad(1) > grid_atom%rad(n)
3696 radius = sqrt(sum(displacement**2))
3697 IF (radius > cutoff .OR. &
3698 radius > grid_atom%rad(merge(1, n, descending))) RETURN
3699 IF (radius <= 1.0e-12_dp) RETURN
3700 direction = displacement/radius
3701
3702 cpassert(n >= 2)
3703 left = n - 1
3704 IF (radius <= grid_atom%rad(merge(n, 1, descending))) THEN
3705 left = 1
3706 ELSE
3707 DO inode = 1, n - 1
3708 IF (radius <= grid_atom%rad(merge(n - inode, inode + 1, descending))) THEN
3709 left = inode
3710 EXIT
3711 END IF
3712 END DO
3713 END IF
3714
3715 logical_start = max(1, left - 1)
3716 logical_end = min(n, left + 2)
3717 nradial = logical_end - logical_start + 1
3718 DO inode = 1, nradial
3719 radial_indices(inode) = merge(n + 2 - logical_start - inode, &
3720 logical_start + inode - 1, descending)
3721 END DO
3722 left_pos = left - logical_start + 1
3723 right_pos = left_pos + 1
3724 x1 = grid_atom%rad(radial_indices(left_pos))
3725 x2 = grid_atom%rad(radial_indices(right_pos))
3726 h_interval = x2 - x1
3727 t = (radius - x1)/h_interval
3728
3729 h00 = 1.0_dp - 10.0_dp*t**3 + 15.0_dp*t**4 - 6.0_dp*t**5
3730 h10 = t - 6.0_dp*t**3 + 8.0_dp*t**4 - 3.0_dp*t**5
3731 h20 = 0.5_dp*(t**2 - 3.0_dp*t**3 + 3.0_dp*t**4 - t**5)
3732 h01 = 10.0_dp*t**3 - 15.0_dp*t**4 + 6.0_dp*t**5
3733 h11 = -4.0_dp*t**3 + 7.0_dp*t**4 - 3.0_dp*t**5
3734 h21 = 0.5_dp*(t**3 - 2.0_dp*t**4 + t**5)
3735 dh00 = -30.0_dp*t**2 + 60.0_dp*t**3 - 30.0_dp*t**4
3736 dh10 = 1.0_dp - 18.0_dp*t**2 + 32.0_dp*t**3 - 15.0_dp*t**4
3737 dh20 = 0.5_dp*(2.0_dp*t - 9.0_dp*t**2 + 12.0_dp*t**3 - 5.0_dp*t**4)
3738 dh01 = 30.0_dp*t**2 - 60.0_dp*t**3 + 30.0_dp*t**4
3739 dh11 = -12.0_dp*t**2 + 28.0_dp*t**3 - 15.0_dp*t**4
3740 dh21 = 0.5_dp*(3.0_dp*t**2 - 8.0_dp*t**3 + 5.0_dp*t**4)
3741
3742 CALL radial_node_derivative_coefficients( &
3743 grid_atom, descending, left, logical_start, slope_left, curvature_left)
3744 CALL radial_node_derivative_coefficients( &
3745 grid_atom, descending, left + 1, logical_start, slope_right, curvature_right)
3746 radial_weights(left_pos) = radial_weights(left_pos) + h00
3747 radial_weights(right_pos) = radial_weights(right_pos) + h01
3748 radial_weights(1:nradial) = radial_weights(1:nradial) + &
3749 h_interval*(h10*slope_left(1:nradial) + &
3750 h11*slope_right(1:nradial)) + &
3751 h_interval**2*(h20*curvature_left(1:nradial) + &
3752 h21*curvature_right(1:nradial))
3753 radial_derivative_weights(left_pos) = &
3754 radial_derivative_weights(left_pos) + dh00/h_interval
3755 radial_derivative_weights(right_pos) = &
3756 radial_derivative_weights(right_pos) + dh01/h_interval
3757 radial_derivative_weights(1:nradial) = radial_derivative_weights(1:nradial) + &
3758 dh10*slope_left(1:nradial) + &
3759 dh11*slope_right(1:nradial) + &
3760 h_interval*(dh20*curvature_left(1:nradial) + &
3761 dh21*curvature_right(1:nradial))
3762
3763 angular_values = 0.0_dp
3764 angular_value_derivatives = 0.0_dp
3765 DO iso = 1, harmonics%max_s_harm
3766 l = indso(1, iso)
3767 CALL y_lm(direction, angular_values(iso), l, indso(2, iso))
3768 IF (l == 0) cycle
3769 shell_index = iso - nsoset(l - 1)
3770 DO ic = 1, nco(l)
3771 lx = indco(1, ic + ncoset(l - 1))
3772 ly = indco(2, ic + ncoset(l - 1))
3773 lz = indco(3, ic + ncoset(l - 1))
3774 IF (lx > 0) THEN
3775 monomial = real(lx, dp)*direction(1)**(lx - 1)* &
3776 direction(2)**ly*direction(3)**lz
3777 angular_value_derivatives(1, iso) = angular_value_derivatives(1, iso) + &
3778 orbtramat(l)%slm(shell_index, ic)*monomial
3779 END IF
3780 IF (ly > 0) THEN
3781 monomial = direction(1)**lx*real(ly, dp)*direction(2)**(ly - 1)* &
3782 direction(3)**lz
3783 angular_value_derivatives(2, iso) = angular_value_derivatives(2, iso) + &
3784 orbtramat(l)%slm(shell_index, ic)*monomial
3785 END IF
3786 IF (lz > 0) THEN
3787 monomial = direction(1)**lx*direction(2)**ly* &
3788 REAL(lz, dp)*direction(3)**(lz - 1)
3789 angular_value_derivatives(3, iso) = angular_value_derivatives(3, iso) + &
3790 orbtramat(l)%slm(shell_index, ic)*monomial
3791 END IF
3792 END DO
3793 DO inode = 1, 3
3794 solid_derivative = angular_value_derivatives(inode, iso)
3795 angular_value_derivatives(inode, iso) = (solid_derivative - &
3796 REAL(l, dp)*angular_values(iso)* &
3797 direction(inode))/radius
3798 END DO
3799 END DO
3800
3801 DO ia = 1, grid_atom%ng_sphere
3802 angular_weights(ia) = grid_atom%wa(ia)* &
3803 dot_product(harmonics%slm(ia, 1:harmonics%max_s_harm), &
3804 angular_values)
3805 DO inode = 1, 3
3806 angular_derivative_weights(inode, ia) = grid_atom%wa(ia)* &
3807 dot_product(harmonics%slm(ia, 1:harmonics%max_s_harm), &
3808 angular_value_derivatives(inode, :))
3809 END DO
3810 END DO
3811 active = .true.
3812
3813 END SUBROUTINE atom_grid_interpolation_weights
3814
3815! **************************************************************************************************
3816!> \brief Interpolate hard-minus-soft primitive fields and their spatial derivatives from one
3817!> GAPW atom grid.
3818!> \param grid_atom radial and angular source grid
3819!> \param harmonics spherical-harmonic representation of the source grid
3820!> \param displacement target point relative to the source-atom image
3821!> \param cutoff compact support radius of the source fields
3822!> \param nspins number of spin channels
3823!> \param rho_h hard one-center density values
3824!> \param rho_s soft one-center density values
3825!> \param drho_h hard one-center density-gradient values
3826!> \param drho_s soft one-center density-gradient values
3827!> \param tau_h hard one-center kinetic-energy-density values
3828!> \param tau_s soft one-center kinetic-energy-density values
3829!> \param density interpolated hard-minus-soft density
3830!> \param gradient interpolated hard-minus-soft density gradient
3831!> \param kin interpolated hard-minus-soft kinetic-energy density
3832!> \param density_spatial Cartesian derivatives of density
3833!> \param gradient_spatial Cartesian derivatives of the density gradient
3834!> \param kin_spatial Cartesian derivatives of the kinetic-energy density
3835! **************************************************************************************************
3836 SUBROUTINE interpolate_gapw_atom_grid_fields( &
3837 grid_atom, harmonics, displacement, cutoff, nspins, rho_h, rho_s, drho_h, drho_s, &
3838 tau_h, tau_s, density, gradient, kin, density_spatial, gradient_spatial, kin_spatial)
3839 TYPE(grid_atom_type), POINTER :: grid_atom
3840 TYPE(harmonics_atom_type), POINTER :: harmonics
3841 REAL(dp), DIMENSION(3), INTENT(IN) :: displacement
3842 REAL(dp), INTENT(IN) :: cutoff
3843 INTEGER, INTENT(IN) :: nspins
3844 REAL(dp), DIMENSION(:, :, :), INTENT(IN) :: rho_h, rho_s
3845 REAL(dp), DIMENSION(:, :, :, :), INTENT(IN) :: drho_h, drho_s
3846 REAL(dp), DIMENSION(:, :, :), INTENT(IN) :: tau_h, tau_s
3847 REAL(dp), DIMENSION(2), INTENT(OUT) :: density
3848 REAL(dp), DIMENSION(3, 2), INTENT(OUT) :: gradient
3849 REAL(dp), DIMENSION(2), INTENT(OUT) :: kin
3850 REAL(dp), DIMENSION(3, 2), INTENT(OUT) :: density_spatial
3851 REAL(dp), DIMENSION(3, 3, 2), INTENT(OUT) :: gradient_spatial
3852 REAL(dp), DIMENSION(3, 2), INTENT(OUT) :: kin_spatial
3853
3854 INTEGER :: ia, idir, inode, ir, ispin, jdir, nradial
3855 INTEGER, DIMENSION(4) :: radial_indices
3856 LOGICAL :: active
3857 REAL(dp) :: derivative_weight, weight
3858 REAL(dp), DIMENSION(grid_atom%ng_sphere) :: angular_weights
3859 REAL(dp), DIMENSION(4) :: radial_derivative_weights, radial_weights
3860 REAL(dp), DIMENSION(3, grid_atom%ng_sphere) :: angular_derivative_weights
3861
3862 density = 0.0_dp
3863 gradient = 0.0_dp
3864 kin = 0.0_dp
3865 density_spatial = 0.0_dp
3866 gradient_spatial = 0.0_dp
3867 kin_spatial = 0.0_dp
3868 CALL atom_grid_interpolation_weights( &
3869 grid_atom, harmonics, displacement, cutoff, radial_indices, radial_weights, &
3870 radial_derivative_weights, nradial, angular_weights, angular_derivative_weights, active)
3871 IF (active) THEN
3872 DO inode = 1, nradial
3873 ir = radial_indices(inode)
3874 DO ia = 1, grid_atom%ng_sphere
3875 weight = radial_weights(inode)*angular_weights(ia)
3876 DO ispin = 1, nspins
3877 density(ispin) = density(ispin) + &
3878 weight*(rho_h(ia, ir, ispin) - rho_s(ia, ir, ispin))
3879 kin(ispin) = kin(ispin) + &
3880 weight*(tau_h(ia, ir, ispin) - tau_s(ia, ir, ispin))
3881 DO idir = 1, 3
3882 gradient(idir, ispin) = gradient(idir, ispin) + &
3883 weight*(drho_h(idir, ia, ir, ispin) - &
3884 drho_s(idir, ia, ir, ispin))
3885 derivative_weight = radial_derivative_weights(inode)* &
3886 displacement(idir)/sqrt(sum(displacement**2))* &
3887 angular_weights(ia) + radial_weights(inode)* &
3888 angular_derivative_weights(idir, ia)
3889 density_spatial(idir, ispin) = density_spatial(idir, ispin) + &
3890 derivative_weight*(rho_h(ia, ir, ispin) - rho_s(ia, ir, ispin))
3891 kin_spatial(idir, ispin) = kin_spatial(idir, ispin) + &
3892 derivative_weight*(tau_h(ia, ir, ispin) - tau_s(ia, ir, ispin))
3893 DO jdir = 1, 3
3894 gradient_spatial(jdir, idir, ispin) = &
3895 gradient_spatial(jdir, idir, ispin) + derivative_weight*( &
3896 drho_h(jdir, ia, ir, ispin) - drho_s(jdir, ia, ir, ispin))
3897 END DO
3898 END DO
3899 END DO
3900 END DO
3901 END DO
3902 END IF
3903 END SUBROUTINE interpolate_gapw_atom_grid_fields
3904
3905! **************************************************************************************************
3906!> \brief Apply the exact transpose of interpolate_gapw_atom_grid_fields to one-center potentials.
3907!> \param grid_atom radial and angular source grid
3908!> \param harmonics spherical-harmonic representation of the source grid
3909!> \param displacement target point relative to the source-atom image
3910!> \param cutoff compact support radius of the source fields
3911!> \param nspins number of spin channels
3912!> \param density_adjoint model derivative with respect to density
3913!> \param gradient_adjoint model derivative with respect to the density gradient
3914!> \param kin_adjoint model derivative with respect to kinetic-energy density
3915!> \param vxc_h accumulated hard one-center density potential
3916!> \param vxc_s accumulated soft one-center density potential
3917!> \param vxg_h accumulated hard one-center density-gradient potential
3918!> \param vxg_s accumulated soft one-center density-gradient potential
3919!> \param vtau_h accumulated hard one-center kinetic-energy-density potential
3920!> \param vtau_s accumulated soft one-center kinetic-energy-density potential
3921! **************************************************************************************************
3922 SUBROUTINE add_gapw_atom_grid_interpolation_adjoint( &
3923 grid_atom, harmonics, displacement, cutoff, nspins, density_adjoint, gradient_adjoint, &
3924 kin_adjoint, vxc_h, vxc_s, vxg_h, vxg_s, vtau_h, vtau_s)
3925 TYPE(grid_atom_type), POINTER :: grid_atom
3926 TYPE(harmonics_atom_type), POINTER :: harmonics
3927 REAL(dp), DIMENSION(3), INTENT(IN) :: displacement
3928 REAL(dp), INTENT(IN) :: cutoff
3929 INTEGER, INTENT(IN) :: nspins
3930 REAL(dp), DIMENSION(2), INTENT(IN) :: density_adjoint
3931 REAL(dp), DIMENSION(3, 2), INTENT(IN) :: gradient_adjoint
3932 REAL(dp), DIMENSION(2), INTENT(IN) :: kin_adjoint
3933 REAL(dp), DIMENSION(:, :, :), INTENT(INOUT) :: vxc_h, vxc_s
3934 REAL(dp), DIMENSION(:, :, :, :), INTENT(INOUT) :: vxg_h, vxg_s
3935 REAL(dp), DIMENSION(:, :, :), INTENT(INOUT) :: vtau_h, vtau_s
3936
3937 INTEGER :: ia, idir, inode, ir, ispin, nradial
3938 INTEGER, DIMENSION(4) :: radial_indices
3939 LOGICAL :: active
3940 REAL(dp) :: value
3941 REAL(dp), DIMENSION(grid_atom%ng_sphere) :: angular_weights
3942 REAL(dp), DIMENSION(4) :: radial_derivative_weights, radial_weights
3943 REAL(dp), DIMENSION(3, grid_atom%ng_sphere) :: angular_derivative_weights
3944
3945 CALL atom_grid_interpolation_weights( &
3946 grid_atom, harmonics, displacement, cutoff, radial_indices, radial_weights, &
3947 radial_derivative_weights, nradial, angular_weights, angular_derivative_weights, active)
3948 IF (active) THEN
3949 DO inode = 1, nradial
3950 ir = radial_indices(inode)
3951 DO ia = 1, grid_atom%ng_sphere
3952 value = radial_weights(inode)*angular_weights(ia)
3953 DO ispin = 1, nspins
3954 ! CP2K applies the hard-minus-soft sign when the two one-center
3955 ! matrices are assembled, so both stored potentials carry the
3956 ! same transpose-interpolation coefficient.
3957 vxc_h(ia, ir, ispin) = vxc_h(ia, ir, ispin) + value*density_adjoint(ispin)
3958 vxc_s(ia, ir, ispin) = vxc_s(ia, ir, ispin) + value*density_adjoint(ispin)
3959 vtau_h(ia, ir, ispin) = vtau_h(ia, ir, ispin) + value*kin_adjoint(ispin)
3960 vtau_s(ia, ir, ispin) = vtau_s(ia, ir, ispin) + value*kin_adjoint(ispin)
3961 DO idir = 1, 3
3962 vxg_h(idir, ia, ir, ispin) = vxg_h(idir, ia, ir, ispin) + &
3963 value*gradient_adjoint(idir, ispin)
3964 vxg_s(idir, ia, ir, ispin) = vxg_s(idir, ia, ir, ispin) + &
3965 value*gradient_adjoint(idir, ispin)
3966 END DO
3967 END DO
3968 END DO
3969 END DO
3970 END IF
3971 END SUBROUTINE add_gapw_atom_grid_interpolation_adjoint
3972
3973! **************************************************************************************************
3974!> \brief ...
3975!> \param qs_env ...
3976!> \param exc1 the on-body ex energy contribution
3977!> \param gradient_atom_set ...
3978! **************************************************************************************************
3979 SUBROUTINE calculate_vxc_atom_epr(qs_env, exc1, gradient_atom_set)
3980
3981 TYPE(qs_environment_type), POINTER :: qs_env
3982 REAL(dp), INTENT(INOUT) :: exc1
3983 TYPE(nablavks_atom_type), DIMENSION(:), POINTER :: gradient_atom_set
3984
3985 CHARACTER(LEN=*), PARAMETER :: routinen = 'calculate_vxc_atom_epr'
3986
3987 INTEGER :: bo(2), handle, ia, iat, iatom, idir, &
3988 ikind, ir, ispin, myfun, na, natom, &
3989 nr, nspins, num_pe
3990 INTEGER, DIMENSION(2, 3) :: bounds
3991 INTEGER, DIMENSION(:), POINTER :: atom_list
3992 LOGICAL :: accint, donlcc, gradient_f, lsd, nlcc, &
3993 paw_atom, tau_f
3994 REAL(dp) :: agr, alpha, density_cut, exc_h, exc_s, &
3995 gradient_cut, tau_cut
3996 REAL(dp), DIMENSION(1, 1, 1) :: tau_d
3997 REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d
3998 REAL(dp), DIMENSION(:, :), POINTER :: rho_nlcc, weight_h, weight_s
3999 REAL(dp), DIMENSION(:, :, :), POINTER :: rho_h, rho_s, tau_h, tau_s, vtau_h, &
4000 vtau_s, vxc_h, vxc_s
4001 REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s, vxg_h, vxg_s
4002 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
4003 TYPE(dft_control_type), POINTER :: dft_control
4004 TYPE(grid_atom_type), POINTER :: grid_atom
4005 TYPE(gto_basis_set_type), POINTER :: basis_1c
4006 TYPE(harmonics_atom_type), POINTER :: harmonics
4007 TYPE(mp_para_env_type), POINTER :: para_env
4008 TYPE(qs_kind_type), DIMENSION(:), POINTER :: my_kind_set
4009 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s, int_hh, int_ss, r_h, r_s
4010 TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
4011 TYPE(rho_atom_type), DIMENSION(:), POINTER :: my_rho_atom_set
4012 TYPE(rho_atom_type), POINTER :: rho_atom
4013 TYPE(section_vals_type), POINTER :: input, my_xc_section, xc_fun_section
4014 TYPE(tau_basis_cache_type) :: tau_basis_cache
4015 TYPE(xc_derivative_set_type) :: deriv_set
4016 TYPE(xc_rho_cflags_type) :: needs
4017 TYPE(xc_rho_set_type) :: rho_set_h, rho_set_s
4018
4019! -------------------------------------------------------------------------
4020
4021 CALL timeset(routinen, handle)
4022
4023 NULLIFY (atom_list)
4024 NULLIFY (my_kind_set)
4025 NULLIFY (atomic_kind_set)
4026 NULLIFY (grid_atom)
4027 NULLIFY (harmonics)
4028 NULLIFY (input)
4029 NULLIFY (para_env)
4030 NULLIFY (rho_atom)
4031 NULLIFY (my_rho_atom_set)
4032 NULLIFY (rho_nlcc)
4033
4034 CALL get_qs_env(qs_env=qs_env, &
4035 dft_control=dft_control, &
4036 para_env=para_env, &
4037 atomic_kind_set=atomic_kind_set, &
4038 qs_kind_set=my_kind_set, &
4039 input=input, &
4040 rho_atom_set=my_rho_atom_set)
4041
4042 nlcc = has_nlcc(my_kind_set)
4043 accint = dft_control%qs_control%gapw_control%accurate_xcint
4044
4045 my_xc_section => section_vals_get_subs_vals(input, &
4046 "PROPERTIES%LINRES%EPR%PRINT%G_TENSOR%XC")
4047 xc_fun_section => section_vals_get_subs_vals(my_xc_section, "XC_FUNCTIONAL")
4048 CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", &
4049 i_val=myfun)
4050
4051 IF (myfun == xc_none) THEN
4052 exc1 = 0.0_dp
4053 my_rho_atom_set(:)%exc_h = 0.0_dp
4054 my_rho_atom_set(:)%exc_s = 0.0_dp
4055 ELSE
4056 CALL section_vals_val_get(my_xc_section, "DENSITY_CUTOFF", &
4057 r_val=density_cut)
4058 CALL section_vals_val_get(my_xc_section, "GRADIENT_CUTOFF", &
4059 r_val=gradient_cut)
4060 CALL section_vals_val_get(my_xc_section, "TAU_CUTOFF", &
4061 r_val=tau_cut)
4062
4063 lsd = dft_control%lsd
4064 nspins = dft_control%nspins
4065 needs = xc_functionals_get_needs(xc_fun_section, &
4066 lsd=lsd, &
4067 calc_potential=.true.)
4068
4069 ! whatever the xc, if epr_xc, drho_spin is needed
4070 needs%drho_spin = .true.
4071
4072 gradient_f = (needs%drho .OR. needs%drho_spin)
4073 tau_f = (needs%tau .OR. needs%tau_spin)
4074
4075 ! Initialize energy contribution from the one center XC terms to zero
4076 exc1 = 0.0_dp
4077
4078 ! Nullify some pointers for work-arrays
4079 NULLIFY (rho_h, drho_h, rho_s, drho_s, weight_h, weight_s)
4080 NULLIFY (vxc_h, vxc_s, vxg_h, vxg_s)
4081 NULLIFY (tau_h, tau_s)
4082 NULLIFY (vtau_h, vtau_s)
4083
4084 ! Here starts the loop over all the atoms
4085
4086 DO ikind = 1, SIZE(atomic_kind_set)
4087 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
4088 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
4089 harmonics=harmonics, grid_atom=grid_atom)
4090 CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
4091
4092 IF (.NOT. paw_atom) cycle
4093
4094 nr = grid_atom%nr
4095 na = grid_atom%ng_sphere
4096
4097 ! Prepare the structures needed to calculate and store the xc derivatives
4098
4099 ! Array dimension: here anly one dimensional arrays are used,
4100 ! i.e. only the first column of deriv_data is read.
4101 ! The other to dimensions are set to size equal 1
4102 bounds(1:2, 1:3) = 1
4103 bounds(2, 1) = na
4104 bounds(2, 2) = nr
4105
4106 ! set integration weights
4107 IF (accint) THEN
4108 weight_h => grid_atom%weight
4109 alpha = dft_control%qs_control%gapw_control%aw(ikind)
4110 IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
4111 IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
4112 END IF
4113 IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
4114 ALLOCATE (grid_atom%gapw_weight_s(na, nr))
4115 DO ir = 1, nr
4116 agr = 1.0_dp - exp(-alpha*grid_atom%rad2(ir))
4117 grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
4118 END DO
4119 grid_atom%gapw_weight_alpha = alpha
4120 END IF
4121 weight_s => grid_atom%gapw_weight_s
4122 ELSE
4123 weight_h => grid_atom%weight
4124 weight_s => grid_atom%weight
4125 END IF
4126
4127 ! create a place where to put the derivatives
4128 CALL xc_dset_create(deriv_set, local_bounds=bounds)
4129 ! create the place where to store the argument for the functionals
4130 CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
4131 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
4132 CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
4133 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
4134
4135 ! allocate the required 3d arrays where to store rho and drho
4136 CALL xc_rho_set_atom_update(rho_set_h, needs, nspins, bounds)
4137 CALL xc_rho_set_atom_update(rho_set_s, needs, nspins, bounds)
4138
4139 CALL reallocate(rho_h, 1, na, 1, nr, 1, nspins)
4140 CALL reallocate(rho_s, 1, na, 1, nr, 1, nspins)
4141 CALL reallocate(vxc_h, 1, na, 1, nr, 1, nspins)
4142 CALL reallocate(vxc_s, 1, na, 1, nr, 1, nspins)
4143 !
4144 IF (gradient_f) THEN
4145 CALL reallocate(drho_h, 1, 4, 1, na, 1, nr, 1, nspins)
4146 CALL reallocate(drho_s, 1, 4, 1, na, 1, nr, 1, nspins)
4147 CALL reallocate(vxg_h, 1, 3, 1, na, 1, nr, 1, nspins)
4148 CALL reallocate(vxg_s, 1, 3, 1, na, 1, nr, 1, nspins)
4149 END IF
4150
4151 IF (tau_f) THEN
4152 CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
4153 CALL reallocate(tau_h, 1, na, 1, nr, 1, nspins)
4154 CALL reallocate(tau_s, 1, na, 1, nr, 1, nspins)
4155 CALL reallocate(vtau_h, 1, na, 1, nr, 1, nspins)
4156 CALL reallocate(vtau_s, 1, na, 1, nr, 1, nspins)
4157 END IF
4158
4159 ! NLCC: prepare rho and drho of the core charge for this KIND
4160 donlcc = .false.
4161 IF (nlcc) THEN
4162 NULLIFY (rho_nlcc)
4163 rho_nlcc => my_kind_set(ikind)%nlcc_pot
4164 IF (ASSOCIATED(rho_nlcc)) donlcc = .true.
4165 END IF
4166
4167 ! Distribute the atoms of this kind
4168
4169 num_pe = para_env%num_pe
4170 bo = get_limit(natom, para_env%num_pe, para_env%mepos)
4171
4172 DO iat = bo(1), bo(2)
4173 iatom = atom_list(iat)
4174
4175 my_rho_atom_set(iatom)%exc_h = 0.0_dp
4176 my_rho_atom_set(iatom)%exc_s = 0.0_dp
4177
4178 rho_atom => my_rho_atom_set(iatom)
4179 rho_h = 0.0_dp
4180 rho_s = 0.0_dp
4181 IF (gradient_f) THEN
4182 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
4183 CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, &
4184 rho_rad_s=r_s, drho_rad_h=dr_h, &
4185 drho_rad_s=dr_s, rho_rad_h_d=r_h_d, &
4186 rho_rad_s_d=r_s_d)
4187 drho_h = 0.0_dp
4188 drho_s = 0.0_dp
4189 ELSE
4190 NULLIFY (r_h, r_s)
4191 CALL get_rho_atom(rho_atom=rho_atom, rho_rad_h=r_h, rho_rad_s=r_s)
4192 rho_d = 0.0_dp
4193 END IF
4194 IF (tau_f) THEN
4195 !compute tau on the grid all at once
4196 CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
4197 ELSE
4198 tau_d = 0.0_dp
4199 END IF
4200
4201 DO ir = 1, nr
4202 CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
4203 ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, &
4204 r_h_d, r_s_d, drho_h, drho_s)
4205 IF (donlcc) THEN
4206 CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
4207 ir, rho_nlcc(:, 1), rho_h, rho_s, rho_nlcc(:, 2), drho_h, drho_s)
4208 END IF
4209 END DO
4210 DO ir = 1, nr
4211 IF (tau_f) THEN
4212 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
4213 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
4214 ELSE IF (gradient_f) THEN
4215 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_d, na, ir)
4216 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_d, na, ir)
4217 ELSE
4218 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, rho_d, tau_d, na, ir)
4219 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, rho_d, tau_d, na, ir)
4220 END IF
4221 END DO
4222
4223 !-------------------!
4224 ! hard atom density !
4225 !-------------------!
4226 CALL xc_dset_zero_all(deriv_set)
4227 CALL vxc_of_r_epr(xc_fun_section, rho_set_h, deriv_set, needs, weight_h, &
4228 lsd, na, nr, exc_h, vxc_h, vxg_h, vtau_h)
4229 rho_atom%exc_h = rho_atom%exc_h + exc_h
4230
4231 !-------------------!
4232 ! soft atom density !
4233 !-------------------!
4234 CALL xc_dset_zero_all(deriv_set)
4235 CALL vxc_of_r_epr(xc_fun_section, rho_set_s, deriv_set, needs, weight_s, &
4236 lsd, na, nr, exc_s, vxc_s, vxg_s, vtau_s)
4237 rho_atom%exc_s = rho_atom%exc_s + exc_s
4238
4239 DO ispin = 1, nspins
4240 DO idir = 1, 3
4241 DO ir = 1, nr
4242 DO ia = 1, na
4243 gradient_atom_set(iatom)%nablavks_vec_rad_h(idir, ispin)%r_coef(ir, ia) = &
4244 gradient_atom_set(iatom)%nablavks_vec_rad_h(idir, ispin)%r_coef(ir, ia) &
4245 + vxg_h(idir, ia, ir, ispin)
4246 gradient_atom_set(iatom)%nablavks_vec_rad_s(idir, ispin)%r_coef(ir, ia) = &
4247 gradient_atom_set(iatom)%nablavks_vec_rad_s(idir, ispin)%r_coef(ir, ia) &
4248 + vxg_s(idir, ia, ir, ispin)
4249 END DO ! ia
4250 END DO ! ir
4251 END DO ! idir
4252 END DO ! ispin
4253
4254 ! Add contributions to the exc energy
4255
4256 exc1 = exc1 + rho_atom%exc_h - rho_atom%exc_s
4257
4258 ! Integration to get the matrix elements relative to the vxc_atom
4259 ! here the products with the primitives is done: gaVxcgb
4260 ! internal transformation to get the integral in cartesian Gaussians
4261
4262 NULLIFY (int_hh, int_ss)
4263 CALL get_rho_atom(rho_atom=rho_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
4264 IF (gradient_f) THEN
4265 CALL gavxcgb_gc(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
4266 grid_atom, basis_1c, harmonics, nspins)
4267 ELSE
4268 CALL gavxcgb_nogc(vxc_h, vxc_s, int_hh, int_ss, &
4269 grid_atom, basis_1c, harmonics, nspins)
4270 END IF
4271 IF (tau_f) THEN
4272 CALL dgavtaudgb(vtau_h, vtau_s, int_hh, int_ss, &
4273 tau_basis_cache, nspins)
4274 END IF
4275 NULLIFY (r_h, r_s, dr_h, dr_s)
4276 END DO ! iat
4277
4278 IF (tau_f) CALL release_tau_basis_cache(tau_basis_cache)
4279
4280 ! Release the xc structure used to store the xc derivatives
4281 CALL xc_dset_release(deriv_set)
4282 CALL xc_rho_set_release(rho_set_h)
4283 CALL xc_rho_set_release(rho_set_s)
4284 END DO ! ikind
4285
4286 CALL para_env%sum(exc1)
4287
4288 IF (ASSOCIATED(rho_h)) DEALLOCATE (rho_h)
4289 IF (ASSOCIATED(rho_s)) DEALLOCATE (rho_s)
4290 IF (ASSOCIATED(vxc_h)) DEALLOCATE (vxc_h)
4291 IF (ASSOCIATED(vxc_s)) DEALLOCATE (vxc_s)
4292
4293 IF (gradient_f) THEN
4294 IF (ASSOCIATED(drho_h)) DEALLOCATE (drho_h)
4295 IF (ASSOCIATED(drho_s)) DEALLOCATE (drho_s)
4296 IF (ASSOCIATED(vxg_h)) DEALLOCATE (vxg_h)
4297 IF (ASSOCIATED(vxg_s)) DEALLOCATE (vxg_s)
4298 END IF
4299
4300 IF (tau_f) THEN
4301 IF (ASSOCIATED(tau_h)) DEALLOCATE (tau_h)
4302 IF (ASSOCIATED(tau_s)) DEALLOCATE (tau_s)
4303 IF (ASSOCIATED(vtau_h)) DEALLOCATE (vtau_h)
4304 IF (ASSOCIATED(vtau_s)) DEALLOCATE (vtau_s)
4305 END IF
4306
4307 END IF !xc_none
4308
4309 CALL timestop(handle)
4310
4311 END SUBROUTINE calculate_vxc_atom_epr
4312
4313! **************************************************************************************************
4314!> \brief ...
4315!> \param rho_atom_set ...
4316!> \param rho1_atom_set ...
4317!> \param qs_env ...
4318!> \param xc_section ...
4319!> \param para_env ...
4320!> \param do_tddfpt2 New implementation of TDDFT.
4321!> \param do_triplet ...
4322!> \param do_sf ...
4323!> \param kind_set_external ...
4324! **************************************************************************************************
4325 SUBROUTINE calculate_xc_2nd_deriv_atom(rho_atom_set, rho1_atom_set, qs_env, xc_section, para_env, &
4326 do_tddfpt2, do_triplet, do_sf, kind_set_external)
4327
4328 TYPE(rho_atom_type), DIMENSION(:), POINTER :: rho_atom_set, rho1_atom_set
4329 TYPE(qs_environment_type), POINTER :: qs_env
4330 TYPE(section_vals_type), POINTER :: xc_section
4331 TYPE(mp_para_env_type), INTENT(IN) :: para_env
4332 LOGICAL, INTENT(IN), OPTIONAL :: do_tddfpt2, do_triplet, do_sf
4333 TYPE(qs_kind_type), DIMENSION(:), OPTIONAL, &
4334 POINTER :: kind_set_external
4335
4336 CHARACTER(LEN=*), PARAMETER :: routinen = 'calculate_xc_2nd_deriv_atom'
4337
4338 INTEGER :: atom, handle, iatom, ikind, ir, na, &
4339 natom, nr, nspins
4340 INTEGER, DIMENSION(2) :: local_loop_limit
4341 INTEGER, DIMENSION(2, 3) :: bounds
4342 INTEGER, DIMENSION(:), POINTER :: atom_list
4343 LOGICAL :: accint, donlcc, gradient_functional, &
4344 lsd, my_do_sf, nlcc, paw_atom, &
4345 scale_rho, tau_f
4346 REAL(kind=dp) :: agr, alpha, density_cut, gradient_cut, &
4347 rtot, tau_cut
4348 REAL(kind=dp), CONTIGUOUS, DIMENSION(:, :, :), &
4349 POINTER :: vtau_h, vtau_s, vxc_h, vxc_s
4350 REAL(kind=dp), DIMENSION(1, 1, 1) :: rtau
4351 REAL(kind=dp), DIMENSION(1, 1, 1, 1) :: rrho
4352 REAL(kind=dp), DIMENSION(:, :), POINTER :: rho_nlcc, weight_h, weight_s
4353 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: rho1_h, rho1_s, rho_h, rho_s, tau1_h, &
4354 tau1_s, tau_h, tau_s
4355 REAL(kind=dp), DIMENSION(:, :, :, :), POINTER :: drho1_h, drho1_s, drho_h, drho_s, vxg_h, &
4356 vxg_s
4357 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
4358 TYPE(dft_control_type), POINTER :: dft_control
4359 TYPE(grid_atom_type), POINTER :: grid_atom
4360 TYPE(gto_basis_set_type), POINTER :: basis_1c
4361 TYPE(harmonics_atom_type), POINTER :: harmonics
4362 TYPE(qs_kind_type), DIMENSION(:), POINTER :: my_kind_set, qs_kind_set
4363 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr1_h, dr1_s, dr_h, dr_s, int_hh, &
4364 int_ss, r1_h, r1_s, r_h, r_s
4365 TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r1_h_d, r1_s_d, r_h_d, r_s_d
4366 TYPE(rho_atom_type), POINTER :: rho1_atom, rho_atom
4367 TYPE(section_vals_type), POINTER :: input, xc_fun_section
4368 TYPE(tau_basis_cache_type) :: tau_basis_cache
4369 TYPE(xc_derivative_set_type) :: deriv_set
4370 TYPE(xc_rho_cflags_type) :: needs
4371 TYPE(xc_rho_set_type) :: rho1_set_h, rho1_set_s, rho_set_h, &
4372 rho_set_s
4373
4374! -------------------------------------------------------------------------
4375
4376 CALL timeset(routinen, handle)
4377
4378 NULLIFY (qs_kind_set)
4379 NULLIFY (rho_h, rho_s, drho_h, drho_s, weight_h, weight_s)
4380 NULLIFY (rho1_h, rho1_s, drho1_h, drho1_s)
4381 NULLIFY (vxc_h, vxc_s, vxg_h, vxg_s)
4382 NULLIFY (tau_h, tau_s, tau1_h, tau1_s, vtau_h, vtau_s)
4383 NULLIFY (rho_nlcc)
4384
4385 CALL get_qs_env(qs_env=qs_env, &
4386 input=input, &
4387 dft_control=dft_control, &
4388 qs_kind_set=qs_kind_set, &
4389 atomic_kind_set=atomic_kind_set)
4390
4391 IF (PRESENT(kind_set_external)) THEN
4392 my_kind_set => kind_set_external
4393 ELSE
4394 my_kind_set => qs_kind_set
4395 END IF
4396 nlcc = has_nlcc(my_kind_set)
4397
4398 accint = dft_control%qs_control%gapw_control%accurate_xcint
4399
4400 CALL section_vals_val_get(input, "DFT%LSD", l_val=lsd)
4401 CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", &
4402 r_val=density_cut)
4403 CALL section_vals_val_get(xc_section, "GRADIENT_CUTOFF", &
4404 r_val=gradient_cut)
4405 CALL section_vals_val_get(xc_section, "TAU_CUTOFF", &
4406 r_val=tau_cut)
4407
4408 my_do_sf = .false.
4409 IF (PRESENT(do_sf)) my_do_sf = do_sf
4410
4411 xc_fun_section => section_vals_get_subs_vals(xc_section, &
4412 "XC_FUNCTIONAL")
4413 IF (lsd) THEN
4414 nspins = 2
4415 ELSE
4416 nspins = 1
4417 END IF
4418
4419 scale_rho = .false.
4420 IF (PRESENT(do_tddfpt2) .AND. PRESENT(do_triplet)) THEN
4421 IF (nspins == 1 .AND. do_triplet) THEN
4422 lsd = .true.
4423 scale_rho = .true.
4424 END IF
4425 ELSE IF (PRESENT(do_triplet)) THEN
4426 IF (nspins == 1 .AND. do_triplet) lsd = .true.
4427 END IF
4428
4429 needs = xc_functionals_get_needs(xc_fun_section, lsd=lsd, &
4430 calc_potential=.true.)
4431 gradient_functional = needs%drho .OR. needs%drho_spin
4432 tau_f = (needs%tau .OR. needs%tau_spin)
4433 IF (.NOT. tau_f) rtau = 0.0_dp
4434
4435 ! Here starts the loop over all the atoms
4436 DO ikind = 1, SIZE(atomic_kind_set)
4437
4438 NULLIFY (atom_list, harmonics, grid_atom)
4439 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
4440 CALL get_qs_kind(my_kind_set(ikind), paw_atom=paw_atom, &
4441 harmonics=harmonics, grid_atom=grid_atom)
4442 CALL get_qs_kind(my_kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
4443 IF (.NOT. paw_atom) cycle
4444
4445 nr = grid_atom%nr
4446 na = grid_atom%ng_sphere
4447
4448 ! set integration weights
4449 IF (accint) THEN
4450 weight_h => grid_atom%weight
4451 alpha = dft_control%qs_control%gapw_control%aw(ikind)
4452 IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
4453 IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
4454 END IF
4455 IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
4456 ALLOCATE (grid_atom%gapw_weight_s(na, nr))
4457 DO ir = 1, nr
4458 agr = 1.0_dp - exp(-alpha*grid_atom%rad2(ir))
4459 grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
4460 END DO
4461 grid_atom%gapw_weight_alpha = alpha
4462 END IF
4463 weight_s => grid_atom%gapw_weight_s
4464 ELSE
4465 weight_h => grid_atom%weight
4466 weight_s => grid_atom%weight
4467 END IF
4468
4469 ! Array dimension: here anly one dimensional arrays are used,
4470 ! i.e. only the first column of deriv_data is read.
4471 ! The other to dimensions are set to size equal 1.
4472 bounds(1:2, 1:3) = 1
4473 bounds(2, 1) = na
4474 bounds(2, 2) = nr
4475
4476 CALL xc_dset_create(deriv_set, local_bounds=bounds)
4477 CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
4478 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
4479 CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
4480 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
4481 CALL xc_rho_set_create(rho1_set_h, bounds, rho_cutoff=density_cut, &
4482 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
4483 CALL xc_rho_set_create(rho1_set_s, bounds, rho_cutoff=density_cut, &
4484 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
4485
4486 ! allocate the required 3d arrays where to store rho and drho
4487 IF (nspins == 1 .AND. .NOT. lsd) THEN
4488 CALL xc_rho_set_atom_update(rho_set_h, needs, 1, bounds)
4489 CALL xc_rho_set_atom_update(rho1_set_h, needs, 1, bounds)
4490 CALL xc_rho_set_atom_update(rho_set_s, needs, 1, bounds)
4491 CALL xc_rho_set_atom_update(rho1_set_s, needs, 1, bounds)
4492 ELSE
4493 CALL xc_rho_set_atom_update(rho_set_h, needs, 2, bounds)
4494 CALL xc_rho_set_atom_update(rho1_set_h, needs, 2, bounds)
4495 CALL xc_rho_set_atom_update(rho_set_s, needs, 2, bounds)
4496 CALL xc_rho_set_atom_update(rho1_set_s, needs, 2, bounds)
4497 END IF
4498
4499 ALLOCATE (rho_h(1:na, 1:nr, 1:nspins), rho1_h(1:na, 1:nr, 1:nspins), &
4500 rho_s(1:na, 1:nr, 1:nspins), rho1_s(1:na, 1:nr, 1:nspins))
4501
4502 ALLOCATE (vxc_h(1:na, 1:nr, 1:nspins), vxc_s(1:na, 1:nr, 1:nspins))
4503 vxc_h = 0.0_dp
4504 vxc_s = 0.0_dp
4505
4506 IF (tau_f) THEN
4507 CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
4508 ALLOCATE (tau_h(1:na, 1:nr, 1:nspins), tau1_h(1:na, 1:nr, 1:nspins), &
4509 tau_s(1:na, 1:nr, 1:nspins), tau1_s(1:na, 1:nr, 1:nspins))
4510 ALLOCATE (vtau_h(1:na, 1:nr, 1:nspins), vtau_s(1:na, 1:nr, 1:nspins))
4511 END IF
4512
4513 IF (gradient_functional) THEN
4514 ALLOCATE (drho_h(1:4, 1:na, 1:nr, 1:nspins), drho1_h(1:4, 1:na, 1:nr, 1:nspins), &
4515 drho_s(1:4, 1:na, 1:nr, 1:nspins), drho1_s(1:4, 1:na, 1:nr, 1:nspins))
4516 ALLOCATE (vxg_h(1:3, 1:na, 1:nr, 1:nspins), vxg_s(1:3, 1:na, 1:nr, 1:nspins))
4517 ELSE
4518 ALLOCATE (drho_h(1, 1, 1, 1), drho1_h(1, 1, 1, 1), &
4519 drho_s(1, 1, 1, 1), drho1_s(1, 1, 1, 1))
4520 ALLOCATE (vxg_h(1, 1, 1, 1), vxg_s(1, 1, 1, 1))
4521 rrho = 0.0_dp
4522 END IF
4523 vxg_h = 0.0_dp
4524 vxg_s = 0.0_dp
4525
4526 ! NLCC: prepare rho and drho of the core charge for this KIND
4527 donlcc = .false.
4528 IF (nlcc) THEN
4529 NULLIFY (rho_nlcc)
4530 rho_nlcc => my_kind_set(ikind)%nlcc_pot
4531 IF (ASSOCIATED(rho_nlcc)) donlcc = .true.
4532 END IF
4533
4534 ! parallelization
4535 local_loop_limit = get_limit(natom, para_env%num_pe, para_env%mepos)
4536
4537 DO iatom = local_loop_limit(1), local_loop_limit(2) !1,natom
4538 atom = atom_list(iatom)
4539
4540 rho_atom_set(atom)%exc_h = 0.0_dp
4541 rho_atom_set(atom)%exc_s = 0.0_dp
4542 rho1_atom_set(atom)%exc_h = 0.0_dp
4543 rho1_atom_set(atom)%exc_s = 0.0_dp
4544
4545 rho_atom => rho_atom_set(atom)
4546 rho1_atom => rho1_atom_set(atom)
4547 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
4548 NULLIFY (r1_h, r1_s, dr1_h, dr1_s, r1_h_d, r1_s_d)
4549 rho_h = 0.0_dp
4550 rho_s = 0.0_dp
4551 rho1_h = 0.0_dp
4552 rho1_s = 0.0_dp
4553 IF (gradient_functional) THEN
4554 CALL get_rho_atom(rho_atom=rho_atom, &
4555 rho_rad_h=r_h, rho_rad_s=r_s, &
4556 drho_rad_h=dr_h, drho_rad_s=dr_s, &
4557 rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
4558 CALL get_rho_atom(rho_atom=rho1_atom, &
4559 rho_rad_h=r1_h, rho_rad_s=r1_s, &
4560 drho_rad_h=dr1_h, drho_rad_s=dr1_s, &
4561 rho_rad_h_d=r1_h_d, rho_rad_s_d=r1_s_d)
4562 drho_h = 0.0_dp; drho_s = 0.0_dp
4563 drho1_h = 0.0_dp; drho1_s = 0.0_dp
4564 ELSE
4565 CALL get_rho_atom(rho_atom=rho_atom, &
4566 rho_rad_h=r_h, rho_rad_s=r_s)
4567 CALL get_rho_atom(rho_atom=rho1_atom, &
4568 rho_rad_h=r1_h, rho_rad_s=r1_s)
4569 END IF
4570
4571 rtot = 0.0_dp
4572
4573 DO ir = 1, nr
4574 CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_functional, &
4575 ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, r_h_d, r_s_d, &
4576 drho_h, drho_s)
4577 IF (donlcc) THEN
4578 CALL calc_rho_nlcc(grid_atom, nspins, gradient_functional, &
4579 ir, rho_nlcc(:, 1), rho_h, rho_s, rho_nlcc(:, 2), drho_h, drho_s)
4580 END IF
4581 CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_functional, &
4582 ir, r1_h, r1_s, rho1_h, rho1_s, dr1_h, dr1_s, r1_h_d, r1_s_d, &
4583 drho1_h, drho1_s)
4584 END DO
4585 IF (tau_f) THEN
4586 CALL calc_tau_atom(tau_h, tau_s, rho_atom, tau_basis_cache, nspins)
4587 CALL calc_tau_atom(tau1_h, tau1_s, rho1_atom, tau_basis_cache, nspins)
4588 END IF
4589 IF (scale_rho) THEN
4590 rho_h = 2.0_dp*rho_h
4591 rho_s = 2.0_dp*rho_s
4592 IF (gradient_functional) THEN
4593 drho_h = 2.0_dp*drho_h
4594 drho_s = 2.0_dp*drho_s
4595 END IF
4596 IF (tau_f) THEN
4597 tau_h = 2.0_dp*tau_h
4598 tau_s = 2.0_dp*tau_s
4599 END IF
4600 END IF
4601
4602 DO ir = 1, nr
4603 IF (tau_f) THEN
4604 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
4605 CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, tau1_h, na, ir)
4606 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
4607 CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, tau1_s, na, ir)
4608 ELSE IF (gradient_functional) THEN
4609 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, rtau, na, ir)
4610 CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, rtau, na, ir)
4611 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, rtau, na, ir)
4612 CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, rtau, na, ir)
4613 ELSE
4614 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, rrho, rtau, na, ir)
4615 CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, rrho, rtau, na, ir)
4616 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, rrho, rtau, na, ir)
4617 CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, rrho, rtau, na, ir)
4618 END IF
4619 END DO
4620
4621 CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
4622 rho_set=rho_set_h, rho1_set=rho1_set_h, &
4623 deriv_set=deriv_set, &
4624 w=weight_h, vxc=vxc_h, vxg=vxg_h, vtau=vtau_h, do_triplet=do_triplet, &
4625 do_sf=my_do_sf)
4626 CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
4627 rho_set=rho_set_s, rho1_set=rho1_set_s, &
4628 deriv_set=deriv_set, &
4629 w=weight_s, vxc=vxc_s, vxg=vxg_s, vtau=vtau_s, do_triplet=do_triplet, &
4630 do_sf=my_do_sf)
4631
4632 CALL get_rho_atom(rho_atom=rho1_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
4633 IF (gradient_functional) THEN
4634 CALL gavxcgb_gc(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
4635 grid_atom, basis_1c, harmonics, nspins)
4636 ELSE
4637 CALL gavxcgb_nogc(vxc_h, vxc_s, int_hh, int_ss, &
4638 grid_atom, basis_1c, harmonics, nspins)
4639 END IF
4640 IF (tau_f) THEN
4641 CALL dgavtaudgb(vtau_h, vtau_s, int_hh, int_ss, &
4642 tau_basis_cache, nspins)
4643 END IF
4644
4645 NULLIFY (r_h, r_s, dr_h, dr_s)
4646
4647 END DO
4648
4649 ! some cleanup
4650 DEALLOCATE (rho_h, rho_s, rho1_h, rho1_s, vxc_h, vxc_s)
4651 DEALLOCATE (drho_h, drho_s, vxg_h, vxg_s)
4652 DEALLOCATE (drho1_h, drho1_s)
4653 IF (tau_f) THEN
4654 DEALLOCATE (tau_h, tau_s, tau1_h, tau1_s)
4655 DEALLOCATE (vtau_h, vtau_s)
4656 CALL release_tau_basis_cache(tau_basis_cache)
4657 END IF
4658
4659 CALL xc_dset_release(deriv_set)
4660 CALL xc_rho_set_release(rho_set_h)
4661 CALL xc_rho_set_release(rho1_set_h)
4662 CALL xc_rho_set_release(rho_set_s)
4663 CALL xc_rho_set_release(rho1_set_s)
4664 END DO
4665
4666 CALL timestop(handle)
4667
4668 END SUBROUTINE calculate_xc_2nd_deriv_atom
4669
4670! **************************************************************************************************
4671!> \brief ...
4672!> \param qs_env ...
4673!> \param rho0_atom_set ...
4674!> \param rho1_atom_set ...
4675!> \param rho2_atom_set ...
4676!> \param kind_set ...
4677!> \param xc_section ...
4678!> \param is_triplet ...
4679!> \param accuracy ...
4680! **************************************************************************************************
4681 SUBROUTINE calculate_gfxc_atom(qs_env, rho0_atom_set, rho1_atom_set, rho2_atom_set, &
4682 kind_set, xc_section, is_triplet, accuracy)
4683
4684 TYPE(qs_environment_type), POINTER :: qs_env
4685 TYPE(rho_atom_type), DIMENSION(:), POINTER :: rho0_atom_set, rho1_atom_set, &
4686 rho2_atom_set
4687 TYPE(qs_kind_type), DIMENSION(:), POINTER :: kind_set
4688 TYPE(section_vals_type), OPTIONAL, POINTER :: xc_section
4689 LOGICAL, INTENT(IN) :: is_triplet
4690 INTEGER, INTENT(IN) :: accuracy
4691
4692 CHARACTER(LEN=*), PARAMETER :: routinen = 'calculate_gfxc_atom'
4693 REAL(kind=dp), PARAMETER :: epsrho = 5.e-4_dp
4694
4695 INTEGER :: bo(2), handle, iat, iatom, ikind, ir, &
4696 istep, mspins, myfun, na, natom, nf, &
4697 nr, ns, nspins, nstep, num_pe
4698 INTEGER, DIMENSION(2, 3) :: bounds
4699 INTEGER, DIMENSION(:), POINTER :: atom_list
4700 LOGICAL :: accint, donlcc, gradient_f, lsd, nlcc, &
4701 paw_atom, tau_f
4702 REAL(dp) :: agr, alpha, beta, density_cut, exc_h, &
4703 exc_s, gradient_cut, oeps1, oeps2, &
4704 tau_cut
4705 REAL(dp), DIMENSION(1, 1, 1) :: tau_d
4706 REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d
4707 REAL(dp), DIMENSION(:, :), POINTER :: rho_nlcc, weight_h, weight_s
4708 REAL(dp), DIMENSION(:, :, :), POINTER :: rho0_h, rho0_s, rho1_h, rho1_s, rho_h, &
4709 rho_s, tau0_h, tau0_s, tau1_h, tau1_s, &
4710 tau_h, tau_s, vtau_h, vtau_s, vxc_h, &
4711 vxc_s
4712 REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho0_h, drho0_s, drho1_h, drho1_s, &
4713 drho_h, drho_s, vxg_h, vxg_s
4714 REAL(kind=dp), DIMENSION(-4:4) :: ak, bl
4715 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
4716 TYPE(dft_control_type), POINTER :: dft_control
4717 TYPE(grid_atom_type), POINTER :: grid_atom
4718 TYPE(gto_basis_set_type), POINTER :: basis_1c
4719 TYPE(harmonics_atom_type), POINTER :: harmonics
4720 TYPE(mp_para_env_type), POINTER :: para_env
4721 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s, fint_hh, fint_ss, int_hh, &
4722 int_ss, r_h, r_s
4723 TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
4724 TYPE(rho_atom_type), POINTER :: rho0_atom, rho1_atom, rho2_atom
4725 TYPE(section_vals_type), POINTER :: xc_fun_section
4726 TYPE(tau_basis_cache_type) :: tau_basis_cache
4727 TYPE(xc_derivative_set_type) :: deriv_set
4728 TYPE(xc_rho_cflags_type) :: needs
4729 TYPE(xc_rho_set_type) :: rho_set_h, rho_set_s
4730
4731 CALL timeset(routinen, handle)
4732
4733 NULLIFY (vtau_h, vtau_s)
4734
4735 ak = 0.0_dp
4736 bl = 0.0_dp
4737 SELECT CASE (accuracy)
4738 CASE (:4)
4739 nstep = 2
4740 ak(-2:2) = [1.0_dp, -8.0_dp, 0.0_dp, 8.0_dp, -1.0_dp]/12.0_dp
4741 bl(-2:2) = [-1.0_dp, 16.0_dp, -30.0_dp, 16.0_dp, -1.0_dp]/12.0_dp
4742 CASE (5:7)
4743 nstep = 3
4744 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
4745 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
4746 CASE (8:)
4747 nstep = 4
4748 ak(-4:4) = [1.0_dp, -32.0_dp/3.0_dp, 56.0_dp, -224.0_dp, 0.0_dp, &
4749 224.0_dp, -56.0_dp, 32.0_dp/3.0_dp, -1.0_dp]/280.0_dp
4750 bl(-4:4) = [-1.0_dp, 128.0_dp/9.0_dp, -112.0_dp, 896.0_dp, -14350.0_dp/9.0_dp, &
4751 896.0_dp, -112.0_dp, 128.0_dp/9.0_dp, -1.0_dp]/560.0_dp
4752 END SELECT
4753 oeps1 = 1.0_dp/epsrho
4754 oeps2 = 1.0_dp/(epsrho**2)
4755
4756 CALL get_qs_env(qs_env=qs_env, &
4757 dft_control=dft_control, &
4758 para_env=para_env, &
4759 atomic_kind_set=atomic_kind_set)
4760
4761 xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
4762 CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", i_val=myfun)
4763
4764 accint = dft_control%qs_control%gapw_control%accurate_xcint
4765
4766 IF (myfun == xc_none) THEN
4767 ! no action needed?
4768 ELSE
4769 CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", r_val=density_cut)
4770 CALL section_vals_val_get(xc_section, "GRADIENT_CUTOFF", r_val=gradient_cut)
4771 CALL section_vals_val_get(xc_section, "TAU_CUTOFF", r_val=tau_cut)
4772
4773 nlcc = has_nlcc(kind_set)
4774 lsd = dft_control%lsd
4775 nspins = dft_control%nspins
4776 mspins = nspins
4777 IF (is_triplet) THEN
4778 cpassert(nspins == 1)
4779 lsd = .true.
4780 mspins = 2
4781 END IF
4782 needs = xc_functionals_get_needs(xc_fun_section, lsd=lsd, calc_potential=.true.)
4783 gradient_f = (needs%drho .OR. needs%drho_spin)
4784 tau_f = (needs%tau .OR. needs%tau_spin)
4785
4786 ! Here starts the loop over all the atoms
4787 DO ikind = 1, SIZE(atomic_kind_set)
4788 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
4789 CALL get_qs_kind(kind_set(ikind), paw_atom=paw_atom, &
4790 harmonics=harmonics, grid_atom=grid_atom)
4791 CALL get_qs_kind(kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
4792
4793 IF (.NOT. paw_atom) cycle
4794
4795 nr = grid_atom%nr
4796 na = grid_atom%ng_sphere
4797
4798 ! set integration weights
4799 IF (accint) THEN
4800 weight_h => grid_atom%weight
4801 alpha = dft_control%qs_control%gapw_control%aw(ikind)
4802 IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
4803 IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
4804 END IF
4805 IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
4806 ALLOCATE (grid_atom%gapw_weight_s(na, nr))
4807 DO ir = 1, nr
4808 agr = 1.0_dp - exp(-alpha*grid_atom%rad2(ir))
4809 grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
4810 END DO
4811 grid_atom%gapw_weight_alpha = alpha
4812 END IF
4813 weight_s => grid_atom%gapw_weight_s
4814 ELSE
4815 weight_h => grid_atom%weight
4816 weight_s => grid_atom%weight
4817 END IF
4818
4819 ! Prepare the structures needed to calculate and store the xc derivatives
4820
4821 ! Array dimension: here anly one dimensional arrays are used,
4822 ! i.e. only the first column of deriv_data is read.
4823 ! The other to dimensions are set to size equal 1
4824 bounds(1:2, 1:3) = 1
4825 bounds(2, 1) = na
4826 bounds(2, 2) = nr
4827
4828 ! create a place where to put the derivatives
4829 CALL xc_dset_create(deriv_set, local_bounds=bounds)
4830 ! create the place where to store the argument for the functionals
4831 CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
4832 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
4833 CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
4834 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
4835
4836 ! allocate the required 3d arrays where to store rho and drho
4837 CALL xc_rho_set_atom_update(rho_set_h, needs, mspins, bounds)
4838 CALL xc_rho_set_atom_update(rho_set_s, needs, mspins, bounds)
4839
4840 ALLOCATE (rho_h(na, nr, mspins), rho_s(na, nr, mspins), &
4841 rho0_h(na, nr, nspins), rho0_s(na, nr, nspins), &
4842 rho1_h(na, nr, nspins), rho1_s(na, nr, nspins))
4843 ALLOCATE (vxc_h(na, nr, mspins), vxc_s(na, nr, mspins))
4844 IF (gradient_f) THEN
4845 ALLOCATE (drho_h(4, na, nr, mspins), drho_s(4, na, nr, mspins), &
4846 drho0_h(4, na, nr, nspins), drho0_s(4, na, nr, nspins), &
4847 drho1_h(4, na, nr, nspins), drho1_s(4, na, nr, nspins))
4848 ALLOCATE (vxg_h(3, na, nr, mspins), vxg_s(3, na, nr, mspins))
4849 END IF
4850 IF (tau_f) THEN
4851 CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
4852 ALLOCATE (tau_h(na, nr, mspins), tau_s(na, nr, mspins), &
4853 tau0_h(na, nr, nspins), tau0_s(na, nr, nspins), &
4854 tau1_h(na, nr, nspins), tau1_s(na, nr, nspins))
4855 ALLOCATE (vtau_h(na, nr, mspins), vtau_s(na, nr, mspins))
4856 END IF
4857 !
4858 ! NLCC: prepare rho and drho of the core charge for this KIND
4859 donlcc = .false.
4860 IF (nlcc) THEN
4861 NULLIFY (rho_nlcc)
4862 rho_nlcc => kind_set(ikind)%nlcc_pot
4863 IF (ASSOCIATED(rho_nlcc)) donlcc = .true.
4864 END IF
4865
4866 ! Distribute the atoms of this kind
4867 num_pe = para_env%num_pe
4868 bo = get_limit(natom, num_pe, para_env%mepos)
4869
4870 DO iat = bo(1), bo(2)
4871 iatom = atom_list(iat)
4872 !
4873 NULLIFY (int_hh, int_ss)
4874 rho0_atom => rho0_atom_set(iatom)
4875 CALL get_rho_atom(rho_atom=rho0_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
4876 ALLOCATE (fint_ss(nspins), fint_hh(nspins))
4877 DO ns = 1, nspins
4878 nf = SIZE(int_ss(ns)%r_coef, 1)
4879 ALLOCATE (fint_ss(ns)%r_coef(nf, nf))
4880 nf = SIZE(int_hh(ns)%r_coef, 1)
4881 ALLOCATE (fint_hh(ns)%r_coef(nf, nf))
4882 END DO
4883
4884 ! RHO0
4885 rho0_h = 0.0_dp
4886 rho0_s = 0.0_dp
4887 rho0_atom => rho0_atom_set(iatom)
4888 IF (gradient_f) THEN
4889 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
4890 CALL get_rho_atom(rho_atom=rho0_atom, rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
4891 drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
4892 drho0_h = 0.0_dp
4893 drho0_s = 0.0_dp
4894 ELSE
4895 NULLIFY (r_h, r_s)
4896 CALL get_rho_atom(rho_atom=rho0_atom, rho_rad_h=r_h, rho_rad_s=r_s)
4897 rho_d = 0.0_dp
4898 END IF
4899 DO ir = 1, nr
4900 CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
4901 ir, r_h, r_s, rho0_h, rho0_s, dr_h, dr_s, &
4902 r_h_d, r_s_d, drho0_h, drho0_s)
4903 IF (donlcc) THEN
4904 CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
4905 ir, rho_nlcc(:, 1), rho0_h, rho0_s, rho_nlcc(:, 2), drho0_h, drho0_s)
4906 END IF
4907 END DO
4908 IF (tau_f) THEN
4909 !compute tau on the grid all at once
4910 CALL calc_tau_atom(tau0_h, tau0_s, rho0_atom, tau_basis_cache, nspins)
4911 ELSE
4912 tau_d = 0.0_dp
4913 END IF
4914 ! RHO1
4915 rho1_h = 0.0_dp
4916 rho1_s = 0.0_dp
4917 rho1_atom => rho1_atom_set(iatom)
4918 IF (gradient_f) THEN
4919 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
4920 CALL get_rho_atom(rho_atom=rho1_atom, rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
4921 drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
4922 drho1_h = 0.0_dp
4923 drho1_s = 0.0_dp
4924 ELSE
4925 NULLIFY (r_h, r_s)
4926 CALL get_rho_atom(rho_atom=rho1_atom, rho_rad_h=r_h, rho_rad_s=r_s)
4927 END IF
4928 DO ir = 1, nr
4929 CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
4930 ir, r_h, r_s, rho1_h, rho1_s, dr_h, dr_s, &
4931 r_h_d, r_s_d, drho1_h, drho1_s)
4932 END DO
4933 IF (tau_f) THEN
4934 !compute tau on the grid all at once
4935 CALL calc_tau_atom(tau1_h, tau1_s, rho1_atom, tau_basis_cache, nspins)
4936 END IF
4937 ! RHO2
4938 rho2_atom => rho2_atom_set(iatom)
4939
4940 DO istep = -nstep, nstep
4941
4942 beta = real(istep, kind=dp)*epsrho
4943
4944 IF (is_triplet) THEN
4945 rho_h(:, :, 1) = rho0_h(:, :, 1) + beta*rho1_h(:, :, 1)
4946 rho_h(:, :, 2) = rho0_h(:, :, 1)
4947 rho_h = 0.5_dp*rho_h
4948 rho_s(:, :, 1) = rho0_s(:, :, 1) + beta*rho1_s(:, :, 1)
4949 rho_s(:, :, 2) = rho0_s(:, :, 1)
4950 rho_s = 0.5_dp*rho_s
4951 IF (gradient_f) THEN
4952 drho_h(:, :, :, 1) = drho0_h(:, :, :, 1) + beta*drho1_h(:, :, :, 1)
4953 drho_h(:, :, :, 2) = drho0_h(:, :, :, 1)
4954 drho_h = 0.5_dp*drho_h
4955 drho_s(:, :, :, 1) = drho0_s(:, :, :, 1) + beta*drho1_s(:, :, :, 1)
4956 drho_s(:, :, :, 2) = drho0_s(:, :, :, 1)
4957 drho_s = 0.5_dp*drho_s
4958 END IF
4959 IF (tau_f) THEN
4960 tau_h(:, :, 1) = tau0_h(:, :, 1) + beta*tau1_h(:, :, 1)
4961 tau_h(:, :, 2) = tau0_h(:, :, 1)
4962 tau_h = 0.5_dp*tau0_h
4963 tau_s(:, :, 1) = tau0_s(:, :, 1) + beta*tau1_s(:, :, 1)
4964 tau_s(:, :, 2) = tau0_s(:, :, 1)
4965 tau_s = 0.5_dp*tau0_s
4966 END IF
4967 ELSE
4968 rho_h = rho0_h + beta*rho1_h
4969 rho_s = rho0_s + beta*rho1_s
4970 IF (gradient_f) THEN
4971 drho_h = drho0_h + beta*drho1_h
4972 drho_s = drho0_s + beta*drho1_s
4973 END IF
4974 IF (tau_f) THEN
4975 tau_h = tau0_h + beta*tau1_h
4976 tau_s = tau0_s + beta*tau1_s
4977 END IF
4978 END IF
4979 !
4980 IF (gradient_f) THEN
4981 drho_h(4, :, :, :) = sqrt( &
4982 drho_h(1, :, :, :)*drho_h(1, :, :, :) + &
4983 drho_h(2, :, :, :)*drho_h(2, :, :, :) + &
4984 drho_h(3, :, :, :)*drho_h(3, :, :, :))
4985
4986 drho_s(4, :, :, :) = sqrt( &
4987 drho_s(1, :, :, :)*drho_s(1, :, :, :) + &
4988 drho_s(2, :, :, :)*drho_s(2, :, :, :) + &
4989 drho_s(3, :, :, :)*drho_s(3, :, :, :))
4990 END IF
4991
4992 DO ir = 1, nr
4993 IF (tau_f) THEN
4994 CALL fill_rho_set(rho_set_h, lsd, mspins, needs, rho_h, drho_h, tau_h, na, ir)
4995 CALL fill_rho_set(rho_set_s, lsd, mspins, needs, rho_s, drho_s, tau_s, na, ir)
4996 ELSE IF (gradient_f) THEN
4997 CALL fill_rho_set(rho_set_h, lsd, mspins, needs, rho_h, drho_h, tau_d, na, ir)
4998 CALL fill_rho_set(rho_set_s, lsd, mspins, needs, rho_s, drho_s, tau_d, na, ir)
4999 ELSE
5000 CALL fill_rho_set(rho_set_h, lsd, mspins, needs, rho_h, rho_d, tau_d, na, ir)
5001 CALL fill_rho_set(rho_set_s, lsd, mspins, needs, rho_s, rho_d, tau_d, na, ir)
5002 END IF
5003 END DO
5004
5005 ! hard atom density !
5006 CALL xc_dset_zero_all(deriv_set)
5007 CALL vxc_of_r_new(xc_fun_section, rho_set_h, deriv_set, 1, needs, weight_h, &
5008 lsd, na, nr, exc_h, vxc_h, vxg_h, vtau_h)
5009 IF (is_triplet) THEN
5010 vxc_h(:, :, 1) = vxc_h(:, :, 1) - vxc_h(:, :, 2)
5011 IF (gradient_f) THEN
5012 vxg_h(:, :, :, 1) = vxg_h(:, :, :, 1) - vxg_h(:, :, :, 2)
5013 END IF
5014 IF (tau_f) THEN
5015 vtau_h(:, :, 1) = vtau_h(:, :, 1) - vtau_h(:, :, 2)
5016 END IF
5017 END IF
5018 ! soft atom density !
5019 CALL xc_dset_zero_all(deriv_set)
5020 CALL vxc_of_r_new(xc_fun_section, rho_set_s, deriv_set, 1, needs, weight_s, &
5021 lsd, na, nr, exc_s, vxc_s, vxg_s, vtau_s)
5022 IF (is_triplet) THEN
5023 vxc_s(:, :, 1) = vxc_s(:, :, 1) - vxc_s(:, :, 2)
5024 IF (gradient_f) THEN
5025 vxg_s(:, :, :, 1) = vxg_s(:, :, :, 1) - vxg_s(:, :, :, 2)
5026 END IF
5027 IF (tau_f) THEN
5028 vtau_s(:, :, 1) = vtau_s(:, :, 1) - vtau_s(:, :, 2)
5029 END IF
5030 END IF
5031 ! potentials
5032 DO ns = 1, nspins
5033 fint_hh(ns)%r_coef(:, :) = 0.0_dp
5034 fint_ss(ns)%r_coef(:, :) = 0.0_dp
5035 END DO
5036 IF (gradient_f) THEN
5037 CALL gavxcgb_gc(vxc_h, vxc_s, vxg_h, vxg_s, fint_hh, fint_ss, &
5038 grid_atom, basis_1c, harmonics, nspins)
5039 ELSE
5040 CALL gavxcgb_nogc(vxc_h, vxc_s, fint_hh, fint_ss, &
5041 grid_atom, basis_1c, harmonics, nspins)
5042 END IF
5043 IF (tau_f) THEN
5044 CALL dgavtaudgb(vtau_h, vtau_s, fint_hh, fint_ss, &
5045 tau_basis_cache, nspins)
5046 END IF
5047 ! first derivative fxc
5048 NULLIFY (int_hh, int_ss)
5049 CALL get_rho_atom(rho_atom=rho1_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
5050 DO ns = 1, nspins
5051 int_ss(ns)%r_coef(:, :) = int_ss(ns)%r_coef(:, :) + oeps1*ak(istep)*fint_ss(ns)%r_coef(:, :)
5052 int_hh(ns)%r_coef(:, :) = int_hh(ns)%r_coef(:, :) + oeps1*ak(istep)*fint_hh(ns)%r_coef(:, :)
5053 END DO
5054 ! second derivative gxc
5055 NULLIFY (int_hh, int_ss)
5056 CALL get_rho_atom(rho_atom=rho2_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
5057 DO ns = 1, nspins
5058 int_ss(ns)%r_coef(:, :) = int_ss(ns)%r_coef(:, :) + oeps2*bl(istep)*fint_ss(ns)%r_coef(:, :)
5059 int_hh(ns)%r_coef(:, :) = int_hh(ns)%r_coef(:, :) + oeps2*bl(istep)*fint_hh(ns)%r_coef(:, :)
5060 END DO
5061 END DO
5062 !
5063 DO ns = 1, nspins
5064 DEALLOCATE (fint_ss(ns)%r_coef)
5065 DEALLOCATE (fint_hh(ns)%r_coef)
5066 END DO
5067 DEALLOCATE (fint_ss, fint_hh)
5068
5069 END DO ! iat
5070
5071 ! Release the xc structure used to store the xc derivatives
5072 CALL xc_dset_release(deriv_set)
5073 CALL xc_rho_set_release(rho_set_h)
5074 CALL xc_rho_set_release(rho_set_s)
5075
5076 DEALLOCATE (rho_h, rho_s, rho0_h, rho0_s, rho1_h, rho1_s)
5077 DEALLOCATE (vxc_h, vxc_s)
5078 IF (gradient_f) THEN
5079 DEALLOCATE (drho_h, drho_s, drho0_h, drho0_s, drho1_h, drho1_s)
5080 DEALLOCATE (vxg_h, vxg_s)
5081 END IF
5082 IF (tau_f) THEN
5083 DEALLOCATE (tau_h, tau_s, tau0_h, tau0_s, tau1_h, tau1_s)
5084 DEALLOCATE (vtau_h, vtau_s)
5085 CALL release_tau_basis_cache(tau_basis_cache)
5086 END IF
5087 END DO ! ikind
5088
5089 END IF !xc_none
5090
5091 CALL timestop(handle)
5092
5093 END SUBROUTINE calculate_gfxc_atom
5094
5095! **************************************************************************************************
5096!> \brief ...
5097!> \param qs_env ...
5098!> \param rho0_atom_set ...
5099!> \param rho1_atom_set ...
5100!> \param rho2_atom_set ...
5101!> \param kind_set ...
5102!> \param xc_section ...
5103!> \param is_triplet ...
5104!> \param accuracy ...
5105!> \param epsrho ...
5106! **************************************************************************************************
5107 SUBROUTINE gfxc_atom_diff(qs_env, rho0_atom_set, rho1_atom_set, rho2_atom_set, &
5108 kind_set, xc_section, is_triplet, accuracy, epsrho)
5109
5110 TYPE(qs_environment_type), POINTER :: qs_env
5111 TYPE(rho_atom_type), DIMENSION(:), POINTER :: rho0_atom_set, rho1_atom_set, &
5112 rho2_atom_set
5113 TYPE(qs_kind_type), DIMENSION(:), POINTER :: kind_set
5114 TYPE(section_vals_type), OPTIONAL, POINTER :: xc_section
5115 LOGICAL, INTENT(IN) :: is_triplet
5116 INTEGER, INTENT(IN) :: accuracy
5117 REAL(kind=dp), INTENT(IN) :: epsrho
5118
5119 CHARACTER(LEN=*), PARAMETER :: routinen = 'gfxc_atom_diff'
5120
5121 INTEGER :: bo(2), handle, iat, iatom, ikind, ir, &
5122 istep, mspins, myfun, na, natom, nf, &
5123 nr, ns, nspins, nstep, num_pe
5124 INTEGER, DIMENSION(2, 3) :: bounds
5125 INTEGER, DIMENSION(:), POINTER :: atom_list
5126 LOGICAL :: accint, donlcc, gradient_f, lsd, nlcc, &
5127 paw_atom, tau_f
5128 REAL(dp) :: agr, alpha, beta, density_cut, &
5129 gradient_cut, oeps1, tau_cut
5130 REAL(dp), CONTIGUOUS, DIMENSION(:, :, :), POINTER :: vtau_h, vtau_s, vxc_h, vxc_s
5131 REAL(dp), DIMENSION(1, 1, 1) :: tau_d
5132 REAL(dp), DIMENSION(1, 1, 1, 1) :: rho_d
5133 REAL(dp), DIMENSION(:, :), POINTER :: rho_nlcc, weight_h, weight_s
5134 REAL(dp), DIMENSION(:, :, :), POINTER :: rho0_h, rho0_s, rho1_h, rho1_s, rho_h, &
5135 rho_s, tau0_h, tau0_s, tau1_h, tau1_s, &
5136 tau_h, tau_s
5137 REAL(dp), DIMENSION(:, :, :, :), POINTER :: drho0_h, drho0_s, drho1_h, drho1_s, &
5138 drho_h, drho_s, vxg_h, vxg_s
5139 REAL(kind=dp), DIMENSION(-4:4) :: ak
5140 TYPE(atomic_kind_type), DIMENSION(:), POINTER :: atomic_kind_set
5141 TYPE(dft_control_type), POINTER :: dft_control
5142 TYPE(grid_atom_type), POINTER :: grid_atom
5143 TYPE(gto_basis_set_type), POINTER :: basis_1c
5144 TYPE(harmonics_atom_type), POINTER :: harmonics
5145 TYPE(mp_para_env_type), POINTER :: para_env
5146 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s, fint_hh, fint_ss, int_hh, &
5147 int_ss, r_h, r_s
5148 TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
5149 TYPE(rho_atom_type), POINTER :: rho0_atom, rho1_atom, rho2_atom
5150 TYPE(section_vals_type), POINTER :: xc_fun_section
5151 TYPE(tau_basis_cache_type) :: tau_basis_cache
5152 TYPE(xc_derivative_set_type) :: deriv_set
5153 TYPE(xc_rho_cflags_type) :: needs
5154 TYPE(xc_rho_set_type) :: rho1_set_h, rho1_set_s, rho_set_h, &
5155 rho_set_s
5156
5157 CALL timeset(routinen, handle)
5158
5159 NULLIFY (vtau_h, vtau_s)
5160
5161 ak = 0.0_dp
5162 SELECT CASE (accuracy)
5163 CASE (:4)
5164 nstep = 2
5165 ak(-2:2) = [1.0_dp, -8.0_dp, 0.0_dp, 8.0_dp, -1.0_dp]/12.0_dp
5166 CASE (5:7)
5167 nstep = 3
5168 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
5169 CASE (8:)
5170 nstep = 4
5171 ak(-4:4) = [1.0_dp, -32.0_dp/3.0_dp, 56.0_dp, -224.0_dp, 0.0_dp, &
5172 224.0_dp, -56.0_dp, 32.0_dp/3.0_dp, -1.0_dp]/280.0_dp
5173 END SELECT
5174 oeps1 = 1.0_dp/epsrho
5175
5176 CALL get_qs_env(qs_env=qs_env, &
5177 dft_control=dft_control, &
5178 para_env=para_env, &
5179 atomic_kind_set=atomic_kind_set)
5180
5181 xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
5182 CALL section_vals_val_get(xc_fun_section, "_SECTION_PARAMETERS_", i_val=myfun)
5183
5184 accint = dft_control%qs_control%gapw_control%accurate_xcint
5185
5186 IF (myfun == xc_none) THEN
5187 ! no action needed?
5188 ELSE
5189 ! calculate fxc
5190 CALL calculate_xc_2nd_deriv_atom(rho0_atom_set, rho1_atom_set, qs_env, xc_section, para_env, &
5191 do_triplet=is_triplet, kind_set_external=kind_set)
5192
5193 CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", r_val=density_cut)
5194 CALL section_vals_val_get(xc_section, "GRADIENT_CUTOFF", r_val=gradient_cut)
5195 CALL section_vals_val_get(xc_section, "TAU_CUTOFF", r_val=tau_cut)
5196
5197 nlcc = has_nlcc(kind_set)
5198 lsd = dft_control%lsd
5199 nspins = dft_control%nspins
5200 mspins = nspins
5201 IF (is_triplet) THEN
5202 cpassert(nspins == 1)
5203 lsd = .true.
5204 mspins = 2
5205 END IF
5206 needs = xc_functionals_get_needs(xc_fun_section, lsd=lsd, calc_potential=.true.)
5207 gradient_f = (needs%drho .OR. needs%drho_spin)
5208 tau_f = (needs%tau .OR. needs%tau_spin)
5209
5210 ! Here starts the loop over all the atoms
5211 DO ikind = 1, SIZE(atomic_kind_set)
5212 CALL get_atomic_kind(atomic_kind_set(ikind), atom_list=atom_list, natom=natom)
5213 CALL get_qs_kind(kind_set(ikind), paw_atom=paw_atom, &
5214 harmonics=harmonics, grid_atom=grid_atom)
5215 CALL get_qs_kind(kind_set(ikind), basis_set=basis_1c, basis_type="GAPW_1C")
5216
5217 IF (.NOT. paw_atom) cycle
5218
5219 nr = grid_atom%nr
5220 na = grid_atom%ng_sphere
5221
5222 ! set integration weights
5223 IF (accint) THEN
5224 weight_h => grid_atom%weight
5225 alpha = dft_control%qs_control%gapw_control%aw(ikind)
5226 IF (ASSOCIATED(grid_atom%gapw_weight_s)) THEN
5227 IF (grid_atom%gapw_weight_alpha /= alpha) DEALLOCATE (grid_atom%gapw_weight_s)
5228 END IF
5229 IF (.NOT. ASSOCIATED(grid_atom%gapw_weight_s)) THEN
5230 ALLOCATE (grid_atom%gapw_weight_s(na, nr))
5231 DO ir = 1, nr
5232 agr = 1.0_dp - exp(-alpha*grid_atom%rad2(ir))
5233 grid_atom%gapw_weight_s(:, ir) = grid_atom%weight(:, ir)*agr
5234 END DO
5235 grid_atom%gapw_weight_alpha = alpha
5236 END IF
5237 weight_s => grid_atom%gapw_weight_s
5238 ELSE
5239 weight_h => grid_atom%weight
5240 weight_s => grid_atom%weight
5241 END IF
5242
5243 ! Prepare the structures needed to calculate and store the xc derivatives
5244
5245 ! Array dimension: here anly one dimensional arrays are used,
5246 ! i.e. only the first column of deriv_data is read.
5247 ! The other to dimensions are set to size equal 1
5248 bounds(1:2, 1:3) = 1
5249 bounds(2, 1) = na
5250 bounds(2, 2) = nr
5251
5252 ! create a place where to put the derivatives
5253 CALL xc_dset_create(deriv_set, local_bounds=bounds)
5254 ! create the place where to store the argument for the functionals
5255 CALL xc_rho_set_create(rho_set_h, bounds, rho_cutoff=density_cut, &
5256 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
5257 CALL xc_rho_set_create(rho_set_s, bounds, rho_cutoff=density_cut, &
5258 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
5259 CALL xc_rho_set_create(rho1_set_h, bounds, rho_cutoff=density_cut, &
5260 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
5261 CALL xc_rho_set_create(rho1_set_s, bounds, rho_cutoff=density_cut, &
5262 drho_cutoff=gradient_cut, tau_cutoff=tau_cut)
5263
5264 ! allocate the required 3d arrays where to store rho and drho
5265 CALL xc_rho_set_atom_update(rho_set_h, needs, mspins, bounds)
5266 CALL xc_rho_set_atom_update(rho_set_s, needs, mspins, bounds)
5267 CALL xc_rho_set_atom_update(rho1_set_h, needs, mspins, bounds)
5268 CALL xc_rho_set_atom_update(rho1_set_s, needs, mspins, bounds)
5269
5270 ALLOCATE (rho_h(na, nr, nspins), rho_s(na, nr, nspins), &
5271 rho0_h(na, nr, nspins), rho0_s(na, nr, nspins), &
5272 rho1_h(na, nr, nspins), rho1_s(na, nr, nspins))
5273 ALLOCATE (vxc_h(na, nr, nspins), vxc_s(na, nr, nspins))
5274 IF (gradient_f) THEN
5275 ALLOCATE (drho_h(4, na, nr, nspins), drho_s(4, na, nr, nspins), &
5276 drho0_h(4, na, nr, nspins), drho0_s(4, na, nr, nspins), &
5277 drho1_h(4, na, nr, nspins), drho1_s(4, na, nr, nspins))
5278 ALLOCATE (vxg_h(3, na, nr, nspins), vxg_s(3, na, nr, nspins))
5279 END IF
5280 IF (tau_f) THEN
5281 CALL create_tau_basis_cache(tau_basis_cache, grid_atom, basis_1c, harmonics)
5282 ALLOCATE (tau_h(na, nr, nspins), tau_s(na, nr, nspins), &
5283 tau0_h(na, nr, nspins), tau0_s(na, nr, nspins), &
5284 tau1_h(na, nr, nspins), tau1_s(na, nr, nspins))
5285 ALLOCATE (vtau_h(na, nr, nspins), vtau_s(na, nr, nspins))
5286 END IF
5287 !
5288 ! NLCC: prepare rho and drho of the core charge for this KIND
5289 donlcc = .false.
5290 IF (nlcc) THEN
5291 NULLIFY (rho_nlcc)
5292 rho_nlcc => kind_set(ikind)%nlcc_pot
5293 IF (ASSOCIATED(rho_nlcc)) donlcc = .true.
5294 END IF
5295
5296 ! Distribute the atoms of this kind
5297 num_pe = para_env%num_pe
5298 bo = get_limit(natom, num_pe, para_env%mepos)
5299
5300 DO iat = bo(1), bo(2)
5301 iatom = atom_list(iat)
5302 !
5303 NULLIFY (int_hh, int_ss)
5304 rho0_atom => rho0_atom_set(iatom)
5305 CALL get_rho_atom(rho_atom=rho0_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
5306 ALLOCATE (fint_ss(nspins), fint_hh(nspins))
5307 DO ns = 1, nspins
5308 nf = SIZE(int_ss(ns)%r_coef, 1)
5309 ALLOCATE (fint_ss(ns)%r_coef(nf, nf))
5310 nf = SIZE(int_hh(ns)%r_coef, 1)
5311 ALLOCATE (fint_hh(ns)%r_coef(nf, nf))
5312 END DO
5313
5314 ! RHO0
5315 rho0_h = 0.0_dp
5316 rho0_s = 0.0_dp
5317 rho0_atom => rho0_atom_set(iatom)
5318 IF (gradient_f) THEN
5319 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
5320 CALL get_rho_atom(rho_atom=rho0_atom, rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
5321 drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
5322 drho0_h = 0.0_dp
5323 drho0_s = 0.0_dp
5324 ELSE
5325 NULLIFY (r_h, r_s)
5326 CALL get_rho_atom(rho_atom=rho0_atom, rho_rad_h=r_h, rho_rad_s=r_s)
5327 rho_d = 0.0_dp
5328 END IF
5329 DO ir = 1, nr
5330 CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
5331 ir, r_h, r_s, rho0_h, rho0_s, dr_h, dr_s, &
5332 r_h_d, r_s_d, drho0_h, drho0_s)
5333 IF (donlcc) THEN
5334 CALL calc_rho_nlcc(grid_atom, nspins, gradient_f, &
5335 ir, rho_nlcc(:, 1), rho0_h, rho0_s, rho_nlcc(:, 2), drho0_h, drho0_s)
5336 END IF
5337 END DO
5338 IF (tau_f) THEN
5339 !compute tau on the grid all at once
5340 CALL calc_tau_atom(tau0_h, tau0_s, rho0_atom, tau_basis_cache, nspins)
5341 ELSE
5342 tau_d = 0.0_dp
5343 END IF
5344 ! RHO1
5345 rho1_h = 0.0_dp
5346 rho1_s = 0.0_dp
5347 rho1_atom => rho1_atom_set(iatom)
5348 IF (gradient_f) THEN
5349 NULLIFY (r_h, r_s, dr_h, dr_s, r_h_d, r_s_d)
5350 CALL get_rho_atom(rho_atom=rho1_atom, rho_rad_h=r_h, rho_rad_s=r_s, drho_rad_h=dr_h, &
5351 drho_rad_s=dr_s, rho_rad_h_d=r_h_d, rho_rad_s_d=r_s_d)
5352 drho1_h = 0.0_dp
5353 drho1_s = 0.0_dp
5354 ELSE
5355 NULLIFY (r_h, r_s)
5356 CALL get_rho_atom(rho_atom=rho1_atom, rho_rad_h=r_h, rho_rad_s=r_s)
5357 END IF
5358 DO ir = 1, nr
5359 CALL calc_rho_angular(grid_atom, harmonics, nspins, gradient_f, &
5360 ir, r_h, r_s, rho1_h, rho1_s, dr_h, dr_s, &
5361 r_h_d, r_s_d, drho1_h, drho1_s)
5362 END DO
5363 IF (tau_f) THEN
5364 !compute tau on the grid all at once
5365 CALL calc_tau_atom(tau1_h, tau1_s, rho1_atom, tau_basis_cache, nspins)
5366 END IF
5367
5368 DO ir = 1, nr
5369 IF (tau_f) THEN
5370 CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, tau1_h, na, ir)
5371 CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, tau1_s, na, ir)
5372 ELSE IF (gradient_f) THEN
5373 CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, drho1_h, tau_d, na, ir)
5374 CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, drho1_s, tau_d, na, ir)
5375 ELSE
5376 CALL fill_rho_set(rho1_set_h, lsd, nspins, needs, rho1_h, rho_d, tau_d, na, ir)
5377 CALL fill_rho_set(rho1_set_s, lsd, nspins, needs, rho1_s, rho_d, tau_d, na, ir)
5378 END IF
5379 END DO
5380
5381 ! RHO2
5382 rho2_atom => rho2_atom_set(iatom)
5383
5384 DO istep = -nstep, nstep
5385
5386 beta = real(istep, kind=dp)*epsrho
5387
5388 rho_h = rho0_h + beta*rho1_h
5389 rho_s = rho0_s + beta*rho1_s
5390 IF (gradient_f) THEN
5391 drho_h = drho0_h + beta*drho1_h
5392 drho_s = drho0_s + beta*drho1_s
5393 END IF
5394 IF (tau_f) THEN
5395 tau_h = tau0_h + beta*tau1_h
5396 tau_s = tau0_s + beta*tau1_s
5397 END IF
5398 !
5399 IF (gradient_f) THEN
5400 drho_h(4, :, :, :) = sqrt( &
5401 drho_h(1, :, :, :)*drho_h(1, :, :, :) + &
5402 drho_h(2, :, :, :)*drho_h(2, :, :, :) + &
5403 drho_h(3, :, :, :)*drho_h(3, :, :, :))
5404
5405 drho_s(4, :, :, :) = sqrt( &
5406 drho_s(1, :, :, :)*drho_s(1, :, :, :) + &
5407 drho_s(2, :, :, :)*drho_s(2, :, :, :) + &
5408 drho_s(3, :, :, :)*drho_s(3, :, :, :))
5409 END IF
5410
5411 DO ir = 1, nr
5412 IF (tau_f) THEN
5413 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_h, na, ir)
5414 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_s, na, ir)
5415 ELSE IF (gradient_f) THEN
5416 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, drho_h, tau_d, na, ir)
5417 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, drho_s, tau_d, na, ir)
5418 ELSE
5419 CALL fill_rho_set(rho_set_h, lsd, nspins, needs, rho_h, rho_d, tau_d, na, ir)
5420 CALL fill_rho_set(rho_set_s, lsd, nspins, needs, rho_s, rho_d, tau_d, na, ir)
5421 END IF
5422 END DO
5423
5424 ! hard atom density !
5425 CALL xc_dset_zero_all(deriv_set)
5426 CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
5427 rho_set=rho_set_h, rho1_set=rho1_set_h, &
5428 deriv_set=deriv_set, &
5429 w=weight_h, vxc=vxc_h, vxg=vxg_h, vtau=vtau_h, &
5430 do_triplet=is_triplet)
5431 ! soft atom density !
5432 CALL xc_dset_zero_all(deriv_set)
5433 CALL xc_2nd_deriv_of_r(xc_section=xc_section, &
5434 rho_set=rho_set_s, rho1_set=rho1_set_s, &
5435 deriv_set=deriv_set, &
5436 w=weight_s, vxc=vxc_s, vxg=vxg_s, vtau=vtau_s, &
5437 do_triplet=is_triplet)
5438 ! potentials
5439 DO ns = 1, nspins
5440 fint_hh(ns)%r_coef(:, :) = 0.0_dp
5441 fint_ss(ns)%r_coef(:, :) = 0.0_dp
5442 END DO
5443 IF (gradient_f) THEN
5444 CALL gavxcgb_gc(vxc_h, vxc_s, vxg_h, vxg_s, fint_hh, fint_ss, &
5445 grid_atom, basis_1c, harmonics, nspins)
5446 ELSE
5447 CALL gavxcgb_nogc(vxc_h, vxc_s, fint_hh, fint_ss, &
5448 grid_atom, basis_1c, harmonics, nspins)
5449 END IF
5450 IF (tau_f) THEN
5451 CALL dgavtaudgb(vtau_h, vtau_s, fint_hh, fint_ss, &
5452 tau_basis_cache, nspins)
5453 END IF
5454 ! second derivative gxc
5455 NULLIFY (int_hh, int_ss)
5456 CALL get_rho_atom(rho_atom=rho2_atom, ga_vlocal_gb_h=int_hh, ga_vlocal_gb_s=int_ss)
5457 DO ns = 1, nspins
5458 int_ss(ns)%r_coef(:, :) = int_ss(ns)%r_coef(:, :) + oeps1*ak(istep)*fint_ss(ns)%r_coef(:, :)
5459 int_hh(ns)%r_coef(:, :) = int_hh(ns)%r_coef(:, :) + oeps1*ak(istep)*fint_hh(ns)%r_coef(:, :)
5460 END DO
5461 END DO
5462 !
5463 DO ns = 1, nspins
5464 DEALLOCATE (fint_ss(ns)%r_coef)
5465 DEALLOCATE (fint_hh(ns)%r_coef)
5466 END DO
5467 DEALLOCATE (fint_ss, fint_hh)
5468
5469 END DO ! iat
5470
5471 ! Release the xc structure used to store the xc derivatives
5472 CALL xc_dset_release(deriv_set)
5473 CALL xc_rho_set_release(rho_set_h)
5474 CALL xc_rho_set_release(rho_set_s)
5475 CALL xc_rho_set_release(rho1_set_h)
5476 CALL xc_rho_set_release(rho1_set_s)
5477
5478 DEALLOCATE (rho_h, rho_s, rho0_h, rho0_s, rho1_h, rho1_s)
5479 DEALLOCATE (vxc_h, vxc_s)
5480 IF (gradient_f) THEN
5481 DEALLOCATE (drho_h, drho_s, drho0_h, drho0_s, drho1_h, drho1_s)
5482 DEALLOCATE (vxg_h, vxg_s)
5483 END IF
5484 IF (tau_f) THEN
5485 DEALLOCATE (tau_h, tau_s, tau0_h, tau0_s, tau1_h, tau1_s)
5486 DEALLOCATE (vtau_h, vtau_s)
5487 CALL release_tau_basis_cache(tau_basis_cache)
5488 END IF
5489 END DO ! ikind
5490
5491 END IF !xc_none
5492
5493 CALL timestop(handle)
5494
5495 END SUBROUTINE gfxc_atom_diff
5496
5497! **************************************************************************************************
5498!> \brief ...
5499!> \param grid_atom ...
5500!> \param harmonics ...
5501!> \param nspins ...
5502!> \param grad_func ...
5503!> \param ir ...
5504!> \param r_h ...
5505!> \param r_s ...
5506!> \param rho_h ...
5507!> \param rho_s ...
5508!> \param dr_h ...
5509!> \param dr_s ...
5510!> \param r_h_d ...
5511!> \param r_s_d ...
5512!> \param drho_h ...
5513!> \param drho_s ...
5514! **************************************************************************************************
5515 SUBROUTINE calc_rho_angular(grid_atom, harmonics, nspins, grad_func, &
5516 ir, r_h, r_s, rho_h, rho_s, &
5517 dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s)
5518
5519 TYPE(grid_atom_type), POINTER :: grid_atom
5520 TYPE(harmonics_atom_type), POINTER :: harmonics
5521 INTEGER, INTENT(IN) :: nspins
5522 LOGICAL, INTENT(IN) :: grad_func
5523 INTEGER, INTENT(IN) :: ir
5524 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: r_h, r_s
5525 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: rho_h, rho_s
5526 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: dr_h, dr_s
5527 TYPE(rho_atom_coeff), DIMENSION(:, :), POINTER :: r_h_d, r_s_d
5528 REAL(kind=dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s
5529
5530 INTEGER :: ia, iso, ispin, na
5531 REAL(kind=dp) :: rad, urad
5532
5533 cpassert(ASSOCIATED(r_h))
5534 cpassert(ASSOCIATED(r_s))
5535 cpassert(ASSOCIATED(rho_h))
5536 cpassert(ASSOCIATED(rho_s))
5537 IF (grad_func) THEN
5538 cpassert(ASSOCIATED(dr_h))
5539 cpassert(ASSOCIATED(dr_s))
5540 cpassert(ASSOCIATED(r_h_d))
5541 cpassert(ASSOCIATED(r_s_d))
5542 cpassert(ASSOCIATED(drho_h))
5543 cpassert(ASSOCIATED(drho_s))
5544 END IF
5545
5546 na = grid_atom%ng_sphere
5547 rad = grid_atom%rad(ir)
5548 urad = grid_atom%oorad2l(ir, 1)
5549 DO ispin = 1, nspins
5550 DO iso = 1, harmonics%max_iso_not0
5551 DO ia = 1, na
5552 rho_h(ia, ir, ispin) = rho_h(ia, ir, ispin) + &
5553 r_h(ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)
5554 rho_s(ia, ir, ispin) = rho_s(ia, ir, ispin) + &
5555 r_s(ispin)%r_coef(ir, iso)*harmonics%slm(ia, iso)
5556 END DO ! ia
5557 END DO ! iso
5558 END DO ! ispin
5559
5560 IF (grad_func) THEN
5561 DO ispin = 1, nspins
5562 DO iso = 1, harmonics%max_iso_not0
5563 DO ia = 1, na
5564
5565 ! components of the gradient of rho1 hard
5566 drho_h(1, ia, ir, ispin) = drho_h(1, ia, ir, ispin) + &
5567 dr_h(ispin)%r_coef(ir, iso)* &
5568 harmonics%a(1, ia)*harmonics%slm(ia, iso) + &
5569 r_h_d(1, ispin)%r_coef(ir, iso)* &
5570 harmonics%slm(ia, iso)
5571
5572 drho_h(2, ia, ir, ispin) = drho_h(2, ia, ir, ispin) + &
5573 dr_h(ispin)%r_coef(ir, iso)* &
5574 harmonics%a(2, ia)*harmonics%slm(ia, iso) + &
5575 r_h_d(2, ispin)%r_coef(ir, iso)* &
5576 harmonics%slm(ia, iso)
5577
5578 drho_h(3, ia, ir, ispin) = drho_h(3, ia, ir, ispin) + &
5579 dr_h(ispin)%r_coef(ir, iso)* &
5580 harmonics%a(3, ia)*harmonics%slm(ia, iso) + &
5581 r_h_d(3, ispin)%r_coef(ir, iso)* &
5582 harmonics%slm(ia, iso)
5583
5584 ! components of the gradient of rho1 soft
5585 drho_s(1, ia, ir, ispin) = drho_s(1, ia, ir, ispin) + &
5586 dr_s(ispin)%r_coef(ir, iso)* &
5587 harmonics%a(1, ia)*harmonics%slm(ia, iso) + &
5588 r_s_d(1, ispin)%r_coef(ir, iso)* &
5589 harmonics%slm(ia, iso)
5590
5591 drho_s(2, ia, ir, ispin) = drho_s(2, ia, ir, ispin) + &
5592 dr_s(ispin)%r_coef(ir, iso)* &
5593 harmonics%a(2, ia)*harmonics%slm(ia, iso) + &
5594 r_s_d(2, ispin)%r_coef(ir, iso)* &
5595 harmonics%slm(ia, iso)
5596
5597 drho_s(3, ia, ir, ispin) = drho_s(3, ia, ir, ispin) + &
5598 dr_s(ispin)%r_coef(ir, iso)* &
5599 harmonics%a(3, ia)*harmonics%slm(ia, iso) + &
5600 r_s_d(3, ispin)%r_coef(ir, iso)* &
5601 harmonics%slm(ia, iso)
5602
5603 END DO ! ia
5604 END DO ! iso
5605 DO ia = 1, na
5606 drho_h(4, ia, ir, ispin) = sqrt( &
5607 drho_h(1, ia, ir, ispin)*drho_h(1, ia, ir, ispin) + &
5608 drho_h(2, ia, ir, ispin)*drho_h(2, ia, ir, ispin) + &
5609 drho_h(3, ia, ir, ispin)*drho_h(3, ia, ir, ispin))
5610
5611 drho_s(4, ia, ir, ispin) = sqrt( &
5612 drho_s(1, ia, ir, ispin)*drho_s(1, ia, ir, ispin) + &
5613 drho_s(2, ia, ir, ispin)*drho_s(2, ia, ir, ispin) + &
5614 drho_s(3, ia, ir, ispin)*drho_s(3, ia, ir, ispin))
5615 END DO ! ia
5616 END DO ! ispin
5617 END IF
5618
5619 END SUBROUTINE calc_rho_angular
5620
5621! **************************************************************************************************
5622!> \brief Precompute radial and angular factors for GAPW meta-GGA tau contractions
5623!> \param tau_cache precomputed compact one-center gradient basis
5624!> \param grid_atom atom-centered integration grid
5625!> \param basis_1c GAPW one-center basis
5626!> \param harmonics spherical harmonics on the atom-centered grid
5627! **************************************************************************************************
5628 SUBROUTINE create_tau_basis_cache(tau_cache, grid_atom, basis_1c, harmonics)
5629
5630 TYPE(tau_basis_cache_type), INTENT(INOUT) :: tau_cache
5631 TYPE(grid_atom_type), POINTER :: grid_atom
5632 TYPE(gto_basis_set_type), POINTER :: basis_1c
5633 TYPE(harmonics_atom_type), POINTER :: harmonics
5634
5635 INTEGER :: dir, ia, igrid, ip, ipgf, ir, iset, iso, &
5636 l, starti
5637 REAL(dp), ALLOCATABLE, DIMENSION(:) :: a1, a2, gexp, r1, r2
5638 REAL(dp), DIMENSION(:, :), POINTER :: slm
5639 REAL(dp), DIMENSION(:, :, :), POINTER :: dslm_dxyz
5640
5641 NULLIFY (slm, dslm_dxyz)
5642
5643 CALL release_tau_basis_cache(tau_cache)
5644
5645 CALL get_gto_basis_set(gto_basis_set=basis_1c, lmax=tau_cache%lmax, &
5646 lmin=tau_cache%lmin, maxso=tau_cache%maxso, &
5647 npgf=tau_cache%npgf, nset=tau_cache%nset, &
5648 zet=tau_cache%zet)
5649 CALL get_paw_basis_info(basis_1c, o2nindex=tau_cache%o2nindex, &
5650 n2oindex=tau_cache%n2oindex, &
5651 nsatbas=tau_cache%nsatbas)
5652
5653 tau_cache%nr = grid_atom%nr
5654 tau_cache%na = grid_atom%ng_sphere
5655 slm => harmonics%slm
5656 dslm_dxyz => harmonics%dslm_dxyz
5657
5658 ALLOCATE (tau_cache%grad(tau_cache%na*tau_cache%nr, tau_cache%nsatbas, 3))
5659 ALLOCATE (a1(tau_cache%na), a2(tau_cache%na), gexp(tau_cache%nr), &
5660 r1(tau_cache%nr), r2(tau_cache%nr))
5661 tau_cache%grad = 0.0_dp
5662
5663 DO iset = 1, tau_cache%nset
5664 DO ipgf = 1, tau_cache%npgf(iset)
5665 starti = (iset - 1)*tau_cache%maxso + &
5666 (ipgf - 1)*nsoset(tau_cache%lmax(iset))
5667 gexp(1:tau_cache%nr) = exp(-tau_cache%zet(ipgf, iset)* &
5668 grid_atom%rad2(1:tau_cache%nr))
5669 DO iso = nsoset(tau_cache%lmin(iset) - 1) + 1, nsoset(tau_cache%lmax(iset))
5670 ip = tau_cache%o2nindex(starti + iso)
5671 IF (ip == 0) cycle
5672 l = indso(1, iso)
5673
5674 r1(1:tau_cache%nr) = grid_atom%rad(1:tau_cache%nr)**(l - 1)*gexp(1:tau_cache%nr)
5675 r2(1:tau_cache%nr) = -2.0_dp*tau_cache%zet(ipgf, iset)* &
5676 grid_atom%rad2(1:tau_cache%nr)*r1(1:tau_cache%nr)
5677
5678 DO dir = 1, 3
5679 a1(1:tau_cache%na) = dslm_dxyz(dir, 1:tau_cache%na, iso)
5680 a2(1:tau_cache%na) = harmonics%a(dir, 1:tau_cache%na)*slm(1:tau_cache%na, iso)
5681 DO ir = 1, tau_cache%nr
5682 DO ia = 1, tau_cache%na
5683 igrid = ia + (ir - 1)*tau_cache%na
5684 tau_cache%grad(igrid, ip, dir) = r1(ir)*a1(ia) + r2(ir)*a2(ia)
5685 END DO
5686 END DO
5687 END DO
5688 END DO
5689 END DO
5690 END DO
5691
5692 DEALLOCATE (a1, a2, gexp, r1, r2)
5693
5694 END SUBROUTINE create_tau_basis_cache
5695
5696! **************************************************************************************************
5697!> \brief Release precomputed GAPW meta-GGA tau factors
5698!> \param tau_cache precomputed compact one-center gradient basis
5699! **************************************************************************************************
5700 SUBROUTINE release_tau_basis_cache(tau_cache)
5701
5702 TYPE(tau_basis_cache_type), INTENT(INOUT) :: tau_cache
5703
5704 IF (ALLOCATED(tau_cache%grad)) DEALLOCATE (tau_cache%grad)
5705 IF (ASSOCIATED(tau_cache%n2oindex)) DEALLOCATE (tau_cache%n2oindex)
5706 IF (ASSOCIATED(tau_cache%o2nindex)) DEALLOCATE (tau_cache%o2nindex)
5707 NULLIFY (tau_cache%lmax, tau_cache%lmin, tau_cache%n2oindex, tau_cache%npgf, &
5708 tau_cache%zet, tau_cache%o2nindex)
5709 tau_cache%maxso = 0
5710 tau_cache%na = 0
5711 tau_cache%nr = 0
5712 tau_cache%nsatbas = 0
5713 tau_cache%nset = 0
5714
5715 END SUBROUTINE release_tau_basis_cache
5716
5717! **************************************************************************************************
5718!> \brief Computes tau hard and soft on the atomic grids for meta-GGA calculations
5719!> \param tau_h the hard part of tau
5720!> \param tau_s the soft part of tau
5721!> \param rho_atom atom-centered density matrices
5722!> \param tau_cache precomputed compact one-center gradient basis
5723!> \param nspins number of spin channels
5724!> \note This is a rewrite to correct a meta-GGA GAPW bug. This is more brute force than the original,
5725!> which was done along in qs_rho_atom_methods.F, but makes sure that no corner is cut in
5726!> terms of accuracy (A. Bussy)
5727! **************************************************************************************************
5728 SUBROUTINE calc_tau_atom(tau_h, tau_s, rho_atom, tau_cache, nspins)
5729
5730 REAL(dp), DIMENSION(:, :, :), INTENT(INOUT) :: tau_h, tau_s
5731 TYPE(rho_atom_type), POINTER :: rho_atom
5732 TYPE(tau_basis_cache_type), INTENT(IN) :: tau_cache
5733 INTEGER, INTENT(IN) :: nspins
5734
5735 CHARACTER(len=*), PARAMETER :: routinen = 'calc_tau_atom'
5736
5737 INTEGER :: dir, handle, ia, ibas, igrid, ir, ispin, &
5738 na, nbas, ngrid, nr
5739 REAL(dp) :: tau_sum
5740 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: work
5741
5742 CALL timeset(routinen, handle)
5743
5744 cpassert(ALLOCATED(tau_cache%grad))
5745
5746 !zeroing tau, assuming it is already allocated
5747 tau_h = 0.0_dp
5748 tau_s = 0.0_dp
5749
5750 nr = tau_cache%nr
5751 na = tau_cache%na
5752 nbas = tau_cache%nsatbas
5753 ngrid = na*nr
5754 ALLOCATE (work(ngrid, nbas))
5755
5756 DO ispin = 1, nspins
5757 DO dir = 1, 3
5758 CALL dgemm('N', 'T', ngrid, nbas, nbas, 0.5_dp, tau_cache%grad(:, :, dir), &
5759 ngrid, rho_atom%cpc_h(ispin)%r_coef, nbas, 0.0_dp, work, ngrid)
5760!$OMP PARALLEL DO DEFAULT(NONE) COLLAPSE(2) SCHEDULE(STATIC) &
5761!$OMP SHARED(dir, ispin, na, nbas, nr, tau_cache, tau_h, work) &
5762!$OMP PRIVATE(ia, ibas, igrid, ir, tau_sum)
5763 DO ir = 1, nr
5764 DO ia = 1, na
5765 igrid = ia + (ir - 1)*na
5766 tau_sum = 0.0_dp
5767 DO ibas = 1, nbas
5768 tau_sum = tau_sum + tau_cache%grad(igrid, ibas, dir)*work(igrid, ibas)
5769 END DO
5770 tau_h(ia, ir, ispin) = tau_h(ia, ir, ispin) + tau_sum
5771 END DO
5772 END DO
5773!$OMP END PARALLEL DO
5774
5775 CALL dgemm('N', 'T', ngrid, nbas, nbas, 0.5_dp, tau_cache%grad(:, :, dir), &
5776 ngrid, rho_atom%cpc_s(ispin)%r_coef, nbas, 0.0_dp, work, ngrid)
5777!$OMP PARALLEL DO DEFAULT(NONE) COLLAPSE(2) SCHEDULE(STATIC) &
5778!$OMP SHARED(dir, ispin, na, nbas, nr, tau_cache, tau_s, work) &
5779!$OMP PRIVATE(ia, ibas, igrid, ir, tau_sum)
5780 DO ir = 1, nr
5781 DO ia = 1, na
5782 igrid = ia + (ir - 1)*na
5783 tau_sum = 0.0_dp
5784 DO ibas = 1, nbas
5785 tau_sum = tau_sum + tau_cache%grad(igrid, ibas, dir)*work(igrid, ibas)
5786 END DO
5787 tau_s(ia, ir, ispin) = tau_s(ia, ir, ispin) + tau_sum
5788 END DO
5789 END DO
5790!$OMP END PARALLEL DO
5791 END DO
5792 END DO
5793
5794 DEALLOCATE (work)
5795
5796 CALL timestop(handle)
5797
5798 END SUBROUTINE calc_tau_atom
5799
5800! **************************************************************************************************
5801!> \brief ...
5802!> \param grid_atom ...
5803!> \param nspins ...
5804!> \param grad_func ...
5805!> \param ir ...
5806!> \param rho_nlcc ...
5807!> \param rho_h ...
5808!> \param rho_s ...
5809!> \param drho_nlcc ...
5810!> \param drho_h ...
5811!> \param drho_s ...
5812! **************************************************************************************************
5813 SUBROUTINE calc_rho_nlcc(grid_atom, nspins, grad_func, &
5814 ir, rho_nlcc, rho_h, rho_s, drho_nlcc, drho_h, drho_s)
5815
5816 TYPE(grid_atom_type), POINTER :: grid_atom
5817 INTEGER, INTENT(IN) :: nspins
5818 LOGICAL, INTENT(IN) :: grad_func
5819 INTEGER, INTENT(IN) :: ir
5820 REAL(kind=dp), DIMENSION(:) :: rho_nlcc
5821 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: rho_h, rho_s
5822 REAL(kind=dp), DIMENSION(:) :: drho_nlcc
5823 REAL(kind=dp), DIMENSION(:, :, :, :), POINTER :: drho_h, drho_s
5824
5825 INTEGER :: ia, ispin, na
5826 REAL(kind=dp) :: drho, dx, dy, dz, rad, rho, urad, xsp
5827
5828 cpassert(ASSOCIATED(rho_h))
5829 cpassert(ASSOCIATED(rho_s))
5830 IF (grad_func) THEN
5831 cpassert(ASSOCIATED(drho_h))
5832 cpassert(ASSOCIATED(drho_s))
5833 END IF
5834
5835 na = grid_atom%ng_sphere
5836 rad = grid_atom%rad(ir)
5837 urad = grid_atom%oorad2l(ir, 1)
5838
5839 xsp = real(nspins, kind=dp)
5840 rho = rho_nlcc(ir)/xsp
5841 DO ispin = 1, nspins
5842 rho_h(1:na, ir, ispin) = rho_h(1:na, ir, ispin) + rho
5843 rho_s(1:na, ir, ispin) = rho_s(1:na, ir, ispin) + rho
5844 END DO ! ispin
5845
5846 IF (grad_func) THEN
5847 drho = drho_nlcc(ir)/xsp
5848 DO ispin = 1, nspins
5849 DO ia = 1, na
5850 IF (grid_atom%azi(ia) == 0.0_dp) THEN
5851 dx = 0.0_dp
5852 dy = 0.0_dp
5853 ELSE
5854 dx = grid_atom%sin_pol(ia)*grid_atom%sin_azi(ia)
5855 dy = grid_atom%sin_pol(ia)*grid_atom%cos_azi(ia)
5856 END IF
5857 dz = grid_atom%cos_pol(ia)
5858 ! components of the gradient of rho1 hard
5859 drho_h(1, ia, ir, ispin) = drho_h(1, ia, ir, ispin) + drho*dx
5860 drho_h(2, ia, ir, ispin) = drho_h(2, ia, ir, ispin) + drho*dy
5861 drho_h(3, ia, ir, ispin) = drho_h(3, ia, ir, ispin) + drho*dz
5862 ! components of the gradient of rho1 soft
5863 drho_s(1, ia, ir, ispin) = drho_s(1, ia, ir, ispin) + drho*dx
5864 drho_s(2, ia, ir, ispin) = drho_s(2, ia, ir, ispin) + drho*dy
5865 drho_s(3, ia, ir, ispin) = drho_s(3, ia, ir, ispin) + drho*dz
5866 ! norm of gradient
5867 drho_h(4, ia, ir, ispin) = sqrt( &
5868 drho_h(1, ia, ir, ispin)*drho_h(1, ia, ir, ispin) + &
5869 drho_h(2, ia, ir, ispin)*drho_h(2, ia, ir, ispin) + &
5870 drho_h(3, ia, ir, ispin)*drho_h(3, ia, ir, ispin))
5871
5872 drho_s(4, ia, ir, ispin) = sqrt( &
5873 drho_s(1, ia, ir, ispin)*drho_s(1, ia, ir, ispin) + &
5874 drho_s(2, ia, ir, ispin)*drho_s(2, ia, ir, ispin) + &
5875 drho_s(3, ia, ir, ispin)*drho_s(3, ia, ir, ispin))
5876 END DO ! ia
5877 END DO ! ispin
5878 END IF
5879
5880 END SUBROUTINE calc_rho_nlcc
5881
5882! **************************************************************************************************
5883!> \brief ...
5884!> \param vxc_h ...
5885!> \param vxc_s ...
5886!> \param int_hh ...
5887!> \param int_ss ...
5888!> \param grid_atom ...
5889!> \param basis_1c ...
5890!> \param harmonics ...
5891!> \param nspins ...
5892! **************************************************************************************************
5893 SUBROUTINE gavxcgb_nogc(vxc_h, vxc_s, int_hh, int_ss, grid_atom, basis_1c, harmonics, nspins)
5894
5895 REAL(dp), DIMENSION(:, :, :), POINTER :: vxc_h, vxc_s
5896 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: int_hh, int_ss
5897 TYPE(grid_atom_type), POINTER :: grid_atom
5898 TYPE(gto_basis_set_type), POINTER :: basis_1c
5899 TYPE(harmonics_atom_type), POINTER :: harmonics
5900 INTEGER, INTENT(IN) :: nspins
5901
5902 CHARACTER(len=*), PARAMETER :: routinen = 'gaVxcgb_noGC'
5903
5904 INTEGER :: handle, ia, ic, icg, ipgf1, ipgf2, ir, iset1, iset2, iso, iso1, iso2, ispin, l, &
5905 ld, lmax12, lmax_expansion, lmin12, m1, m2, max_iso_not0, max_iso_not0_local, max_s_harm, &
5906 maxl, maxso, n1, n2, na, ngau1, ngau2, nngau1, nr, nset, size1
5907 INTEGER, ALLOCATABLE, DIMENSION(:) :: cg_n_list
5908 INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: cg_list
5909 INTEGER, DIMENSION(:), POINTER :: lmax, lmin, npgf
5910 REAL(dp), ALLOCATABLE, DIMENSION(:) :: g1, g2
5911 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: gg, gvg_h, gvg_s, matso_h, matso_s, vx
5912 REAL(dp), DIMENSION(:, :), POINTER :: zet
5913 REAL(dp), DIMENSION(:, :, :), POINTER :: my_cg
5914
5915 CALL timeset(routinen, handle)
5916
5917 NULLIFY (lmin, lmax, npgf, zet, my_cg)
5918
5919 CALL get_gto_basis_set(gto_basis_set=basis_1c, lmax=lmax, lmin=lmin, &
5920 maxso=maxso, maxl=maxl, npgf=npgf, &
5921 nset=nset, zet=zet)
5922
5923 nr = grid_atom%nr
5924 na = grid_atom%ng_sphere
5925 my_cg => harmonics%my_CG
5926 max_iso_not0 = harmonics%max_iso_not0
5927 lmax_expansion = indso(1, max_iso_not0)
5928 max_s_harm = harmonics%max_s_harm
5929
5930 ALLOCATE (g1(nr), g2(nr), gg(nr, 0:2*maxl))
5931 ALLOCATE (gvg_h(na, 0:2*maxl), gvg_s(na, 0:2*maxl))
5932 ALLOCATE (matso_h(nsoset(maxl), nsoset(maxl)), &
5933 matso_s(nsoset(maxl), nsoset(maxl)))
5934 ALLOCATE (vx(na, nr))
5935 ALLOCATE (cg_list(2, nsoset(maxl)**2, max_s_harm), cg_n_list(max_s_harm))
5936
5937 g1 = 0.0_dp
5938 g2 = 0.0_dp
5939 m1 = 0
5940 DO iset1 = 1, nset
5941 n1 = nsoset(lmax(iset1))
5942 m2 = 0
5943 DO iset2 = 1, nset
5944 CALL get_none0_cg_list(my_cg, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
5945 max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local)
5946 cpassert(max_iso_not0_local <= max_iso_not0)
5947
5948 n2 = nsoset(lmax(iset2))
5949 DO ipgf1 = 1, npgf(iset1)
5950 ngau1 = n1*(ipgf1 - 1) + m1
5951 size1 = nsoset(lmax(iset1)) - nsoset(lmin(iset1) - 1)
5952 nngau1 = nsoset(lmin(iset1) - 1) + ngau1
5953
5954 g1(1:nr) = exp(-zet(ipgf1, iset1)*grid_atom%rad2(1:nr))
5955 DO ipgf2 = 1, npgf(iset2)
5956 ngau2 = n2*(ipgf2 - 1) + m2
5957
5958 g2(1:nr) = exp(-zet(ipgf2, iset2)*grid_atom%rad2(1:nr))
5959 lmin12 = lmin(iset1) + lmin(iset2)
5960 lmax12 = lmax(iset1) + lmax(iset2)
5961
5962 ! reduce expansion local densities
5963 IF (lmin12 <= lmax_expansion) THEN
5964
5965 gg = 0.0_dp
5966 IF (lmin12 == 0) THEN
5967 gg(1:nr, lmin12) = g1(1:nr)*g2(1:nr)
5968 ELSE
5969 gg(1:nr, lmin12) = grid_atom%rad2l(1:nr, lmin12)*g1(1:nr)*g2(1:nr)
5970 END IF
5971
5972 ! limit the expansion of the local densities to a max L
5973 IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion
5974
5975 DO l = lmin12 + 1, lmax12
5976 gg(1:nr, l) = grid_atom%rad(1:nr)*gg(:, l - 1)
5977 END DO
5978
5979 DO ispin = 1, nspins
5980 ld = lmax12 + 1
5981 DO ir = 1, nr
5982 vx(1:na, ir) = vxc_h(1:na, ir, ispin)
5983 END DO
5984 CALL dgemm('N', 'N', na, ld, nr, 1.0_dp, vx(1:na, 1:nr), na, &
5985 gg(1:nr, 0:lmax12), nr, 0.0_dp, gvg_h(1:na, 0:lmax12), na)
5986 DO ir = 1, nr
5987 vx(1:na, ir) = vxc_s(1:na, ir, ispin)
5988 END DO
5989 CALL dgemm('N', 'N', na, ld, nr, 1.0_dp, vx(1:na, 1:nr), na, &
5990 gg(1:nr, 0:lmax12), nr, 0.0_dp, gvg_s(1:na, 0:lmax12), na)
5991
5992 matso_h = 0.0_dp
5993 matso_s = 0.0_dp
5994 DO iso = 1, max_iso_not0_local
5995 DO icg = 1, cg_n_list(iso)
5996 iso1 = cg_list(1, icg, iso)
5997 iso2 = cg_list(2, icg, iso)
5998 l = indso(1, iso1) + indso(1, iso2)
5999
6000 cpassert(l <= lmax_expansion)
6001 DO ia = 1, na
6002 matso_h(iso1, iso2) = matso_h(iso1, iso2) + &
6003 gvg_h(ia, l)* &
6004 my_cg(iso1, iso2, iso)* &
6005 harmonics%slm(ia, iso)
6006 matso_s(iso1, iso2) = matso_s(iso1, iso2) + &
6007 gvg_s(ia, l)* &
6008 my_cg(iso1, iso2, iso)* &
6009 harmonics%slm(ia, iso)
6010 END DO
6011 END DO
6012 END DO
6013
6014 ! Write in the global matrix
6015 DO ic = nsoset(lmin(iset2) - 1) + 1, nsoset(lmax(iset2))
6016 iso1 = nsoset(lmin(iset1) - 1) + 1
6017 iso2 = ngau2 + ic
6018 CALL daxpy(size1, 1.0_dp, matso_h(iso1, ic), 1, &
6019 int_hh(ispin)%r_coef(nngau1 + 1, iso2), 1)
6020 CALL daxpy(size1, 1.0_dp, matso_s(iso1, ic), 1, &
6021 int_ss(ispin)%r_coef(nngau1 + 1, iso2), 1)
6022 END DO
6023
6024 END DO ! ispin
6025
6026 END IF ! lmax_expansion
6027
6028 END DO ! ipfg2
6029 END DO ! ipfg1
6030 m2 = m2 + maxso
6031 END DO ! iset2
6032 m1 = m1 + maxso
6033 END DO ! iset1
6034
6035 DEALLOCATE (g1, g2, gg, matso_h, matso_s, gvg_s, gvg_h, vx)
6036
6037 DEALLOCATE (cg_list, cg_n_list)
6038
6039 CALL timestop(handle)
6040
6041 END SUBROUTINE gavxcgb_nogc
6042
6043! **************************************************************************************************
6044!> \brief ...
6045!> \param vxc_h ...
6046!> \param vxc_s ...
6047!> \param vxg_h ...
6048!> \param vxg_s ...
6049!> \param int_hh ...
6050!> \param int_ss ...
6051!> \param grid_atom ...
6052!> \param basis_1c ...
6053!> \param harmonics ...
6054!> \param nspins ...
6055! **************************************************************************************************
6056 SUBROUTINE gavxcgb_gc(vxc_h, vxc_s, vxg_h, vxg_s, int_hh, int_ss, &
6057 grid_atom, basis_1c, harmonics, nspins)
6058
6059 REAL(dp), DIMENSION(:, :, :), POINTER :: vxc_h, vxc_s
6060 REAL(dp), DIMENSION(:, :, :, :), POINTER :: vxg_h, vxg_s
6061 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: int_hh, int_ss
6062 TYPE(grid_atom_type), POINTER :: grid_atom
6063 TYPE(gto_basis_set_type), POINTER :: basis_1c
6064 TYPE(harmonics_atom_type), POINTER :: harmonics
6065 INTEGER, INTENT(IN) :: nspins
6066
6067 CHARACTER(len=*), PARAMETER :: routinen = 'gaVxcgb_GC'
6068
6069 INTEGER :: dmax_iso_not0_local, handle, ia, ic, icg, ipgf1, ipgf2, ir, iset1, iset2, iso, &
6070 iso1, iso2, ispin, l, lmax12, lmax_expansion, lmin12, m1, m2, max_iso_not0, &
6071 max_iso_not0_local, max_s_harm, maxl, maxso, n1, n2, na, ngau1, ngau2, nngau1, nr, nset, &
6072 size1
6073 INTEGER, ALLOCATABLE, DIMENSION(:) :: cg_n_list, dcg_n_list
6074 INTEGER, ALLOCATABLE, DIMENSION(:, :, :) :: cg_list, dcg_list
6075 INTEGER, DIMENSION(:), POINTER :: lmax, lmin, npgf
6076 REAL(dp) :: urad
6077 REAL(dp), ALLOCATABLE, DIMENSION(:) :: g1, g2
6078 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: dgg, gg, gvxcg_h, gvxcg_s, matso_h, &
6079 matso_s
6080 REAL(dp), ALLOCATABLE, DIMENSION(:, :, :) :: gvxgg_h, gvxgg_s
6081 REAL(dp), DIMENSION(:, :), POINTER :: zet
6082 REAL(dp), DIMENSION(:, :, :), POINTER :: my_cg
6083 REAL(dp), DIMENSION(:, :, :, :), POINTER :: my_cg_dxyz
6084
6085 CALL timeset(routinen, handle)
6086
6087 NULLIFY (lmin, lmax, npgf, zet, my_cg, my_cg_dxyz)
6088
6089 CALL get_gto_basis_set(gto_basis_set=basis_1c, lmax=lmax, lmin=lmin, &
6090 maxso=maxso, maxl=maxl, npgf=npgf, &
6091 nset=nset, zet=zet)
6092
6093 nr = grid_atom%nr
6094 na = grid_atom%ng_sphere
6095 my_cg => harmonics%my_CG
6096 my_cg_dxyz => harmonics%my_CG_dxyz
6097 max_iso_not0 = harmonics%max_iso_not0
6098 lmax_expansion = indso(1, max_iso_not0)
6099 max_s_harm = harmonics%max_s_harm
6100
6101 ALLOCATE (g1(nr), g2(nr), gg(nr, 0:2*maxl), dgg(nr, 0:2*maxl))
6102 ALLOCATE (gvxcg_h(na, 0:2*maxl), gvxcg_s(na, 0:2*maxl))
6103 ALLOCATE (gvxgg_h(3, na, 0:2*maxl), gvxgg_s(3, na, 0:2*maxl))
6104 ALLOCATE (cg_list(2, nsoset(maxl)**2, max_s_harm), cg_n_list(max_s_harm), &
6105 dcg_list(2, nsoset(maxl)**2, max_s_harm), dcg_n_list(max_s_harm))
6106
6107 ALLOCATE (matso_h(nsoset(maxl), nsoset(maxl)), &
6108 matso_s(nsoset(maxl), nsoset(maxl)))
6109
6110 DO ispin = 1, nspins
6111
6112 g1 = 0.0_dp
6113 g2 = 0.0_dp
6114 m1 = 0
6115 DO iset1 = 1, nset
6116 n1 = nsoset(lmax(iset1))
6117 m2 = 0
6118 DO iset2 = 1, nset
6119 CALL get_none0_cg_list(my_cg, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
6120 max_s_harm, lmax_expansion, cg_list, cg_n_list, max_iso_not0_local)
6121 cpassert(max_iso_not0_local <= max_iso_not0)
6122 CALL get_none0_cg_list(my_cg_dxyz, lmin(iset1), lmax(iset1), lmin(iset2), lmax(iset2), &
6123 max_s_harm, lmax_expansion, dcg_list, dcg_n_list, dmax_iso_not0_local)
6124
6125 n2 = nsoset(lmax(iset2))
6126 DO ipgf1 = 1, npgf(iset1)
6127 ngau1 = n1*(ipgf1 - 1) + m1
6128 size1 = nsoset(lmax(iset1)) - nsoset(lmin(iset1) - 1)
6129 nngau1 = nsoset(lmin(iset1) - 1) + ngau1
6130
6131 g1(1:nr) = exp(-zet(ipgf1, iset1)*grid_atom%rad2(1:nr))
6132 DO ipgf2 = 1, npgf(iset2)
6133 ngau2 = n2*(ipgf2 - 1) + m2
6134
6135 g2(1:nr) = exp(-zet(ipgf2, iset2)*grid_atom%rad2(1:nr))
6136 lmin12 = lmin(iset1) + lmin(iset2)
6137 lmax12 = lmax(iset1) + lmax(iset2)
6138
6139 !test reduce expansion local densities
6140 IF (lmin12 <= lmax_expansion) THEN
6141
6142 gg = 0.0_dp
6143 dgg = 0.0_dp
6144
6145 IF (lmin12 == 0) THEN
6146 gg(1:nr, lmin12) = g1(1:nr)*g2(1:nr)
6147 ELSE
6148 gg(1:nr, lmin12) = grid_atom%rad2l(1:nr, lmin12)*g1(1:nr)*g2(1:nr)
6149 END IF
6150
6151 !test reduce expansion local densities
6152 IF (lmax12 > lmax_expansion) lmax12 = lmax_expansion
6153
6154 DO l = lmin12 + 1, lmax12
6155 gg(1:nr, l) = grid_atom%rad(1:nr)*gg(:, l - 1)
6156 dgg(1:nr, l - 1) = dgg(1:nr, l - 1) - 2.0_dp*(zet(ipgf1, iset1) + &
6157 zet(ipgf2, iset2))*gg(1:nr, l)
6158 END DO
6159 dgg(1:nr, lmax12) = dgg(1:nr, lmax12) - 2.0_dp*(zet(ipgf1, iset1) + &
6160 zet(ipgf2, iset2))*grid_atom%rad(1:nr)* &
6161 gg(1:nr, lmax12)
6162
6163 gvxcg_h = 0.0_dp
6164 gvxcg_s = 0.0_dp
6165 gvxgg_h = 0.0_dp
6166 gvxgg_s = 0.0_dp
6167
6168 ! Cross Term
6169 DO l = lmin12, lmax12
6170 DO ia = 1, na
6171 DO ir = 1, nr
6172 gvxcg_h(ia, l) = gvxcg_h(ia, l) + &
6173 gg(ir, l)*vxc_h(ia, ir, ispin) + &
6174 dgg(ir, l)* &
6175 (vxg_h(1, ia, ir, ispin)*harmonics%a(1, ia) + &
6176 vxg_h(2, ia, ir, ispin)*harmonics%a(2, ia) + &
6177 vxg_h(3, ia, ir, ispin)*harmonics%a(3, ia))
6178
6179 gvxcg_s(ia, l) = gvxcg_s(ia, l) + &
6180 gg(ir, l)*vxc_s(ia, ir, ispin) + &
6181 dgg(ir, l)* &
6182 (vxg_s(1, ia, ir, ispin)*harmonics%a(1, ia) + &
6183 vxg_s(2, ia, ir, ispin)*harmonics%a(2, ia) + &
6184 vxg_s(3, ia, ir, ispin)*harmonics%a(3, ia))
6185
6186 urad = grid_atom%oorad2l(ir, 1)
6187
6188 gvxgg_h(1, ia, l) = gvxgg_h(1, ia, l) + &
6189 vxg_h(1, ia, ir, ispin)* &
6190 gg(ir, l)*urad
6191
6192 gvxgg_h(2, ia, l) = gvxgg_h(2, ia, l) + &
6193 vxg_h(2, ia, ir, ispin)* &
6194 gg(ir, l)*urad
6195
6196 gvxgg_h(3, ia, l) = gvxgg_h(3, ia, l) + &
6197 vxg_h(3, ia, ir, ispin)* &
6198 gg(ir, l)*urad
6199
6200 gvxgg_s(1, ia, l) = gvxgg_s(1, ia, l) + &
6201 vxg_s(1, ia, ir, ispin)* &
6202 gg(ir, l)*urad
6203
6204 gvxgg_s(2, ia, l) = gvxgg_s(2, ia, l) + &
6205 vxg_s(2, ia, ir, ispin)* &
6206 gg(ir, l)*urad
6207
6208 gvxgg_s(3, ia, l) = gvxgg_s(3, ia, l) + &
6209 vxg_s(3, ia, ir, ispin)* &
6210 gg(ir, l)*urad
6211
6212 END DO ! ir
6213 END DO ! ia
6214 END DO ! l
6215
6216 matso_h = 0.0_dp
6217 matso_s = 0.0_dp
6218 DO iso = 1, max_iso_not0_local
6219 DO icg = 1, cg_n_list(iso)
6220 iso1 = cg_list(1, icg, iso)
6221 iso2 = cg_list(2, icg, iso)
6222
6223 l = indso(1, iso1) + indso(1, iso2)
6224
6225 !test reduce expansion local densities
6226 cpassert(l <= lmax_expansion)
6227 DO ia = 1, na
6228 matso_h(iso1, iso2) = matso_h(iso1, iso2) + &
6229 gvxcg_h(ia, l)* &
6230 harmonics%slm(ia, iso)* &
6231 my_cg(iso1, iso2, iso)
6232 matso_s(iso1, iso2) = matso_s(iso1, iso2) + &
6233 gvxcg_s(ia, l)* &
6234 harmonics%slm(ia, iso)* &
6235 my_cg(iso1, iso2, iso)
6236 END DO ! ia
6237
6238 !test reduce expansion local densities
6239
6240 END DO
6241
6242 END DO ! iso
6243
6244 DO iso = 1, dmax_iso_not0_local
6245 DO icg = 1, dcg_n_list(iso)
6246 iso1 = dcg_list(1, icg, iso)
6247 iso2 = dcg_list(2, icg, iso)
6248
6249 l = indso(1, iso1) + indso(1, iso2)
6250 !test reduce expansion local densities
6251 cpassert(l <= lmax_expansion)
6252 DO ia = 1, na
6253 matso_h(iso1, iso2) = matso_h(iso1, iso2) + &
6254 (gvxgg_h(1, ia, l)*my_cg_dxyz(1, iso1, iso2, iso) + &
6255 gvxgg_h(2, ia, l)*my_cg_dxyz(2, iso1, iso2, iso) + &
6256 gvxgg_h(3, ia, l)*my_cg_dxyz(3, iso1, iso2, iso))* &
6257 harmonics%slm(ia, iso)
6258
6259 matso_s(iso1, iso2) = matso_s(iso1, iso2) + &
6260 (gvxgg_s(1, ia, l)*my_cg_dxyz(1, iso1, iso2, iso) + &
6261 gvxgg_s(2, ia, l)*my_cg_dxyz(2, iso1, iso2, iso) + &
6262 gvxgg_s(3, ia, l)*my_cg_dxyz(3, iso1, iso2, iso))* &
6263 harmonics%slm(ia, iso)
6264
6265 END DO ! ia
6266
6267 !test reduce expansion local densities
6268
6269 END DO ! icg
6270 END DO ! iso
6271 !test reduce expansion local densities
6272 END IF ! lmax_expansion
6273
6274 ! Write in the global matrix
6275 DO ic = nsoset(lmin(iset2) - 1) + 1, nsoset(lmax(iset2))
6276 iso1 = nsoset(lmin(iset1) - 1) + 1
6277 iso2 = ngau2 + ic
6278 CALL daxpy(size1, 1.0_dp, matso_h(iso1, ic), 1, &
6279 int_hh(ispin)%r_coef(nngau1 + 1, iso2), 1)
6280 CALL daxpy(size1, 1.0_dp, matso_s(iso1, ic), 1, &
6281 int_ss(ispin)%r_coef(nngau1 + 1, iso2), 1)
6282 END DO
6283
6284 END DO ! ipfg2
6285 END DO ! ipfg1
6286 m2 = m2 + maxso
6287 END DO ! iset2
6288 m1 = m1 + maxso
6289 END DO ! iset1
6290 END DO ! ispin
6291
6292 DEALLOCATE (g1, g2, gg, dgg, matso_h, matso_s, gvxcg_h, gvxcg_s, gvxgg_h, gvxgg_s)
6293 DEALLOCATE (cg_list, cg_n_list, dcg_list, dcg_n_list)
6294
6295 CALL timestop(handle)
6296
6297 END SUBROUTINE gavxcgb_gc
6298
6299! **************************************************************************************************
6300!> \brief Integrates 0.5 * grad_ga .dot. (V_tau * grad_gb) on the atomic grid for meta-GGA
6301!> \param vtau_h the hard tau potential
6302!> \param vtau_s the soft tau potential
6303!> \param int_hh hard one-center matrix contribution
6304!> \param int_ss soft one-center matrix contribution
6305!> \param tau_cache precomputed compact one-center gradient basis
6306!> \param nspins number of spin channels
6307!> \note This is a rewrite to correct meta-GGA GAPW bug. This is more brute force than the original
6308!> but makes sure that no corner is cut in terms of accuracy (A. Bussy)
6309! **************************************************************************************************
6310 SUBROUTINE dgavtaudgb(vtau_h, vtau_s, int_hh, int_ss, tau_cache, nspins)
6311
6312 REAL(dp), DIMENSION(:, :, :), POINTER :: vtau_h, vtau_s
6313 TYPE(rho_atom_coeff), DIMENSION(:), POINTER :: int_hh, int_ss
6314 TYPE(tau_basis_cache_type), INTENT(IN) :: tau_cache
6315 INTEGER, INTENT(IN) :: nspins
6316
6317 CHARACTER(len=*), PARAMETER :: routinen = 'dgaVtaudgb'
6318
6319 INTEGER :: dir, handle, ia, ibas, igrid, iold, ir, &
6320 ispin, jbas, jold, max_old_basis, na, &
6321 nbas, ngrid, nr
6322 REAL(dp), ALLOCATABLE, DIMENSION(:, :) :: int_h, int_s, weighted_grad
6323
6324 CALL timeset(routinen, handle)
6325
6326 cpassert(ALLOCATED(tau_cache%grad))
6327 cpassert(ASSOCIATED(tau_cache%n2oindex))
6328
6329 nr = tau_cache%nr
6330 na = tau_cache%na
6331 nbas = tau_cache%nsatbas
6332 ngrid = na*nr
6333 max_old_basis = maxval(tau_cache%n2oindex)
6334 ALLOCATE (int_h(nbas, nbas), int_s(nbas, nbas), weighted_grad(ngrid, nbas))
6335
6336 DO ispin = 1, nspins
6337 cpassert(SIZE(int_hh(ispin)%r_coef, 1) >= max_old_basis)
6338 cpassert(SIZE(int_hh(ispin)%r_coef, 2) >= max_old_basis)
6339 cpassert(SIZE(int_ss(ispin)%r_coef, 1) >= max_old_basis)
6340 cpassert(SIZE(int_ss(ispin)%r_coef, 2) >= max_old_basis)
6341 int_h = 0.0_dp
6342 int_s = 0.0_dp
6343 DO dir = 1, 3
6344!$OMP PARALLEL DO DEFAULT(NONE) COLLAPSE(3) SCHEDULE(STATIC) &
6345!$OMP SHARED(dir, ispin, na, nbas, nr, tau_cache, vtau_h, weighted_grad) &
6346!$OMP PRIVATE(ia, ibas, igrid, ir)
6347 DO ibas = 1, nbas
6348 DO ir = 1, nr
6349 DO ia = 1, na
6350 igrid = ia + (ir - 1)*na
6351 weighted_grad(igrid, ibas) = vtau_h(ia, ir, ispin)* &
6352 tau_cache%grad(igrid, ibas, dir)
6353 END DO
6354 END DO
6355 END DO
6356!$OMP END PARALLEL DO
6357 CALL dgemm('T', 'N', nbas, nbas, ngrid, 0.5_dp, tau_cache%grad(:, :, dir), &
6358 ngrid, weighted_grad, ngrid, 1.0_dp, int_h, nbas)
6359
6360!$OMP PARALLEL DO DEFAULT(NONE) COLLAPSE(3) SCHEDULE(STATIC) &
6361!$OMP SHARED(dir, ispin, na, nbas, nr, tau_cache, vtau_s, weighted_grad) &
6362!$OMP PRIVATE(ia, ibas, igrid, ir)
6363 DO ibas = 1, nbas
6364 DO ir = 1, nr
6365 DO ia = 1, na
6366 igrid = ia + (ir - 1)*na
6367 weighted_grad(igrid, ibas) = vtau_s(ia, ir, ispin)* &
6368 tau_cache%grad(igrid, ibas, dir)
6369 END DO
6370 END DO
6371 END DO
6372!$OMP END PARALLEL DO
6373 CALL dgemm('T', 'N', nbas, nbas, ngrid, 0.5_dp, tau_cache%grad(:, :, dir), &
6374 ngrid, weighted_grad, ngrid, 1.0_dp, int_s, nbas)
6375 END DO
6376
6377!$OMP PARALLEL DO DEFAULT(NONE) COLLAPSE(2) SCHEDULE(STATIC) &
6378!$OMP SHARED(int_h, int_hh, int_s, int_ss, ispin, nbas, tau_cache) &
6379!$OMP PRIVATE(ibas, iold, jbas, jold)
6380 DO jbas = 1, nbas
6381 DO ibas = 1, nbas
6382 jold = tau_cache%n2oindex(jbas)
6383 iold = tau_cache%n2oindex(ibas)
6384 int_hh(ispin)%r_coef(iold, jold) = int_hh(ispin)%r_coef(iold, jold) + &
6385 int_h(ibas, jbas)
6386 int_ss(ispin)%r_coef(iold, jold) = int_ss(ispin)%r_coef(iold, jold) + &
6387 int_s(ibas, jbas)
6388 END DO
6389 END DO
6390!$OMP END PARALLEL DO
6391 END DO
6392
6393 DEALLOCATE (int_h, int_s, weighted_grad)
6394
6395 CALL timestop(handle)
6396
6397 END SUBROUTINE dgavtaudgb
6398
6399END MODULE qs_vxc_atom
6400
modulo
static GRID_HOST_DEVICE int modulo(int a, int m)
Equivalent of Fortran's MODULO, which always return a positive number. https://gcc....
Definition grid_common.h:125
dgemm
static void dgemm(const char transa, const char transb, const int m, const int n, const int k, const double alpha, const double *a, const int lda, const double *b, const int ldb, const double beta, double *c, const int ldc)
Convenient wrapper to hide Fortran nature of dgemm_, swapping a and b.
Definition grid_cpu_task_list.c:225
external_potential_types::get_potential
Definition external_potential_types.F:278
memory_utilities::reallocate
Definition memory_utilities.F:27
pw_methods::pw_axpy
Definition pw_methods.F:165
qs_harmonics_atom::get_none0_cg_list
Definition qs_harmonics_atom.F:54
spherical_harmonics::y_lm
Definition spherical_harmonics.F:45
atom
Definition atom.F:9
atomic_kind_types
Define the atomic kind types and their sub types.
Definition atomic_kind_types.F:23
atomic_kind_types::get_atomic_kind
subroutine, public get_atomic_kind(atomic_kind, fist_potential, element_symbol, name, mass, kind_number, natom, atom_list, rcov, rvdw, z, qeff, apol, cpol, mm_radius, shell, shell_active, damping)
Get attributes of an atomic kind.
Definition atomic_kind_types.F:138
basis_set_types
Definition basis_set_types.F:15
basis_set_types::get_gto_basis_set
subroutine, public get_gto_basis_set(gto_basis_set, name, aliases, norm_type, kind_radius, ncgf, nset, nsgf, cgf_symbol, sgf_symbol, norm_cgf, set_radius, lmax, lmin, lx, ly, lz, m, ncgf_set, npgf, nsgf_set, nshell, cphi, pgf_radius, sphi, scon, zet, first_cgf, first_sgf, l, last_cgf, last_sgf, n, gcc, maxco, maxl, maxpgf, maxsgf_set, maxshell, maxso, nco_sum, npgf_sum, nshell_sum, maxder, short_kind_radius, npgf_seg_sum, ccon)
...
Definition basis_set_types.F:643
cell_types
Handles all functions related to the CELL.
Definition cell_types.F:15
cp_array_utils
various utilities that regard array of different kinds: output, allocation,... maybe it is not a good...
Definition cp_array_utils.F:18
cp_control_types
Defines control structures, which contain the parameters and the settings for the DFT-based calculati...
Definition cp_control_types.F:12
cp_log_handling
various routines to log and control the output. The idea is that decisions about where to log should ...
Definition cp_log_handling.F:41
cp_log_handling::cp_logger_get_default_io_unit
integer function, public cp_logger_get_default_io_unit(logger)
returns the unit nr for the ionode (-1 on all other processors) skips as well checks if the procs cal...
Definition cp_log_handling.F:523
external_potential_types
Definition of the atomic potential types.
Definition external_potential_types.F:14
input_constants
collects all constants needed in input so that they can be used without circular dependencies
Definition input_constants.F:18
input_constants::cdft_beta_constraint
integer, parameter, public cdft_beta_constraint
Definition input_constants.F:804
input_constants::cdft_magnetization_constraint
integer, parameter, public cdft_magnetization_constraint
Definition input_constants.F:804
input_constants::cdft_charge_constraint
integer, parameter, public cdft_charge_constraint
Definition input_constants.F:804
input_constants::cdft_alpha_constraint
integer, parameter, public cdft_alpha_constraint
Definition input_constants.F:804
input_constants::xc_none
integer, parameter, public xc_none
Definition input_constants.F:577
input_section_types
objects that represent the structure of input sections and the data contained in an input section
Definition input_section_types.F:15
input_section_types::section_get_rval
real(kind=dp) function, public section_get_rval(section_vals, keyword_name)
...
Definition input_section_types.F:953
input_section_types::section_vals_get_subs_vals
recursive type(section_vals_type) function, pointer, public section_vals_get_subs_vals(section_vals, subsection_name, i_rep_section, can_return_null)
returns the values of the requested subsection
Definition input_section_types.F:735
input_section_types::section_vals_val_get
subroutine, public section_vals_val_get(section_vals, keyword_name, i_rep_section, i_rep_val, n_rep_val, val, l_val, i_val, r_val, c_val, l_vals, i_vals, r_vals, c_vals, explicit)
returns the requested value
Definition input_section_types.F:1052
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::int_8
integer, parameter, public int_8
Definition kinds.F:54
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
lebedev
Generation of the spherical Lebedev grids. All Lebedev grids were generated with a precision of at le...
Definition lebedev.F:57
lebedev::deallocate_lebedev_grids
subroutine, public deallocate_lebedev_grids()
...
Definition lebedev.F:324
lebedev::lebedev_grid
type(oh_grid), dimension(nlg), target, public lebedev_grid
Definition lebedev.F:85
lebedev::get_number_of_lebedev_grid
integer function, public get_number_of_lebedev_grid(l, n)
Get the number of the Lebedev grid, which has the requested angular momentum quantnum number l or siz...
Definition lebedev.F:114
lebedev::init_lebedev_grids
subroutine, public init_lebedev_grids()
Load the coordinates and weights of the nonredundant Lebedev grid points.
Definition lebedev.F:344
memory_utilities
Utility routines for the memory handling.
Definition memory_utilities.F:14
message_passing
Interface to the message passing library MPI.
Definition message_passing.F:25
orbital_pointers
Provides Cartesian and spherical orbital pointers and indices.
Definition orbital_pointers.F:15
orbital_pointers::nco
integer, dimension(:), allocatable, public nco
Definition orbital_pointers.F:42
orbital_pointers::nsoset
integer, dimension(:), allocatable, public nsoset
Definition orbital_pointers.F:42
orbital_pointers::indso
integer, dimension(:, :), allocatable, public indso
Definition orbital_pointers.F:43
orbital_pointers::ncoset
integer, dimension(:), allocatable, public ncoset
Definition orbital_pointers.F:42
orbital_pointers::indco
integer, dimension(:, :), allocatable, public indco
Definition orbital_pointers.F:43
orbital_transformation_matrices
Calculation of the spherical harmonics and the corresponding orbital transformation matrices.
Definition orbital_transformation_matrices.F:17
orbital_transformation_matrices::orbtramat
type(orbtramat_type), dimension(:), pointer, public orbtramat
Definition orbital_transformation_matrices.F:47
particle_types
Define the data structure for the particle information.
Definition particle_types.F:19
paw_basis_types
Definition paw_basis_types.F:13
paw_basis_types::get_paw_basis_info
subroutine, public get_paw_basis_info(basis_1c, o2nindex, n2oindex, nsatbas)
Return some info on the PAW basis derived from a GTO basis set.
Definition paw_basis_types.F:40
pw_env_types
container for various plainwaves related things
Definition pw_env_types.F:14
pw_env_types::pw_env_get
subroutine, public pw_env_get(pw_env, pw_pools, cube_info, gridlevel_info, auxbas_pw_pool, auxbas_grid, auxbas_rs_desc, auxbas_rs_grid, rs_descs, rs_grids, xc_pw_pool, vdw_pw_pool, poisson_env, interp_section)
returns the various attributes of the pw env
Definition pw_env_types.F:113
pw_grid_types
Definition pw_grid_types.F:13
pw_methods
Definition pw_methods.F:25
pw_pool_types
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
Definition pw_pool_types.F:24
pw_types
Definition pw_types.F:24
qs_cdft_grid
Pointwise CDFT partition functions for nonuniform integration grids.
Definition qs_cdft_grid.F:11
qs_cdft_grid::cdft_point_context_create
subroutine, public cdft_point_context_create(qs_env, context, calculate_derivatives)
Initialize reusable data for pointwise CDFT partition evaluation.
Definition qs_cdft_grid.F:72
qs_cdft_grid::cdft_point_context_release
subroutine, public cdft_point_context_release(context)
Release a pointwise CDFT partition context.
Definition qs_cdft_grid.F:290
qs_cdft_grid::cdft_point_weights
subroutine, public cdft_point_weights(context, point, weights, point_derivative, atom_derivative, atomic_weights)
Evaluate CDFT weights and coordinate derivatives at one point.
Definition qs_cdft_grid.F:330
qs_cdft_types
Defines CDFT control structures.
Definition qs_cdft_types.F:14
qs_environment_types
Definition qs_environment_types.F:14
qs_environment_types::get_qs_env
subroutine, public get_qs_env(qs_env, atomic_kind_set, qs_kind_set, cell, super_cell, cell_ref, use_ref_cell, kpoints, dft_control, mos, sab_orb, sab_all, qmmm, qmmm_periodic, mimic, sac_ae, sac_ppl, sac_lri, sap_ppnl, sab_vdw, sab_scp, sap_oce, sab_lrc, sab_se, sab_xtbe, sab_tbe, sab_core, sab_xb, sab_xtb_pp, sab_xtb_nonbond, sab_almo, sab_kp, sab_kp_nosym, sab_cneo, particle_set, energy, force, matrix_h, matrix_h_im, matrix_ks, matrix_ks_im, matrix_vxc, run_rtp, rtp, matrix_h_kp, matrix_h_im_kp, matrix_ks_kp, matrix_ks_im_kp, matrix_vxc_kp, kinetic_kp, matrix_s_kp, matrix_w_kp, matrix_s_ri_aux_kp, matrix_s, matrix_s_ri_aux, matrix_w, matrix_p_mp2, matrix_p_mp2_admm, matrix_vhxc, rho, rho_xc, pw_env, ewald_env, ewald_pw, active_space, mpools, input, para_env, blacs_env, scf_control, rel_control, kinetic, qs_charges, vppl, xcint_weights, rho_core, rho_nlcc, rho_nlcc_g, ks_env, ks_qmmm_env, wf_history, scf_env, local_particles, local_molecules, distribution_2d, dbcsr_dist, molecule_kind_set, molecule_set, subsys, cp_subsys, oce, local_rho_set, rho_atom_set, task_list, task_list_soft, rho0_atom_set, rho0_mpole, rhoz_set, rhoz_cneo_set, ecoul_1c, rho0_s_rs, rho0_s_gs, rhoz_cneo_s_rs, rhoz_cneo_s_gs, do_kpoints, has_unit_metric, requires_mo_derivs, mo_derivs, mo_loc_history, nkind, natom, nelectron_total, nelectron_spin, efield, neighbor_list_id, linres_control, xas_env, virial, cp_ddapc_env, cp_ddapc_ewald, outer_scf_history, outer_scf_ihistory, x_data, et_coupling, dftb_potential, results, se_taper, se_store_int_env, se_nddo_mpole, se_nonbond_env, admm_env, lri_env, lri_density, exstate_env, ec_env, harris_env, dispersion_env, gcp_env, vee, rho_external, external_vxc, mask, mp2_env, bs_env, kg_env, wanniercentres, atprop, ls_scf_env, do_transport, transport_env, v_hartree_rspace, s_mstruct_changed, rho_changed, potential_changed, forces_up_to_date, mscfg_env, almo_scf_env, gradient_history, variable_history, embed_pot, spin_embed_pot, polar_env, mos_last_converged, eeq, rhs, do_rixs, tb_tblite)
Get the QUICKSTEP environment.
Definition qs_environment_types.F:539
qs_force_types
Definition qs_force_types.F:13
qs_grid_atom
Definition qs_grid_atom.F:8
qs_grid_atom::allocate_grid_atom
subroutine, public allocate_grid_atom(grid_atom)
Initialize components of the grid_atom_type structure.
Definition qs_grid_atom.F:74
qs_grid_atom::create_grid_atom
subroutine, public create_grid_atom(grid_atom, nr, na, llmax, ll, quadrature)
...
Definition qs_grid_atom.F:189
qs_harmonics_atom
Definition qs_harmonics_atom.F:8
qs_kind_types
Define the quickstep kind type and their sub types.
Definition qs_kind_types.F:23
qs_kind_types::has_nlcc
logical function, public has_nlcc(qs_kind_set)
finds if a given qs run needs to use nlcc
Definition qs_kind_types.F:4286
qs_kind_types::get_qs_kind
subroutine, public get_qs_kind(qs_kind, basis_set, basis_type, ncgf, nsgf, all_potential, tnadd_potential, gth_potential, sgp_potential, upf_potential, cneo_potential, se_parameter, dftb_parameter, xtb_parameter, dftb3_param, zatom, zeff, elec_conf, mao, lmax_dftb, alpha_core_charge, ccore_charge, core_charge, core_charge_radius, paw_proj_set, paw_atom, hard_radius, hard0_radius, max_rad_local, covalent_radius, vdw_radius, gpw_type_forced, harmonics, max_iso_not0, max_s_harm, grid_atom, ngrid_ang, ngrid_rad, lmax_rho0, dft_plus_u_atom, l_of_dft_plus_u, n_of_dft_plus_u, u_minus_j, hund_j, u_of_dft_plus_u, j_of_dft_plus_u, alpha_of_dft_plus_u, beta_of_dft_plus_u, j0_of_dft_plus_u, occupation_of_dft_plus_u, dispersion, bs_occupation, magnetization, no_optimize, addel, laddel, naddel, orbitals, max_scf, eps_scf, smear, u_ramping, u_minus_j_target, eps_u_ramping, proj_shell_charge, lr_atom, do_mtlr, u_j_loop, ao_coef, init_u_ramping_each_scf, reltmat, ghost, monovalent, floating, name, element_symbol, pao_basis_size, pao_model_file, pao_potentials, pao_descriptors, nelec)
Get attributes of an atomic kind.
Definition qs_kind_types.F:491
qs_linres_types
Type definitiona for linear response calculations.
Definition qs_linres_types.F:12
qs_rho_atom_methods
Definition qs_rho_atom_methods.F:7
qs_rho_atom_methods::replicate_rho_atom_radial
subroutine, public replicate_rho_atom_radial(para_env, rho_atom_set, qs_kind, atom_list, natom, nspins)
Replicate the radial hard/soft density data needed to evaluate one-center tails on rank-local target ...
Definition qs_rho_atom_methods.F:448
qs_rho_atom_types
Definition qs_rho_atom_types.F:8
qs_rho_atom_types::get_rho_atom
subroutine, public get_rho_atom(rho_atom, cpc_h, cpc_s, rho_rad_h, rho_rad_s, drho_rad_h, drho_rad_s, vrho_rad_h, vrho_rad_s, rho_rad_h_d, rho_rad_s_d, ga_vlocal_gb_h, ga_vlocal_gb_s, int_scr_h, int_scr_s)
...
Definition qs_rho_atom_types.F:195
qs_rho_types
superstucture that hold various representations of the density and keeps track of which ones are vali...
Definition qs_rho_types.F:18
qs_rho_types::qs_rho_get
subroutine, public qs_rho_get(rho_struct, rho_ao, rho_ao_im, rho_ao_kp, rho_ao_im_kp, rho_r, drho_r, rho_g, drho_g, tau_r, tau_g, rho_r_valid, drho_r_valid, rho_g_valid, drho_g_valid, tau_r_valid, tau_g_valid, tot_rho_r, tot_rho_g, rho_r_sccs, soft_valid, complex_rho_ao)
returns info about the density described by this object. If some representation is not available an e...
Definition qs_rho_types.F:229
qs_vxc_atom
routines that build the integrals of the Vxc potential calculated for the atomic density in the basis...
Definition qs_vxc_atom.F:12
qs_vxc_atom::gapw_cdft_one_center
subroutine, public gapw_cdft_one_center(qs_env, energy_only, calculate_forces, values, electronic_charge, operator_group, rho_atom_operator_set)
Add the GAPW one-center correction to CDFT values and operators.
Definition qs_vxc_atom.F:2705
qs_vxc_atom::calculate_xc_2nd_deriv_atom
subroutine, public calculate_xc_2nd_deriv_atom(rho_atom_set, rho1_atom_set, qs_env, xc_section, para_env, do_tddfpt2, do_triplet, do_sf, kind_set_external)
...
Definition qs_vxc_atom.F:4328
qs_vxc_atom::calculate_vxc_atom
subroutine, public calculate_vxc_atom(qs_env, energy_only, exc1, adiabatic_rescale_factor, kind_set_external, rho_atom_set_external, xc_section_external, calculate_forces, composite_vxc_rho, composite_vxc_tau, composite_reference_active, direct_valence_atom_grid, atom_composite_grid)
...
Definition qs_vxc_atom.F:338
qs_vxc_atom::calculate_gfxc_atom
subroutine, public calculate_gfxc_atom(qs_env, rho0_atom_set, rho1_atom_set, rho2_atom_set, kind_set, xc_section, is_triplet, accuracy)
...
Definition qs_vxc_atom.F:4684
qs_vxc_atom::evaluate_nlcc_primitive_fields
subroutine evaluate_nlcc_primitive_fields(point, center, gth_potential, sgp_potential, rho, gradient, hessian)
Evaluate an NLCC density and its first two Cartesian derivatives.
Definition qs_vxc_atom.F:176
qs_vxc_atom::calc_rho_angular
subroutine, public calc_rho_angular(grid_atom, harmonics, nspins, grad_func, ir, r_h, r_s, rho_h, rho_s, dr_h, dr_s, r_h_d, r_s_d, drho_h, drho_s)
...
Definition qs_vxc_atom.F:5519
qs_vxc_atom::calculate_vxc_atom_epr
subroutine, public calculate_vxc_atom_epr(qs_env, exc1, gradient_atom_set)
...
Definition qs_vxc_atom.F:3981
qs_vxc_atom::gavxcgb_nogc
subroutine, public gavxcgb_nogc(vxc_h, vxc_s, int_hh, int_ss, grid_atom, basis_1c, harmonics, nspins)
...
Definition qs_vxc_atom.F:5895
qs_vxc_atom::gfxc_atom_diff
subroutine, public gfxc_atom_diff(qs_env, rho0_atom_set, rho1_atom_set, rho2_atom_set, kind_set, xc_section, is_triplet, accuracy, epsrho)
...
Definition qs_vxc_atom.F:5110
skala_gpw_features
Build SKALA TorchScript feature dictionaries from CP2K GPW real-space grids.
Definition skala_gpw_features.F:11
skala_gpw_features::periodic_atom_image_partition_from_layout
subroutine, public periodic_atom_image_partition_from_layout(grid_point, image_coords, target_image, weight)
Return an image-complete periodic atom weight for a prebuilt image layout.
Definition skala_gpw_features.F:2769
skala_gpw_features::build_periodic_atom_image_layout
subroutine, public build_periodic_atom_image_layout(atom_coords, cell, target_atom, image_periodicity, image_coords, target_image)
Build the image coordinates shared by all points of one target-atom block.
Definition skala_gpw_features.F:2697
skala_gpw_features::smooth_partition_atomic_weight_scale_derivative
pure real(kind=dp) function, public smooth_partition_atomic_weight_scale_derivative(weight)
Derivative of the sparse atom-row quadrature taper with respect to partition weight.
Definition skala_gpw_features.F:3240
skala_gpw_features::smooth_atom_partition
subroutine, public smooth_atom_partition(grid_point, atom_coords, cell, weights, partition_atom_coords, distances, pair_distances)
Build Becke-like smooth atom weights for one native-grid point.
Definition skala_gpw_features.F:2432
skala_gpw_features::periodic_atom_image_partition
subroutine, public periodic_atom_image_partition(grid_point, atom_coords, cell, target_atom, weight, dweight_datom, dweight_dstrain, image_periodicity)
Return the smooth weight of one reference-cell atom in an image-complete periodic atom partition....
Definition skala_gpw_features.F:2838
skala_gpw_features::smooth_partition_atomic_weight_scale
pure real(kind=dp) function, public smooth_partition_atomic_weight_scale(weight)
Smoothly suppress a sparse atom row's internal quadrature weight at the layout cutoff.
Definition skala_gpw_features.F:3217
skala_gpw_features::skala_gpw_smooth_partition_derivatives
subroutine, public skala_gpw_smooth_partition_derivatives(grid_point, atom_coords, cell, weights, included, dweights_datom, dweights_dstrain)
Build smooth atom weights and their atom/cell deformation derivatives.
Definition skala_gpw_features.F:3044
skala_gpw_functional
Experimental CP2K-native GPW real-space-grid path for SKALA TorchScript models.
Definition skala_gpw_functional.F:11
skala_gpw_functional::skala_gapw_density_partition_soft_only
integer, parameter, public skala_gapw_density_partition_soft_only
Definition skala_gpw_functional.F:78
skala_gpw_functional::skala_gapw_atom_composite_energy
subroutine, public skala_gapw_atom_composite_energy(xc_section, group, density, grad, kin, grid_coords, grid_weights, atomic_grid_weights, atomic_grid_sizes, atomic_coords, exc, density_grad_out, grad_grad_out, kin_grad_out, grid_coord_grad_out, grid_weight_grad_out, atomic_grid_weight_grad_out, atom_coord_grad_out)
Evaluate a rank-local set of complete atom blocks and sum their SKALA energies.
Definition skala_gpw_functional.F:1156
skala_gpw_functional::build_vxc_from_feature_grads
subroutine, public build_vxc_from_feature_grads(vxc_rho, vxc_tau, rho_r, pw_pool, density_grad, grad_grad, kin_grad, xc_deriv_method_id, global_grid_layout)
Fill CP2K VXC real-space arrays from Torch feature gradients.
Definition skala_gpw_functional.F:2716
skala_gpw_functional::skala_gapw_density_partition_none
integer, parameter, public skala_gapw_density_partition_none
Definition skala_gpw_functional.F:78
skala_gpw_functional::xc_section_uses_gauxc_model
logical function, public xc_section_uses_gauxc_model(xc_section)
Return true if the GAUXC subsection requests a model evaluation.
Definition skala_gpw_functional.F:279
skala_gpw_functional::xc_section_uses_native_skala_evaluator
logical function, public xc_section_uses_native_skala_evaluator(xc_section)
Return true when SKALA must be evaluated by the CP2K-native grid machinery.
Definition skala_gpw_functional.F:164
skala_gpw_functional::skala_gapw_density_partition_hard_minus_soft
integer, parameter, public skala_gapw_density_partition_hard_minus_soft
Definition skala_gpw_functional.F:78
skala_gpw_functional::native_skala_gapw_density_partition
integer function, public native_skala_gapw_density_partition(xc_section)
Return the hard/soft GAPW one-center density partition for native SKALA.
Definition skala_gpw_functional.F:306
skala_gpw_functional::get_gauxc_section
type(section_vals_type) function, pointer, public get_gauxc_section(xc_section)
Return the first GAUXC functional subsection, if present.
Definition skala_gpw_functional.F:3026
skala_gpw_functional::skala_gapw_atom_vxc_of_r
subroutine, public skala_gapw_atom_vxc_of_r(xc_section, grid_atom, group, atom_coord, rho, drho, tau, weights, lsd, nspins, na, nr, exc, vxc, vxg, vtau, energy_only, atom_force, atom_virial)
Evaluate SKALA on a GAPW one-center atomic grid.
Definition skala_gpw_functional.F:894
skala_gpw_functional::skala_gapw_density_partition_hard_only
integer, parameter, public skala_gapw_density_partition_hard_only
Definition skala_gpw_functional.F:78
spherical_harmonics
Calculate spherical harmonics.
Definition spherical_harmonics.F:27
util
All kind of helpful little routines.
Definition util.F:14
util::get_limit
pure integer function, dimension(2), public get_limit(m, n, me)
divide m entries into n parts, return size of part me
Definition util.F:333
virial_types
Definition virial_types.F:13
xc_atom
Definition xc_atom.F:9
xc_atom::vxc_of_r_epr
subroutine, public vxc_of_r_epr(xc_fun_section, rho_set, deriv_set, needs, w, lsd, na, nr, exc, vxc, vxg, vtau)
Specific EPR version of vxc_of_r_new.
Definition xc_atom.F:297
xc_atom::vxc_of_r_new
subroutine, public vxc_of_r_new(xc_fun_section, rho_set, deriv_set, deriv_order, needs, w, lsd, na, nr, exc, vxc, vxg, vtau, energy_only, adiabatic_rescale_factor)
...
Definition xc_atom.F:64
xc_atom::xc_rho_set_atom_update
subroutine, public xc_rho_set_atom_update(rho_set, needs, nspins, bo)
...
Definition xc_atom.F:507
xc_atom::xc_2nd_deriv_of_r
subroutine, public xc_2nd_deriv_of_r(rho_set, rho1_set, xc_section, deriv_set, w, vxc, vxg, vtau, do_triplet, do_sf)
...
Definition xc_atom.F:403
xc_atom::fill_rho_set
subroutine, public fill_rho_set(rho_set, lsd, nspins, needs, rho, drho, tau, na, ir)
...
Definition xc_atom.F:667
xc_derivative_set_types
represent a group ofunctional derivatives
Definition xc_derivative_set_types.F:14
xc_derivative_set_types::xc_dset_zero_all
subroutine, public xc_dset_zero_all(deriv_set)
...
Definition xc_derivative_set_types.F:166
xc_derivative_set_types::xc_dset_release
subroutine, public xc_dset_release(derivative_set)
releases a derivative set
Definition xc_derivative_set_types.F:143
xc_derivative_set_types::xc_dset_create
subroutine, public xc_dset_create(derivative_set, pw_pool, local_bounds)
creates a derivative set object
Definition xc_derivative_set_types.F:111
xc_derivatives
Definition xc_derivatives.F:9
xc_derivatives::xc_functionals_get_needs
type(xc_rho_cflags_type) function, public xc_functionals_get_needs(functionals, lsd, calc_potential)
...
Definition xc_derivatives.F:770
xc_input_constants
input constants for xc
Definition xc_input_constants.F:10
xc_input_constants::skala_gapw_direct_valence
integer, parameter, public skala_gapw_direct_valence
Definition xc_input_constants.F:29
xc_input_constants::skala_gapw_paw_one_center
integer, parameter, public skala_gapw_paw_one_center
Definition xc_input_constants.F:29
xc_input_constants::skala_gapw_cp2k_default
integer, parameter, public skala_gapw_cp2k_default
Definition xc_input_constants.F:29
xc_input_constants::skala_gapw_paw_one_center_split
integer, parameter, public skala_gapw_paw_one_center_split
Definition xc_input_constants.F:29
xc_rho_cflags_types
contains the structure
Definition xc_rho_cflags_types.F:14
xc_rho_set_types
contains the structure
Definition xc_rho_set_types.F:14
xc_rho_set_types::xc_rho_set_create
subroutine, public xc_rho_set_create(rho_set, local_bounds, rho_cutoff, drho_cutoff, tau_cutoff)
allocates and does (minimal) initialization of a rho_set
Definition xc_rho_set_types.F:111
xc_rho_set_types::xc_rho_set_release
subroutine, public xc_rho_set_release(rho_set, pw_pool)
releases the given rho_set
Definition xc_rho_set_types.F:129
xc_rho_set_types::xc_rho_set_update
subroutine, public xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs, xc_deriv_method_id, xc_rho_smooth_id, pw_pool, spinflip)
updates the given rho set with the density given by rho_r (and rho_g). The rho set will contain the c...
Definition xc_rho_set_types.F:691
xc_rho_set_types::xc_rho_set_get
subroutine, public xc_rho_set_get(rho_set, can_return_null, rho, drho, norm_drho, rhoa, rhob, norm_drhoa, norm_drhob, rho_1_3, rhoa_1_3, rhob_1_3, laplace_rho, laplace_rhoa, laplace_rhob, drhoa, drhob, rho_cutoff, drho_cutoff, tau_cutoff, tau, tau_a, tau_b, local_bounds)
returns the various attributes of rho_set
Definition xc_rho_set_types.F:281
atomic_kind_types::atomic_kind_type
Provides all information about an atomic kind.
Definition atomic_kind_types.F:45
basis_set_types::gto_basis_set_type
Definition basis_set_types.F:72
cell_types::cell_type
Type defining parameters related to the simulation cell.
Definition cell_types.F:60
cp_array_utils::cp_3d_r_cp_type
represent a pointer to a contiguous 3d array
Definition cp_array_utils.F:149
cp_control_types::dft_control_type
Definition cp_control_types.F:758
external_potential_types::gth_potential_type
Definition external_potential_types.F:116
external_potential_types::sgp_potential_type
Definition external_potential_types.F:174
input_section_types::section_vals_type
stores the values of a section
Definition input_section_types.F:127
message_passing::mp_para_env_type
stores all the informations relevant to an mpi environment
Definition message_passing.F:759
particle_types::particle_type
Definition particle_types.F:35
pw_env_types::pw_env_type
contained for different pw related things
Definition pw_env_types.F:70
pw_grid_types::pw_grid_type
Definition pw_grid_types.F:53
pw_pool_types::pw_pool_type
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
Definition pw_pool_types.F:83
pw_types::pw_c1d_gs_type
Definition pw_types.F:127
pw_types::pw_r3d_rs_type
Definition pw_types.F:62
qs_cdft_grid::cdft_point_context_type
Definition qs_cdft_grid.F:41
qs_cdft_types::cdft_control_type
Definition qs_cdft_types.F:219
qs_environment_types::qs_environment_type
Definition qs_environment_types.F:222
qs_force_types::qs_force_type
Definition qs_force_types.F:28
qs_grid_atom::grid_atom_type
Definition qs_grid_atom.F:44
qs_harmonics_atom::harmonics_atom_type
Definition qs_harmonics_atom.F:32
qs_kind_types::qs_kind_type
Provides all information about a quickstep kind.
Definition qs_kind_types.F:190
qs_linres_types::nablavks_atom_type
Definition qs_linres_types.F:213
qs_rho_atom_types::rho_atom_coeff
Definition qs_rho_atom_types.F:19
qs_rho_atom_types::rho_atom_type
Definition qs_rho_atom_types.F:23
qs_rho_types::qs_rho_type
keeps the density in various representations, keeping track of which ones are valid.
Definition qs_rho_types.F:62
virial_types::virial_type
Definition virial_types.F:26
xc_derivative_set_types::xc_derivative_set_type
A derivative set contains the different derivatives of a xc-functional in form of a linked list.
Definition xc_derivative_set_types.F:48
xc_rho_cflags_types::xc_rho_cflags_type
contains a flag for each component of xc_rho_set, so that you can use it to tell which components you...
Definition xc_rho_cflags_types.F:48
xc_rho_set_types::xc_rho_set_type
represent a density, with all the representation and data needed to perform a functional evaluation
Definition xc_rho_set_types.F:78