(git:33f85d8)
•All Data Structures Namespaces Files Functions Variables Typedefs Enumerations Enumerator Macros
xc.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2025 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \brief Exchange and Correlation functional calculations
10!> \par History
11!> (13-Feb-2001) JGH, based on earlier version of apsi
12!> 02.2003 Many many changes [fawzi]
13!> 03.2004 new xc interface [fawzi]
14!> 04.2004 kinetic functionals [fawzi]
15!> \author fawzi
16! **************************************************************************************************
17MODULE xc
18 USE cp_array_utils, ONLY: cp_3d_r_cp_type
19 USE cp_linked_list_xc_deriv, ONLY: cp_sll_xc_deriv_next, &
20 cp_sll_xc_deriv_type
21 USE cp_log_handling, ONLY: cp_get_default_logger, &
22 cp_logger_get_default_unit_nr, &
23 cp_logger_type, &
24 cp_to_string
25 USE input_section_types, ONLY: section_get_ival, &
26 section_get_lval, &
27 section_get_rval, &
28 section_vals_get_subs_vals, &
29 section_vals_type, &
30 section_vals_val_get
31 USE kahan_sum, ONLY: accurate_dot_product, &
32 accurate_sum
33 USE kinds, ONLY: default_path_length, &
34 dp
35 USE pw_grid_types, ONLY: pw_mode_distributed, &
36 pw_grid_type
37 USE pw_methods, ONLY: pw_axpy, &
38 pw_copy, &
39 pw_derive, &
40 pw_scale, &
41 pw_transfer, &
42 pw_zero, pw_integrate_function
43 USE pw_pool_types, ONLY: &
44 pw_pool_type
45 USE pw_types, ONLY: &
46 pw_c1d_gs_type, pw_r3d_rs_type
47 USE xc_derivative_desc, ONLY: &
48 deriv_rho, deriv_rhoa, deriv_rhob, &
49 deriv_norm_drhoa, deriv_norm_drhob, deriv_norm_drho, deriv_tau_a, deriv_tau_b, deriv_tau, &
50 deriv_laplace_rho, deriv_laplace_rhoa, deriv_laplace_rhob, id_to_desc
51 USE xc_derivative_set_types, ONLY: xc_derivative_set_type, &
52 xc_dset_create, &
53 xc_dset_get_derivative, &
54 xc_dset_release, &
55 xc_dset_zero_all, xc_dset_recover_pw
56 USE xc_derivative_types, ONLY: xc_derivative_get, &
57 xc_derivative_type
58 USE xc_derivatives, ONLY: xc_functionals_eval, &
59 xc_functionals_get_needs
60 USE xc_input_constants, ONLY: &
61 xc_debug_new_routine, xc_default_f_routine, xc_test_lsd_f_routine
62 USE xc_rho_cflags_types, ONLY: xc_rho_cflags_type
63 USE xc_rho_set_types, ONLY: xc_rho_set_create, &
64 xc_rho_set_get, &
65 xc_rho_set_release, &
66 xc_rho_set_type, &
67 xc_rho_set_update, xc_rho_set_recover_pw
68 USE xc_util, ONLY: xc_pw_smooth, xc_pw_laplace, xc_pw_divergence, xc_requires_tmp_g
69#include "../base/base_uses.f90"
70
71 IMPLICIT NONE
72 PRIVATE
73 PUBLIC :: xc_vxc_pw_create1, xc_vxc_pw_create, &
74 xc_exc_calc, xc_calc_2nd_deriv_analytical, xc_calc_2nd_deriv_numerical, &
75 xc_calc_2nd_deriv, xc_prep_2nd_deriv, divide_by_norm_drho, smooth_cutoff, &
76 xc_uses_kinetic_energy_density, xc_uses_norm_drho
77 PUBLIC :: calc_xc_density
78
79 LOGICAL, PRIVATE, PARAMETER :: debug_this_module = .true.
80 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'xc'
81
82CONTAINS
83
84! **************************************************************************************************
85!> \brief ...
86!> \param xc_fun_section ...
87!> \param lsd ...
88!> \return ...
89! **************************************************************************************************
90 FUNCTION xc_uses_kinetic_energy_density(xc_fun_section, lsd) RESULT(res)
91 TYPE(section_vals_type), POINTER, INTENT(IN) :: xc_fun_section
92 LOGICAL, INTENT(IN) :: lsd
93 LOGICAL :: res
94
95 TYPE(xc_rho_cflags_type) :: needs
96
97 needs = xc_functionals_get_needs(xc_fun_section, &
98 lsd=lsd, &
99 calc_potential=.false.)
100 res = (needs%tau_spin .OR. needs%tau)
101
102 END FUNCTION
103
104! **************************************************************************************************
105!> \brief ...
106!> \param xc_fun_section ...
107!> \param lsd ...
108!> \return ...
109! **************************************************************************************************
110 FUNCTION xc_uses_norm_drho(xc_fun_section, lsd) RESULT(res)
111 TYPE(section_vals_type), POINTER, INTENT(IN) :: xc_fun_section
112 LOGICAL, INTENT(IN) :: lsd
113 LOGICAL :: res
114
115 TYPE(xc_rho_cflags_type) :: needs
116
117 needs = xc_functionals_get_needs(xc_fun_section, &
118 lsd=lsd, &
119 calc_potential=.false.)
120 res = (needs%norm_drho .OR. needs%norm_drho_spin)
121
122 END FUNCTION
123
124! **************************************************************************************************
125!> \brief Exchange and Correlation functional calculations.
126!> depending on the selected functional_routine calls
127!> the correct routine
128!> \param vxc_rho will contain the v_xc part that depend on rho
129!> (if one of the chosen xc functionals has it it is allocated and you
130!> are responsible for it)
131!> \param vxc_tau will contain the kinetic tau part of v_xcthe functional
132!> (if one of the chosen xc functionals has it it is allocated and you
133!> are responsible for it)
134!> \param rho_r the value of the density in the real space
135!> \param rho_g value of the density in the g space (needs to be associated
136!> only for gradient corrections)
137!> \param tau value of the kinetic density tau on the grid (can be null,
138!> used only with meta functionals)
139!> \param exc the xc energy
140!> \param xc_section parameters selecting the xc and the method used to
141!> calculate it
142!> \param pw_pool the pool for the grids
143!> \param compute_virial should the virial be computed... if so virial_xc must be present
144!> \param virial_xc for calculating the GGA part of the stress
145!> \param exc_r ...
146!> \author fawzi
147! **************************************************************************************************
148 SUBROUTINE xc_vxc_pw_create1(vxc_rho, vxc_tau, rho_r, rho_g, tau, exc, xc_section, &
149 pw_pool, compute_virial, virial_xc, exc_r)
150 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau
151 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau
152 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
153 REAL(kind=dp), INTENT(out) :: exc
154 TYPE(section_vals_type), POINTER :: xc_section
155 TYPE(pw_pool_type), POINTER :: pw_pool
156 LOGICAL, INTENT(IN) :: compute_virial
157 REAL(kind=dp), DIMENSION(3, 3), INTENT(OUT) :: virial_xc
158 TYPE(pw_r3d_rs_type), INTENT(INOUT), OPTIONAL :: exc_r
159
160 INTEGER :: f_routine
161
162 cpassert(ASSOCIATED(rho_r))
163 cpassert(ASSOCIATED(xc_section))
164 cpassert(.NOT. ASSOCIATED(vxc_rho))
165 cpassert(.NOT. ASSOCIATED(vxc_tau))
166
167 virial_xc = 0.0_dp
168
169 CALL section_vals_val_get(xc_section, "FUNCTIONAL_ROUTINE", &
170 i_val=f_routine)
171 SELECT CASE (f_routine)
172 CASE (xc_default_f_routine)
173 CALL xc_vxc_pw_create(vxc_rho=vxc_rho, vxc_tau=vxc_tau, tau=tau, exc_r=exc_r, &
174 rho_r=rho_r, rho_g=rho_g, exc=exc, xc_section=xc_section, &
175 pw_pool=pw_pool, compute_virial=compute_virial, virial_xc=virial_xc)
176 CASE (xc_debug_new_routine)
177 cpassert(.NOT. PRESENT(exc_r))
178 CALL xc_vxc_pw_create_debug(vxc_rho=vxc_rho, vxc_tau=vxc_tau, tau=tau, &
179 rho_r=rho_r, rho_g=rho_g, exc=exc, xc_section=xc_section, &
180 pw_pool=pw_pool)
181 CASE (xc_test_lsd_f_routine)
182 cpassert(.NOT. PRESENT(exc_r))
183 CALL xc_vxc_pw_create_test_lsd(vxc_rho=vxc_rho, vxc_tau=vxc_tau, &
184 tau=tau, rho_r=rho_r, rho_g=rho_g, exc=exc, &
185 xc_section=xc_section, pw_pool=pw_pool)
186 CASE default
187 END SELECT
188
189 END SUBROUTINE xc_vxc_pw_create1
190
191! **************************************************************************************************
192!> \brief calculates vxc using lsd with rhoa=rhob=0.5*rho and compares
193!> with the lda result
194!> \param vxc_rho will contain the v_xc part that depend on rho
195!> (if one of the chosen xc functionals has it it is allocated and you
196!> are responsible for it)
197!> \param vxc_tau will contain the kinetic tau part of v_xc
198!> (if one of the chosen xc functionals has it it is allocated and you
199!> are responsible for it)
200!> \param rho_r the value of the density in the real space
201!> \param rho_g value of the density in the g space (needs to be associated
202!> only for gradient corrections)
203!> \param tau value of the kinetic density tau on the grid (can be null,
204!> used only with meta functionals)
205!> \param exc the xc energy
206!> \param xc_section which functional to calculate, and how
207!> \param pw_pool the pool for the grids
208!> \author Fawzi Mohamed
209!> \note
210!> for debugging only: leaks, and non parallel
211! **************************************************************************************************
212 SUBROUTINE xc_vxc_pw_create_test_lsd(vxc_rho, vxc_tau, rho_r, rho_g, tau, &
213 exc, xc_section, pw_pool)
214 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau
215 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau
216 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
217 REAL(kind=dp), INTENT(out) :: exc
218 TYPE(section_vals_type), POINTER :: xc_section
219 TYPE(pw_pool_type), POINTER :: pw_pool
220
221 LOGICAL, PARAMETER :: compute_virial = .false.
222
223 CHARACTER(len=default_path_length) :: filename
224 INTEGER, DIMENSION(:), POINTER :: split_desc
225 INTEGER :: i, ii, ispin, j, k, order
226 INTEGER, DIMENSION(2, 3) :: bo
227 REAL(kind=dp) :: diff, exc2, maxdiff, tmp
228 REAL(kind=dp), DIMENSION(3, 3) :: virial_xc
229 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: pot, pot2, pot3
230 TYPE(cp_sll_xc_deriv_type), POINTER :: deriv_iter
231 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: vxc_rho2, vxc_tau2
232 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho2_g
233 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho2_r, tau2
234 TYPE(xc_derivative_set_type) :: dset1, dset2
235 TYPE(xc_derivative_type), POINTER :: deriv, deriv2, deriv3
236 TYPE(xc_rho_set_type) :: rho_set1, rho_set2
237
238 NULLIFY (vxc_rho2, vxc_tau2, tau2, pot, pot3, pot3, &
239 deriv, deriv2, deriv3, rho2_g)
240
241 bo = rho_r(1)%pw_grid%bounds_local
242
243 ALLOCATE (rho2_r(2))
244 DO ispin = 1, 2
245 CALL pw_pool%create_pw(rho2_r(ispin))
246 END DO
247 DO k = bo(1, 3), bo(2, 3)
248 DO j = bo(1, 2), bo(2, 2)
249 DO i = bo(1, 1), bo(2, 1)
250 tmp = rho_r(1)%array(i, j, k)*0.5
251 rho2_r(1)%array(i, j, k) = tmp
252 rho2_r(2)%array(i, j, k) = tmp
253 END DO
254 END DO
255 END DO
256
257 IF (ASSOCIATED(tau)) THEN
258 ALLOCATE (tau2(2))
259 DO ispin = 1, 2
260 CALL pw_pool%create_pw(tau2(ispin))
261 END DO
262
263 DO k = bo(1, 3), bo(2, 3)
264 DO j = bo(1, 2), bo(2, 2)
265 DO i = bo(1, 1), bo(2, 1)
266 tmp = tau(1)%array(i, j, k)*0.5
267 tau2(1)%array(i, j, k) = tmp
268 tau2(2)%array(i, j, k) = tmp
269 END DO
270 END DO
271 END DO
272 END IF
273
274 print *, "about to calculate xc (lda)"
275 CALL xc_rho_set_and_dset_create(rho_r=rho_r, rho_g=rho_g, &
276 tau=tau, xc_section=xc_section, &
277 pw_pool=pw_pool, rho_set=rho_set1, &
278 deriv_set=dset1, deriv_order=1, &
279 calc_potential=.false.)
280 CALL xc_vxc_pw_create(rho_r=rho_r, rho_g=rho_g, tau=tau, &
281 vxc_rho=vxc_rho, vxc_tau=vxc_tau, exc=exc, xc_section=xc_section, &
282 pw_pool=pw_pool, &
283 compute_virial=compute_virial, virial_xc=virial_xc)
284 print *, "did calculate xc (lda)"
285 print *, "about to calculate xc (lsd)"
286 CALL xc_rho_set_and_dset_create(rho_set=rho_set2, deriv_set=dset2, &
287 rho_r=rho2_r, rho_g=rho2_g, tau=tau2, xc_section=xc_section, &
288 pw_pool=pw_pool, deriv_order=1, &
289 calc_potential=.false.)
290 CALL xc_vxc_pw_create(rho_r=rho2_r, rho_g=rho2_g, tau=tau2, &
291 vxc_rho=vxc_rho2, vxc_tau=vxc_tau2, exc=exc2, xc_section=xc_section, &
292 pw_pool=pw_pool, compute_virial=compute_virial, virial_xc=virial_xc)
293 print *, "did calculate xc (new)"
294 print *, "at (0,0,0) rho_r=", rho_r(1)%array(0, 0, 0), &
295 "rho2_r(1)=", rho2_r(1)%array(0, 0, 0), &
296 "rho2_r(2)=", rho2_r(2)%array(0, 0, 0), &
297 "rho_r_sm=", rho_set1%rho(0, 0, 0), "rhoa2_r_sm=", rho_set2%rhoa(0, 0, 0), &
298 "rhob2_r_sm=", rho_set2%rhob(0, 0, 0)
299 OPEN (unit=120, file="rho.bindata", status="unknown", access='sequential', &
300 form="unformatted", action="write")
301 pot => rho_set1%rho
302 WRITE (unit=120) pot(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), bo(2, 3))
303 CLOSE (unit=120)
304 OPEN (unit=120, file="rhoa.bindata", status="unknown", access='sequential', &
305 form="unformatted", action="write")
306 pot => rho_set2%rhoa
307 WRITE (unit=120) pot(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), bo(2, 3))
308 CLOSE (unit=120)
309 OPEN (unit=120, file="rhob.bindata", status="unknown", access='sequential', &
310 form="unformatted", action="write")
311 pot => rho_set2%rhob
312 WRITE (unit=120) pot(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), bo(2, 3))
313 CLOSE (unit=120)
314 OPEN (unit=120, file="ndrho.bindata", status="unknown", access='sequential', &
315 form="unformatted", action="write")
316 pot => rho_set1%norm_drho
317 WRITE (unit=120) pot(:, :, bo(2, 3))
318 CLOSE (unit=120)
319 OPEN (unit=120, file="ndrhoa.bindata", status="unknown", access='sequential', &
320 form="unformatted", action="write")
321 pot => rho_set2%norm_drhoa
322 WRITE (unit=120) pot(:, :, bo(2, 3))
323 CLOSE (unit=120)
324 OPEN (unit=120, file="ndrhob.bindata", status="unknown", access='sequential', &
325 form="unformatted", action="write")
326 pot => rho_set2%norm_drhob
327 WRITE (unit=120) pot(:, :, bo(2, 3))
328 CLOSE (unit=120)
329 IF (rho_set1%has%tau) THEN
330 OPEN (unit=120, file="tau.bindata", status="unknown", access='sequential', &
331 form="unformatted", action="write")
332 pot => rho_set1%tau
333 WRITE (unit=120) pot(:, :, bo(2, 3))
334 CLOSE (unit=120)
335 END IF
336 IF (rho_set2%has%tau_spin) THEN
337 OPEN (unit=120, file="tau_a.bindata", status="unknown", access='sequential', &
338 form="unformatted", action="write")
339 pot => rho_set2%tau_a
340 WRITE (unit=120) pot(:, :, bo(2, 3))
341 CLOSE (unit=120)
342 OPEN (unit=120, file="tau_v.bindata", status="unknown", access='sequential', &
343 form="unformatted", action="write")
344 pot => rho_set2%tau_b
345 WRITE (unit=120) pot(:, :, bo(2, 3))
346 CLOSE (unit=120)
347 END IF
348 OPEN (unit=120, file="vxc.bindata", status="unknown", access='sequential', &
349 form="unformatted", action="write")
350 pot => vxc_rho(1)%array
351 WRITE (unit=120) pot(:, :, bo(2, 3))
352 CLOSE (unit=120)
353 OPEN (unit=120, file="vxc2.bindata", status="unknown", access='sequential', &
354 form="unformatted", action="write")
355 pot => vxc_rho2(1)%array
356 WRITE (unit=120) pot(:, :, bo(2, 3))
357 CLOSE (unit=120)
358 IF (ASSOCIATED(vxc_tau)) THEN
359 OPEN (unit=120, file="vxc_tau.bindata", status="unknown", access='sequential', &
360 form="unformatted", action="write")
361 pot => vxc_tau(1)%array
362 WRITE (unit=120) pot(:, :, bo(2, 3))
363 CLOSE (unit=120)
364 END IF
365 IF (ASSOCIATED(vxc_tau2)) THEN
366 OPEN (unit=120, file="vxc_tau2_a.bindata", status="unknown", access='sequential', &
367 form="unformatted", action="write")
368 pot => vxc_tau2(1)%array
369 WRITE (unit=120) pot(:, :, bo(2, 3))
370 CLOSE (unit=120)
371 OPEN (unit=120, file="vxc_tau2_b.bindata", status="unknown", access='sequential', &
372 form="unformatted", action="write")
373 pot => vxc_tau2(2)%array
374 WRITE (unit=120) pot(:, :, bo(2, 3))
375 CLOSE (unit=120)
376 END IF
377
378 print *, "calc diff on vxc"
379 maxdiff = 0.0_dp
380 DO ispin = 1, 1
381 ii = 0
382 DO k = bo(1, 3), bo(2, 3)
383 DO j = bo(1, 2), bo(2, 2)
384 DO i = bo(1, 1), bo(2, 1)
385 ii = ii + 1
386 diff = abs(vxc_rho(ispin)%array(i, j, k) - &
387 vxc_rho2(ispin)%array(i, j, k))
388 IF (ii == 1) THEN
389 print *, "vxc", ispin, "=", vxc_rho(ispin)%array(i, j, k), &
390 "vs", vxc_rho2(ispin)%array(i, j, k), "diff=", diff
391 END IF
392 IF (maxdiff < diff) THEN
393 maxdiff = diff
394 print *, "diff=", diff, " at ", i, ",", j, ",", k, &
395 " spin=", ispin, "rho=", rho_set1%rho(i, j, k), &
396 " ndrho=", rho_set1%norm_drho(i, j, k)
397 END IF
398 END DO
399 END DO
400 END DO
401 END DO
402 print *, "diff exc=", abs(exc - exc2), "diff vxc=", maxdiff
403 ! CPASSERT(maxdiff<5.e-11)
404 ! CPASSERT(ABS(exc-exc2)<1.e-14)
405
406 IF (ASSOCIATED(vxc_tau)) THEN
407 print *, "calc diff on vxc_tau"
408 maxdiff = 0.0_dp
409 DO ispin = 1, 1
410 ii = 0
411 DO k = bo(1, 3), bo(2, 3)
412 DO j = bo(1, 2), bo(2, 2)
413 DO i = bo(1, 1), bo(2, 1)
414 ii = ii + 1
415 diff = abs(vxc_tau(ispin)%array(i, j, k) - &
416 vxc_tau2(ispin)%array(i, j, k))
417 IF (ii == 1) THEN
418 print *, "vxc_tau", ispin, "=", vxc_tau(ispin)%array(i, j, k), &
419 "vs", vxc_tau2(ispin)%array(i, j, k), "diff=", diff
420 END IF
421 IF (maxdiff < diff) THEN
422 maxdiff = diff
423 print *, "diff=", diff, " at ", i, ",", j, ",", k, &
424 " spin=", ispin, "rho=", rho_set1%rho(i, j, k), &
425 " ndrho=", rho_set1%norm_drho(i, j, k)
426 END IF
427 END DO
428 END DO
429 END DO
430 END DO
431 print *, "diff exc=", abs(exc - exc2), "diff vxc_tau=", maxdiff
432 END IF
433 deriv_iter => dset1%derivs
434 DO WHILE (cp_sll_xc_deriv_next(deriv_iter, el_att=deriv))
435 CALL xc_derivative_get(deriv, order=order, &
436 split_desc=split_desc, deriv_data=pot)
437 SELECT CASE (order)
438 CASE (0)
439 filename = "e_0.bindata"
440 deriv2 => xc_dset_get_derivative(dset2, [INTEGER::])
441 CASE (1)
442 filename = "e_"//trim(id_to_desc(split_desc(1)))//".bindata"
443 IF (split_desc(1) == deriv_rho) THEN
444 deriv2 => xc_dset_get_derivative(dset2, [deriv_rhoa])
445 ELSEIF (split_desc(1) == deriv_tau) THEN
446 deriv2 => xc_dset_get_derivative(dset2, [deriv_tau_a])
447 ELSEIF (split_desc(1) == deriv_norm_drho) THEN
448 deriv2 => xc_dset_get_derivative(dset2, [deriv_norm_drhoa])
449 deriv3 => xc_dset_get_derivative(dset2, [deriv_norm_drho])
450 IF (ASSOCIATED(deriv3)) THEN
451 IF (ASSOCIATED(deriv2)) THEN
452 CALL xc_derivative_get(deriv2, &
453 deriv_data=pot2)
454 CALL xc_derivative_get(deriv3, &
455 deriv_data=pot3)
456 pot2 = pot2 + pot3
457 ELSE
458 deriv2 => deriv3
459 END IF
460 NULLIFY (deriv3, pot2, pot3)
461 END IF
462 ELSE
463 cpabort("Unknown derivative variable")
464 END IF
465 CASE default
466 cpabort("Unsupported derivative order")
467 END SELECT
468 CALL xc_derivative_get(deriv2, &
469 deriv_data=pot2)
470 print *, "checking ", filename
471 maxdiff = 0.0_dp
472 DO k = bo(1, 3), bo(2, 3)
473 DO j = bo(1, 2), bo(2, 2)
474 DO i = bo(1, 1), bo(2, 1)
475 diff = abs(pot(i, j, k) - pot2(i, j, k))
476 IF (maxdiff < diff) THEN
477 maxdiff = diff
478 print *, "ediff(", i, j, k, ")=", maxdiff, &
479 "rho=", rho_set1%rho(i, j, k), &
480 "ndrho=", rho_set1%norm_drho(i, j, k)
481 END IF
482 END DO
483 END DO
484 END DO
485 print *, "maxdiff ", filename, "=", maxdiff
486 OPEN (unit=120, file=trim(filename), status="unknown", &
487 access='sequential', &
488 form="unformatted")
489 WRITE (unit=120) pot(:, :, bo(2, 3))
490 CLOSE (unit=120)
491 END DO
492 deriv_iter => dset2%derivs
493 DO WHILE (cp_sll_xc_deriv_next(deriv_iter, el_att=deriv))
494 CALL xc_derivative_get(deriv, order=order, &
495 split_desc=split_desc, deriv_data=pot)
496 SELECT CASE (order)
497 CASE (0)
498 filename = "e_0-2.bindata"
499 CASE (1)
500 filename = "e_"//trim(id_to_desc(split_desc(1)))//"-2.bindata"
501 CASE default
502 cpabort("Unsupported derivative order")
503 END SELECT
504 OPEN (unit=120, file=trim(filename), status="unknown", &
505 access='sequential', &
506 form="unformatted")
507 WRITE (unit=120) pot(:, :, bo(2, 3))
508 CLOSE (unit=120)
509 END DO
510 CALL xc_rho_set_release(rho_set1)
511 CALL xc_rho_set_release(rho_set2)
512 CALL xc_dset_release(dset2)
513 CALL xc_dset_release(dset1)
514 DO ispin = 1, 2
515 CALL pw_pool%give_back_pw(rho2_r(ispin))
516 CALL pw_pool%give_back_pw(vxc_rho2(ispin))
517 IF (ASSOCIATED(vxc_tau2)) THEN
518 CALL pw_pool%give_back_pw(vxc_tau2(ispin))
519 END IF
520 END DO
521 DEALLOCATE (vxc_rho2, rho2_r, rho2_g)
522 IF (ASSOCIATED(vxc_tau2)) THEN
523 DEALLOCATE (vxc_tau2)
524 END IF
525
526 END SUBROUTINE xc_vxc_pw_create_test_lsd
527
528! **************************************************************************************************
529!> \brief calculates vxc outputting the yz plane of rho, and of the various components
530!> of the the derivatives and of vxc
531!> \param vxc_rho will contain the v_xc part that depend on rho
532!> (if one of the chosen xc functionals has it it is allocated and you
533!> are responsible for it)
534!> \param vxc_tau will contain the kinetic tau part of v_xc
535!> (if one of the chosen xc functionals has it it is allocated and you
536!> are responsible for it)
537!> \param rho_r the value of the density in the real space
538!> \param rho_g value of the density in the g space (needs to be associated
539!> only for gradient corrections)
540!> \param tau value of the kinetic density tau on the grid (can be null,
541!> used only with meta functionals)
542!> \param exc the xc energy
543!> \param xc_section which functional should be used, and how to do it
544!> \param pw_pool the pool for the grids
545!> \author Fawzi Mohamed
546!> \note
547!> for debugging only.
548! **************************************************************************************************
549 SUBROUTINE xc_vxc_pw_create_debug(vxc_rho, vxc_tau, rho_r, rho_g, tau, exc, &
550 xc_section, pw_pool)
551 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau
552 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau
553 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
554 REAL(kind=dp), INTENT(out) :: exc
555 TYPE(section_vals_type), POINTER :: xc_section
556 TYPE(pw_pool_type), POINTER :: pw_pool
557
558 LOGICAL, PARAMETER :: compute_virial = .false.
559
560 CHARACTER(len=default_path_length) :: filename
561 INTEGER, DIMENSION(:), POINTER :: split_desc
562 INTEGER :: i, ispin, j, k, order
563 INTEGER, DIMENSION(2, 3) :: bo
564 REAL(kind=dp), DIMENSION(3, 3) :: virial_xc
565 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: pot
566 TYPE(cp_logger_type), POINTER :: logger
567 TYPE(cp_sll_xc_deriv_type), POINTER :: deriv_iter
568 TYPE(xc_derivative_set_type) :: dset1
569 TYPE(xc_derivative_type), POINTER :: deriv
570 TYPE(xc_rho_set_type) :: rho_set1
571
572 NULLIFY (pot, deriv)
573 logger => cp_get_default_logger()
574
575 bo = rho_r(1)%pw_grid%bounds_local
576
577 CALL xc_rho_set_and_dset_create(rho_r=rho_r, rho_g=rho_g, &
578 tau=tau, xc_section=xc_section, &
579 pw_pool=pw_pool, rho_set=rho_set1, &
580 deriv_set=dset1, deriv_order=1, &
581 calc_potential=.false.)
582
583 ! outputs 0,:,: plane
584 IF (bo(1, 1) <= 0 .AND. 0 <= bo(2, 1)) THEN
585 IF (rho_set1%has%rho_spin) THEN
586 OPEN (unit=120, file="rhoa.bindata", status="unknown", access='sequential', &
587 form="unformatted", action="write")
588 pot => rho_set1%rhoa
589 WRITE (unit=120) pot(0, :, :)
590 CLOSE (unit=120)
591 OPEN (unit=120, file="rhob.bindata", status="unknown", access='sequential', &
592 form="unformatted", action="write")
593 pot => rho_set1%rhob
594 WRITE (unit=120) pot(0, :, :)
595 CLOSE (unit=120)
596 END IF
597 IF (rho_set1%has%norm_drho) THEN
598 OPEN (unit=120, file="ndrho.bindata", status="unknown", access='sequential', &
599 form="unformatted", action="write")
600 pot => rho_set1%norm_drho
601 WRITE (unit=120) pot(0, :, :)
602 CLOSE (unit=120)
603 END IF
604 IF (rho_set1%has%norm_drho_spin) THEN
605 OPEN (unit=120, file="ndrhoa.bindata", status="unknown", access='sequential', &
606 form="unformatted", action="write")
607 pot => rho_set1%norm_drhoa
608 WRITE (unit=120) pot(0, :, :)
609 CLOSE (unit=120)
610 OPEN (unit=120, file="ndrhob.bindata", status="unknown", access='sequential', &
611 form="unformatted", action="write")
612 pot => rho_set1%norm_drhob
613 WRITE (unit=120) pot(0, :, :)
614 CLOSE (unit=120)
615 END IF
616 IF (rho_set1%has%rho) THEN
617 OPEN (unit=120, file="rho.bindata", status="unknown", access='sequential', &
618 form="unformatted", action="write")
619 pot => rho_set1%rho
620 WRITE (unit=120) pot(0, :, :)
621 CLOSE (unit=120)
622 END IF
623 IF (rho_set1%has%tau) THEN
624 OPEN (unit=120, file="tau.bindata", status="unknown", access='sequential', &
625 form="unformatted", action="write")
626 pot => rho_set1%tau
627 WRITE (unit=120) pot(0, :, :)
628 CLOSE (unit=120)
629 END IF
630 IF (rho_set1%has%tau_spin) THEN
631 OPEN (unit=120, file="tau_a.bindata", status="unknown", access='sequential', &
632 form="unformatted", action="write")
633 pot => rho_set1%tau_a
634 WRITE (unit=120) pot(0, :, :)
635 CLOSE (unit=120)
636 OPEN (unit=120, file="tau_b.bindata", status="unknown", access='sequential', &
637 form="unformatted", action="write")
638 pot => rho_set1%tau_b
639 WRITE (unit=120) pot(0, :, :)
640 CLOSE (unit=120)
641 END IF
642
643 deriv_iter => dset1%derivs
644 DO WHILE (cp_sll_xc_deriv_next(deriv_iter, el_att=deriv))
645 CALL xc_derivative_get(deriv, order=order, &
646 split_desc=split_desc, deriv_data=pot)
647 SELECT CASE (order)
648 CASE (0)
649 filename = "e_0.bindata"
650 CASE (1)
651 filename = "e_"//trim(id_to_desc(split_desc(1)))//".bindata"
652 CASE default
653 cpabort("Unsupported derivative order")
654 END SELECT
655 OPEN (unit=120, file=trim(filename), status="unknown", &
656 access='sequential', &
657 form="unformatted")
658 WRITE (unit=120) pot(0, :, :)
659 CLOSE (unit=120)
660 END DO
661 END IF
662
663 CALL xc_vxc_pw_create(vxc_rho=vxc_rho, vxc_tau=vxc_tau, &
664 rho_r=rho_r, rho_g=rho_g, tau=tau, &
665 exc=exc, xc_section=xc_section, &
666 pw_pool=pw_pool, &
667 compute_virial=compute_virial, virial_xc=virial_xc)
668
669 ! outputs 0,:,: plane
670 IF (bo(1, 1) <= 0 .AND. 0 <= bo(2, 1)) THEN
671 IF (ASSOCIATED(vxc_rho)) THEN
672 DO ispin = 1, SIZE(vxc_rho)
673 WRITE (filename, "('vxc-',i1,'.bindata')") ispin
674 OPEN (unit=120, file=filename, status="unknown", access='sequential', &
675 form="unformatted", action="write")
676 pot => vxc_rho(ispin)%array
677 WRITE (unit=120) pot(0, :, :)
678 CLOSE (unit=120)
679
680 pot => vxc_rho(ispin)%array
681 DO k = bo(1, 3), bo(2, 3)
682 DO j = bo(1, 2), bo(2, 2)
683 DO i = bo(1, 1), bo(2, 1)
684 IF (abs(pot(i, j, k)) > 10.0_dp) THEN
685 WRITE (cp_logger_get_default_unit_nr(logger), &
686 "(' vxc_',i1,'(',i6,',',i6,',',i6,')=',e11.4)", &
687 advance="no") ispin, i, j, k, pot(i, j, k)
688 IF (rho_set1%has%rho_spin) THEN
689 WRITE (cp_logger_get_default_unit_nr(logger), &
690 "(' rho=(',e11.4,',',e11.4,')')", advance="no") &
691 rho_set1%rhoa(i, j, k), rho_set1%rhob(i, j, k)
692 ELSE IF (rho_set1%has%rho) THEN
693 WRITE (cp_logger_get_default_unit_nr(logger), &
694 "(' rho=',e11.4)", advance="no") rho_set1%rho(i, j, k)
695 END IF
696 IF (rho_set1%has%norm_drho_spin) THEN
697 WRITE (cp_logger_get_default_unit_nr(logger), &
698 "(' ndrho=(',e11.4,',',e11.4,')')", advance="no") &
699 rho_set1%norm_drhoa(i, j, k), &
700 rho_set1%norm_drhob(i, j, k)
701 ELSE IF (rho_set1%has%norm_drho) THEN
702 WRITE (cp_logger_get_default_unit_nr(logger), &
703 "(' ndrho=',e11.4)", advance="no") rho_set1%norm_drho(i, j, k)
704 END IF
705 IF (rho_set1%has%tau_spin) THEN
706 WRITE (cp_logger_get_default_unit_nr(logger), &
707 "(' tau=(',e11.4,',',e11.4,')')", advance="no") &
708 rho_set1%tau_a(i, j, k), &
709 rho_set1%tau_b(i, j, k)
710 ELSE IF (rho_set1%has%tau) THEN
711 WRITE (cp_logger_get_default_unit_nr(logger), &
712 "(' tau=',e11.4)", advance="no") rho_set1%tau(i, j, k)
713 END IF
714
715 deriv_iter => dset1%derivs
716 DO WHILE (cp_sll_xc_deriv_next(deriv_iter, el_att=deriv))
717 CALL xc_derivative_get(deriv, order=order, &
718 split_desc=split_desc, deriv_data=pot)
719 SELECT CASE (order)
720 CASE (0)
721 filename = " e_0"
722 CASE (1)
723 filename = " e_"//trim(id_to_desc(split_desc(1)))
724 CASE default
725 cpabort("Unsupported derivative order")
726 END SELECT
727 WRITE (unit=cp_logger_get_default_unit_nr(logger), &
728 fmt="(a,'=',e11.4)", advance="no") &
729 trim(filename), pot(i, j, k)
730 END DO
731
732 WRITE (cp_logger_get_default_unit_nr(logger), &
733 "()")
734 END IF
735 END DO
736 END DO
737 END DO
738 END DO
739 END IF
740 IF (ASSOCIATED(vxc_tau)) THEN
741 DO ispin = 1, SIZE(vxc_tau)
742 WRITE (filename, "('vxc_tau_',i1,'.bindata')") ispin
743 OPEN (unit=120, file=filename, status="unknown", access='sequential', &
744 form="unformatted", action="write")
745 pot => vxc_tau(ispin)%array
746 WRITE (unit=120) pot(0, :, :)
747 CLOSE (unit=120)
748
749 pot => vxc_tau(ispin)%array
750 DO k = bo(1, 3), bo(2, 3)
751 DO j = bo(1, 2), bo(2, 2)
752 DO i = bo(1, 1), bo(2, 1)
753 IF (abs(pot(i, j, k)) > 10.0_dp) THEN
754 WRITE (cp_logger_get_default_unit_nr(logger), &
755 "('vxc_tau_',i1,'(',i6,',',i6,',',i6,')=',e11.4)", &
756 advance="no") ispin, i, j, k, pot(i, j, k)
757 IF (rho_set1%has%rho_spin) THEN
758 WRITE (cp_logger_get_default_unit_nr(logger), &
759 "(' rho=(',e11.4,',',e11.4,')')", advance="no") &
760 rho_set1%rhoa(i, j, k), rho_set1%rhob(i, j, k)
761 ELSE IF (rho_set1%has%rho) THEN
762 WRITE (cp_logger_get_default_unit_nr(logger), &
763 "(' rho=',e11.4)", advance="no") rho_set1%rho(i, j, k)
764 END IF
765 IF (rho_set1%has%norm_drho_spin) THEN
766 WRITE (cp_logger_get_default_unit_nr(logger), &
767 "(' ndrho=(',e11.4,',',e11.4,')')", advance="no") &
768 rho_set1%norm_drhoa(i, j, k), &
769 rho_set1%norm_drhob(i, j, k)
770 ELSE IF (rho_set1%has%norm_drho) THEN
771 WRITE (cp_logger_get_default_unit_nr(logger), &
772 "(' ndrho=',e11.4)", advance="no") rho_set1%norm_drho(i, j, k)
773 END IF
774 IF (rho_set1%has%tau_spin) THEN
775 WRITE (cp_logger_get_default_unit_nr(logger), &
776 "(' tau=(',e11.4,',',e11.4,')')", advance="no") &
777 rho_set1%tau_a(i, j, k), &
778 rho_set1%tau_b(i, j, k)
779 ELSE IF (rho_set1%has%tau) THEN
780 WRITE (cp_logger_get_default_unit_nr(logger), &
781 "(' tau=',e11.4)", advance="no") rho_set1%tau(i, j, k)
782 END IF
783
784 deriv_iter => dset1%derivs
785 DO WHILE (cp_sll_xc_deriv_next(deriv_iter, el_att=deriv))
786 CALL xc_derivative_get(deriv, order=order, &
787 split_desc=split_desc, deriv_data=pot)
788 SELECT CASE (order)
789 CASE (0)
790 filename = " e_0"
791 CASE (1)
792 filename = " e_"//trim(id_to_desc(split_desc(1)))
793 CASE default
794 cpabort("Unsupported derivative order")
795 END SELECT
796 WRITE (unit=cp_logger_get_default_unit_nr(logger), &
797 fmt="(a,'=',e11.4)", advance="no") &
798 trim(filename), pot(i, j, k)
799 END DO
800
801 WRITE (cp_logger_get_default_unit_nr(logger), "()")
802 END IF
803 END DO
804 END DO
805 END DO
806 END DO
807 END IF
808 END IF
809
810 CALL xc_dset_release(dset1)
811 CALL xc_rho_set_release(rho_set1)
812 END SUBROUTINE xc_vxc_pw_create_debug
813
814! **************************************************************************************************
815!> \brief creates a xc_rho_set and a derivative set containing the derivatives
816!> of the functionals with the given deriv_order.
817!> \param rho_set will contain the rho set
818!> \param deriv_set will contain the derivatives
819!> \param deriv_order the order of the requested derivatives. If positive
820!> 0:deriv_order are calculated, if negative only -deriv_order is
821!> guaranteed to be valid. Orders not requested might be present,
822!> but might contain garbage.
823!> \param rho_r the value of the density in the real space
824!> \param rho_g value of the density in the g space (can be null, used only
825!> without smoothing of rho or deriv)
826!> \param tau value of the kinetic density tau on the grid (can be null,
827!> used only with meta functionals)
828!> \param xc_section the section describing the functional to use
829!> \param pw_pool the pool for the grids
830!> \param calc_potential if the basic components of the arguments
831!> should be kept in rho set (a basic component is for example drho
832!> when with lda a functional needs norm_drho)
833!> \author fawzi
834!> \note
835!> if any of the functionals is gradient corrected the full gradient is
836!> added to the rho set
837! **************************************************************************************************
838 SUBROUTINE xc_rho_set_and_dset_create(rho_set, deriv_set, deriv_order, &
839 rho_r, rho_g, tau, xc_section, pw_pool, &
840 calc_potential)
841
842 TYPE(xc_rho_set_type) :: rho_set
843 TYPE(xc_derivative_set_type) :: deriv_set
844 INTEGER, INTENT(in) :: deriv_order
845 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau
846 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
847 TYPE(section_vals_type), POINTER :: xc_section
848 TYPE(pw_pool_type), POINTER :: pw_pool
849 LOGICAL, INTENT(in) :: calc_potential
850
851 CHARACTER(len=*), PARAMETER :: routinen = 'xc_rho_set_and_dset_create'
852
853 INTEGER :: handle, nspins
854 LOGICAL :: lsd
855 TYPE(section_vals_type), POINTER :: xc_fun_sections
856
857 CALL timeset(routinen, handle)
858
859 cpassert(ASSOCIATED(pw_pool))
860
861 nspins = SIZE(rho_r)
862 lsd = (nspins /= 1)
863
864 xc_fun_sections => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
865
866 CALL xc_dset_create(deriv_set, pw_pool)
867
868 CALL xc_rho_set_create(rho_set, &
869 rho_r(1)%pw_grid%bounds_local, &
870 rho_cutoff=section_get_rval(xc_section, "density_cutoff"), &
871 drho_cutoff=section_get_rval(xc_section, "gradient_cutoff"), &
872 tau_cutoff=section_get_rval(xc_section, "tau_cutoff"))
873
874 CALL xc_rho_set_update(rho_set, rho_r, rho_g, tau, &
875 xc_functionals_get_needs(xc_fun_sections, lsd, calc_potential), &
876 section_get_ival(xc_section, "XC_GRID%XC_DERIV"), &
877 section_get_ival(xc_section, "XC_GRID%XC_SMOOTH_RHO"), &
878 pw_pool)
879
880 CALL xc_functionals_eval(xc_fun_sections, &
881 lsd=lsd, &
882 rho_set=rho_set, &
883 deriv_set=deriv_set, &
884 deriv_order=deriv_order)
885
886 CALL divide_by_norm_drho(deriv_set, rho_set, lsd)
887
888 CALL timestop(handle)
889
890 END SUBROUTINE xc_rho_set_and_dset_create
891
892! **************************************************************************************************
893!> \brief smooths the cutoff on rho with a function smoothderiv_rho that is 0
894!> for rho<rho_cutoff and 1 for rho>rho_cutoff*rho_smooth_cutoff_range:
895!> E= integral e_0*smoothderiv_rho => dE/d...= de/d... * smooth,
896!> dE/drho = de/drho * smooth + e_0 * dsmooth/drho
897!> \param pot the potential to smooth
898!> \param rho , rhoa,rhob: the value of the density (used to apply the cutoff)
899!> \param rhoa ...
900!> \param rhob ...
901!> \param rho_cutoff the value at whch the cutoff function must go to 0
902!> \param rho_smooth_cutoff_range range of the smoothing
903!> \param e_0 value of e_0, if given it is assumed that pot is the derivative
904!> wrt. to rho, and needs the dsmooth*e_0 contribution
905!> \param e_0_scale_factor ...
906!> \author Fawzi Mohamed
907! **************************************************************************************************
908 SUBROUTINE smooth_cutoff(pot, rho, rhoa, rhob, rho_cutoff, &
909 rho_smooth_cutoff_range, e_0, e_0_scale_factor)
910 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN), &
911 POINTER :: pot, rho, rhoa, rhob
912 REAL(kind=dp), INTENT(in) :: rho_cutoff, rho_smooth_cutoff_range
913 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
914 POINTER :: e_0
915 REAL(kind=dp), INTENT(in), OPTIONAL :: e_0_scale_factor
916
917 INTEGER :: i, j, k
918 INTEGER, DIMENSION(2, 3) :: bo
919 REAL(kind=dp) :: my_e_0_scale_factor, my_rho, my_rho_n, my_rho_n2, rho_smooth_cutoff, &
920 rho_smooth_cutoff_2, rho_smooth_cutoff_range_2
921
922 cpassert(ASSOCIATED(pot))
923 bo(1, :) = lbound(pot)
924 bo(2, :) = ubound(pot)
925 my_e_0_scale_factor = 1.0_dp
926 IF (PRESENT(e_0_scale_factor)) my_e_0_scale_factor = e_0_scale_factor
927 rho_smooth_cutoff = rho_cutoff*rho_smooth_cutoff_range
928 rho_smooth_cutoff_2 = (rho_cutoff + rho_smooth_cutoff)/2
929 rho_smooth_cutoff_range_2 = rho_smooth_cutoff_2 - rho_cutoff
930
931 IF (rho_smooth_cutoff_range > 0.0_dp) THEN
932 IF (PRESENT(e_0)) THEN
933 cpassert(ASSOCIATED(e_0))
934 IF (ASSOCIATED(rho)) THEN
935!$OMP PARALLEL DO DEFAULT(NONE) &
936!$OMP SHARED(bo,e_0,pot,rho,rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2, &
937!$OMP rho_smooth_cutoff_range_2,my_e_0_scale_factor) &
938!$OMP PRIVATE(k,j,i,my_rho,my_rho_n,my_rho_n2) &
939!$OMP COLLAPSE(3)
940 DO k = bo(1, 3), bo(2, 3)
941 DO j = bo(1, 2), bo(2, 2)
942 DO i = bo(1, 1), bo(2, 1)
943 my_rho = rho(i, j, k)
944 IF (my_rho < rho_smooth_cutoff) THEN
945 IF (my_rho < rho_cutoff) THEN
946 pot(i, j, k) = 0.0_dp
947 ELSEIF (my_rho < rho_smooth_cutoff_2) THEN
948 my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
949 my_rho_n2 = my_rho_n*my_rho_n
950 pot(i, j, k) = pot(i, j, k)* &
951 my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2) + &
952 my_e_0_scale_factor*e_0(i, j, k)* &
953 my_rho_n2*(3.0_dp - 2.0_dp*my_rho_n) &
954 /rho_smooth_cutoff_range_2
955 ELSE
956 my_rho_n = 2.0_dp - (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
957 my_rho_n2 = my_rho_n*my_rho_n
958 pot(i, j, k) = pot(i, j, k)* &
959 (1.0_dp - my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2)) &
960 + my_e_0_scale_factor*e_0(i, j, k)* &
961 my_rho_n2*(3.0_dp - 2.0_dp*my_rho_n) &
962 /rho_smooth_cutoff_range_2
963 END IF
964 END IF
965 END DO
966 END DO
967 END DO
968!$OMP END PARALLEL DO
969 ELSE
970!$OMP PARALLEL DO DEFAULT(NONE) &
971!$OMP SHARED(bo,pot,e_0,rhoa,rhob,rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2, &
972!$OMP rho_smooth_cutoff_range_2,my_e_0_scale_factor) &
973!$OMP PRIVATE(k,j,i,my_rho,my_rho_n,my_rho_n2) &
974!$OMP COLLAPSE(3)
975 DO k = bo(1, 3), bo(2, 3)
976 DO j = bo(1, 2), bo(2, 2)
977 DO i = bo(1, 1), bo(2, 1)
978 my_rho = rhoa(i, j, k) + rhob(i, j, k)
979 IF (my_rho < rho_smooth_cutoff) THEN
980 IF (my_rho < rho_cutoff) THEN
981 pot(i, j, k) = 0.0_dp
982 ELSEIF (my_rho < rho_smooth_cutoff_2) THEN
983 my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
984 my_rho_n2 = my_rho_n*my_rho_n
985 pot(i, j, k) = pot(i, j, k)* &
986 my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2) + &
987 my_e_0_scale_factor*e_0(i, j, k)* &
988 my_rho_n2*(3.0_dp - 2.0_dp*my_rho_n) &
989 /rho_smooth_cutoff_range_2
990 ELSE
991 my_rho_n = 2.0_dp - (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
992 my_rho_n2 = my_rho_n*my_rho_n
993 pot(i, j, k) = pot(i, j, k)* &
994 (1.0_dp - my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2)) &
995 + my_e_0_scale_factor*e_0(i, j, k)* &
996 my_rho_n2*(3.0_dp - 2.0_dp*my_rho_n) &
997 /rho_smooth_cutoff_range_2
998 END IF
999 END IF
1000 END DO
1001 END DO
1002 END DO
1003!$OMP END PARALLEL DO
1004 END IF
1005 ELSE
1006 IF (ASSOCIATED(rho)) THEN
1007!$OMP PARALLEL DO DEFAULT(NONE) &
1008!$OMP SHARED(bo,pot,rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2, &
1009!$OMP rho_smooth_cutoff_range_2,rho) &
1010!$OMP PRIVATE(k,j,i,my_rho,my_rho_n,my_rho_n2) &
1011!$OMP COLLAPSE(3)
1012 DO k = bo(1, 3), bo(2, 3)
1013 DO j = bo(1, 2), bo(2, 2)
1014 DO i = bo(1, 1), bo(2, 1)
1015 my_rho = rho(i, j, k)
1016 IF (my_rho < rho_smooth_cutoff) THEN
1017 IF (my_rho < rho_cutoff) THEN
1018 pot(i, j, k) = 0.0_dp
1019 ELSEIF (my_rho < rho_smooth_cutoff_2) THEN
1020 my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
1021 my_rho_n2 = my_rho_n*my_rho_n
1022 pot(i, j, k) = pot(i, j, k)* &
1023 my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2)
1024 ELSE
1025 my_rho_n = 2.0_dp - (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
1026 my_rho_n2 = my_rho_n*my_rho_n
1027 pot(i, j, k) = pot(i, j, k)* &
1028 (1.0_dp - my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2))
1029 END IF
1030 END IF
1031 END DO
1032 END DO
1033 END DO
1034!$OMP END PARALLEL DO
1035 ELSE
1036!$OMP PARALLEL DO DEFAULT(NONE) &
1037!$OMP SHARED(bo,pot,rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2, &
1038!$OMP rho_smooth_cutoff_range_2,rhoa,rhob) &
1039!$OMP PRIVATE(k,j,i,my_rho,my_rho_n,my_rho_n2) &
1040!$OMP COLLAPSE(3)
1041 DO k = bo(1, 3), bo(2, 3)
1042 DO j = bo(1, 2), bo(2, 2)
1043 DO i = bo(1, 1), bo(2, 1)
1044 my_rho = rhoa(i, j, k) + rhob(i, j, k)
1045 IF (my_rho < rho_smooth_cutoff) THEN
1046 IF (my_rho < rho_cutoff) THEN
1047 pot(i, j, k) = 0.0_dp
1048 ELSEIF (my_rho < rho_smooth_cutoff_2) THEN
1049 my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
1050 my_rho_n2 = my_rho_n*my_rho_n
1051 pot(i, j, k) = pot(i, j, k)* &
1052 my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2)
1053 ELSE
1054 my_rho_n = 2.0_dp - (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
1055 my_rho_n2 = my_rho_n*my_rho_n
1056 pot(i, j, k) = pot(i, j, k)* &
1057 (1.0_dp - my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2))
1058 END IF
1059 END IF
1060 END DO
1061 END DO
1062 END DO
1063!$OMP END PARALLEL DO
1064 END IF
1065 END IF
1066 END IF
1067 END SUBROUTINE smooth_cutoff
1068
1069 SUBROUTINE calc_xc_density(pot, rho, rho_cutoff)
1070 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pot
1071 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(INOUT) :: rho
1072 REAL(kind=dp), INTENT(in) :: rho_cutoff
1073
1074 INTEGER :: i, j, k, nspins
1075 INTEGER, DIMENSION(2, 3) :: bo
1076 REAL(kind=dp) :: eps1, eps2, my_rho, my_pot
1077
1078 bo(1, :) = lbound(pot%array)
1079 bo(2, :) = ubound(pot%array)
1080 nspins = SIZE(rho)
1081
1082 eps1 = rho_cutoff*1.e-4_dp
1083 eps2 = rho_cutoff
1084
1085 DO k = bo(1, 3), bo(2, 3)
1086 DO j = bo(1, 2), bo(2, 2)
1087 DO i = bo(1, 1), bo(2, 1)
1088 my_pot = pot%array(i, j, k)
1089 IF (nspins == 2) THEN
1090 my_rho = rho(1)%array(i, j, k) + rho(2)%array(i, j, k)
1091 ELSE
1092 my_rho = rho(1)%array(i, j, k)
1093 END IF
1094 IF (my_rho > eps1) THEN
1095 pot%array(i, j, k) = my_pot/my_rho
1096 ELSE IF (my_rho < eps2) THEN
1097 pot%array(i, j, k) = 0.0_dp
1098 ELSE
1099 pot%array(i, j, k) = min(my_pot/my_rho, my_rho**(1._dp/3._dp))
1100 END IF
1101 END DO
1102 END DO
1103 END DO
1104
1105 END SUBROUTINE calc_xc_density
1106
1107! **************************************************************************************************
1108!> \brief Exchange and Correlation functional calculations
1109!> \param vxc_rho will contain the v_xc part that depend on rho
1110!> (if one of the chosen xc functionals has it it is allocated and you
1111!> are responsible for it)
1112!> \param vxc_tau will contain the kinetic tau part of v_xc
1113!> (if one of the chosen xc functionals has it it is allocated and you
1114!> are responsible for it)
1115!> \param exc the xc energy
1116!> \param rho_r the value of the density in the real space
1117!> \param rho_g value of the density in the g space (needs to be associated
1118!> only for gradient corrections)
1119!> \param tau value of the kinetic density tau on the grid (can be null,
1120!> used only with meta functionals)
1121!> \param xc_section which functional to calculate, and how to do it
1122!> \param pw_pool the pool for the grids
1123!> \param compute_virial ...
1124!> \param virial_xc ...
1125!> \param exc_r the value of the xc functional in the real space
1126!> \par History
1127!> JGH (13-Jun-2002): adaptation to new functionals
1128!> Fawzi (11.2002): drho_g(1:3)->drho_g
1129!> Fawzi (1.2003). lsd version
1130!> Fawzi (11.2003): version using the new xc interface
1131!> Fawzi (03.2004): fft free for smoothed density and derivs, gga lsd
1132!> Fawzi (04.2004): metafunctionals
1133!> mguidon (12.2008) : laplace functionals
1134!> \author fawzi; based LDA version of JGH, based on earlier version of apsi
1135!> \note
1136!> Beware: some really dirty pointer handling!
1137!> energy should be kept consistent with xc_exc_calc
1138! **************************************************************************************************
1139 SUBROUTINE xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau, xc_section, &
1140 pw_pool, compute_virial, virial_xc, exc_r)
1141 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau
1142 REAL(kind=dp), INTENT(out) :: exc
1143 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau
1144 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
1145 TYPE(section_vals_type), POINTER :: xc_section
1146 TYPE(pw_pool_type), POINTER :: pw_pool
1147 LOGICAL :: compute_virial
1148 REAL(kind=dp), DIMENSION(3, 3), INTENT(OUT) :: virial_xc
1149 TYPE(pw_r3d_rs_type), INTENT(INOUT), OPTIONAL :: exc_r
1150
1151 CHARACTER(len=*), PARAMETER :: routinen = 'xc_vxc_pw_create'
1152 INTEGER, DIMENSION(2), PARAMETER :: norm_drho_spin_name = [deriv_norm_drhoa, deriv_norm_drhob]
1153
1154 INTEGER :: handle, idir, ispin, jdir, &
1155 npoints, nspins, &
1156 xc_deriv_method_id, xc_rho_smooth_id, deriv_id
1157 INTEGER, DIMENSION(2, 3) :: bo
1158 LOGICAL :: dealloc_pw_to_deriv, has_laplace, &
1159 has_tau, lsd, use_virial, has_gradient, &
1160 has_derivs, has_rho, dealloc_pw_to_deriv_rho
1161 REAL(kind=dp) :: density_smooth_cut_range, drho_cutoff, &
1162 rho_cutoff
1163 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data, norm_drho, norm_drho_spin, &
1164 rho, rhoa, rhob
1165 TYPE(cp_sll_xc_deriv_type), POINTER :: pos
1166 TYPE(pw_grid_type), POINTER :: pw_grid
1167 TYPE(pw_r3d_rs_type), DIMENSION(3) :: pw_to_deriv, pw_to_deriv_rho
1168 TYPE(pw_c1d_gs_type) :: tmp_g, vxc_g
1169 TYPE(pw_r3d_rs_type) :: v_drho_r, virial_pw
1170 TYPE(xc_derivative_set_type) :: deriv_set
1171 TYPE(xc_derivative_type), POINTER :: deriv_att
1172 TYPE(xc_rho_set_type) :: rho_set
1173
1174 CALL timeset(routinen, handle)
1175 NULLIFY (norm_drho_spin, norm_drho, pos)
1176
1177 pw_grid => rho_r(1)%pw_grid
1178
1179 cpassert(ASSOCIATED(xc_section))
1180 cpassert(ASSOCIATED(pw_pool))
1181 cpassert(.NOT. ASSOCIATED(vxc_rho))
1182 cpassert(.NOT. ASSOCIATED(vxc_tau))
1183 nspins = SIZE(rho_r)
1184 lsd = (nspins /= 1)
1185 IF (lsd) THEN
1186 cpassert(nspins == 2)
1187 END IF
1188
1189 use_virial = compute_virial
1190 virial_xc = 0.0_dp
1191
1192 bo = rho_r(1)%pw_grid%bounds_local
1193 npoints = (bo(2, 1) - bo(1, 1) + 1)*(bo(2, 2) - bo(1, 2) + 1)*(bo(2, 3) - bo(1, 3) + 1)
1194
1195 ! calculate the potential derivatives
1196 CALL xc_rho_set_and_dset_create(rho_set=rho_set, deriv_set=deriv_set, &
1197 deriv_order=1, rho_r=rho_r, rho_g=rho_g, tau=tau, &
1198 xc_section=xc_section, &
1199 pw_pool=pw_pool, &
1200 calc_potential=.true.)
1201
1202 CALL section_vals_val_get(xc_section, "XC_GRID%XC_DERIV", &
1203 i_val=xc_deriv_method_id)
1204 CALL section_vals_val_get(xc_section, "XC_GRID%XC_SMOOTH_RHO", &
1205 i_val=xc_rho_smooth_id)
1206 CALL section_vals_val_get(xc_section, "DENSITY_SMOOTH_CUTOFF_RANGE", &
1207 r_val=density_smooth_cut_range)
1208
1209 CALL xc_rho_set_get(rho_set, rho_cutoff=rho_cutoff, &
1210 drho_cutoff=drho_cutoff)
1211
1212 CALL check_for_derivatives(deriv_set, lsd, has_rho, has_gradient, has_tau, has_laplace)
1213 ! check for unknown derivatives
1214 has_derivs = has_rho .OR. has_gradient .OR. has_tau .OR. has_laplace
1215
1216 ALLOCATE (vxc_rho(nspins))
1217
1218 CALL xc_rho_set_get(rho_set, rho=rho, rhoa=rhoa, rhob=rhob, &
1219 can_return_null=.true.)
1220
1221 ! recover the vxc arrays
1222 IF (lsd) THEN
1223 CALL xc_dset_recover_pw(deriv_set, [deriv_rhoa], vxc_rho(1), pw_grid, pw_pool)
1224 CALL xc_dset_recover_pw(deriv_set, [deriv_rhob], vxc_rho(2), pw_grid, pw_pool)
1225
1226 ELSE
1227 CALL xc_dset_recover_pw(deriv_set, [deriv_rho], vxc_rho(1), pw_grid, pw_pool)
1228 END IF
1229
1230 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho])
1231 IF (ASSOCIATED(deriv_att)) THEN
1232 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
1233
1234 CALL xc_rho_set_get(rho_set, norm_drho=norm_drho, &
1235 rho_cutoff=rho_cutoff, &
1236 drho_cutoff=drho_cutoff, &
1237 can_return_null=.true.)
1238 CALL xc_rho_set_recover_pw(rho_set, pw_grid, pw_pool, dealloc_pw_to_deriv_rho, drho=pw_to_deriv_rho)
1239
1240 cpassert(ASSOCIATED(deriv_data))
1241 IF (use_virial) THEN
1242 CALL pw_pool%create_pw(virial_pw)
1243 CALL pw_zero(virial_pw)
1244 DO idir = 1, 3
1245!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(virial_pw,pw_to_deriv_rho,deriv_data,idir)
1246 virial_pw%array(:, :, :) = pw_to_deriv_rho(idir)%array(:, :, :)*deriv_data(:, :, :)
1247!$OMP END PARALLEL WORKSHARE
1248 DO jdir = 1, idir
1249 virial_xc(idir, jdir) = -pw_grid%dvol* &
1250 accurate_dot_product(virial_pw%array(:, :, :), &
1251 pw_to_deriv_rho(jdir)%array(:, :, :))
1252 virial_xc(jdir, idir) = virial_xc(idir, jdir)
1253 END DO
1254 END DO
1255 CALL pw_pool%give_back_pw(virial_pw)
1256 END IF ! use_virial
1257 DO idir = 1, 3
1258 cpassert(ASSOCIATED(pw_to_deriv_rho(idir)%array))
1259!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_data,pw_to_deriv_rho,idir)
1260 pw_to_deriv_rho(idir)%array(:, :, :) = pw_to_deriv_rho(idir)%array(:, :, :)*deriv_data(:, :, :)
1261!$OMP END PARALLEL WORKSHARE
1262 END DO
1263
1264 ! Deallocate pw to save memory
1265 CALL pw_pool%give_back_cr3d(deriv_att%deriv_data)
1266
1267 END IF
1268
1269 IF ((has_gradient .AND. xc_requires_tmp_g(xc_deriv_method_id)) .OR. pw_grid%spherical) THEN
1270 CALL pw_pool%create_pw(vxc_g)
1271 IF (.NOT. pw_grid%spherical) THEN
1272 CALL pw_pool%create_pw(tmp_g)
1273 END IF
1274 END IF
1275
1276 DO ispin = 1, nspins
1277
1278 IF (lsd) THEN
1279 IF (ispin == 1) THEN
1280 CALL xc_rho_set_get(rho_set, norm_drhoa=norm_drho_spin, &
1281 can_return_null=.true.)
1282 IF (ASSOCIATED(norm_drho_spin)) CALL xc_rho_set_recover_pw( &
1283 rho_set, pw_grid, pw_pool, dealloc_pw_to_deriv, drhoa=pw_to_deriv)
1284 ELSE
1285 CALL xc_rho_set_get(rho_set, norm_drhob=norm_drho_spin, &
1286 can_return_null=.true.)
1287 IF (ASSOCIATED(norm_drho_spin)) CALL xc_rho_set_recover_pw( &
1288 rho_set, pw_grid, pw_pool, dealloc_pw_to_deriv, drhob=pw_to_deriv)
1289 END IF
1290
1291 deriv_att => xc_dset_get_derivative(deriv_set, [norm_drho_spin_name(ispin)])
1292 IF (ASSOCIATED(deriv_att)) THEN
1293 cpassert(lsd)
1294 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
1295
1296 IF (use_virial) THEN
1297 CALL pw_pool%create_pw(virial_pw)
1298 CALL pw_zero(virial_pw)
1299 DO idir = 1, 3
1300!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_data,pw_to_deriv,virial_pw,idir)
1301 virial_pw%array(:, :, :) = pw_to_deriv(idir)%array(:, :, :)*deriv_data(:, :, :)
1302!$OMP END PARALLEL WORKSHARE
1303 DO jdir = 1, idir
1304 virial_xc(idir, jdir) = virial_xc(idir, jdir) - pw_grid%dvol* &
1305 accurate_dot_product(virial_pw%array(:, :, :), &
1306 pw_to_deriv(jdir)%array(:, :, :))
1307 virial_xc(jdir, idir) = virial_xc(idir, jdir)
1308 END DO
1309 END DO
1310 CALL pw_pool%give_back_pw(virial_pw)
1311 END IF ! use_virial
1312
1313 DO idir = 1, 3
1314!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_data,idir,pw_to_deriv)
1315 pw_to_deriv(idir)%array(:, :, :) = deriv_data(:, :, :)*pw_to_deriv(idir)%array(:, :, :)
1316!$OMP END PARALLEL WORKSHARE
1317 END DO
1318 END IF ! deriv_att
1319
1320 END IF ! LSD
1321
1322 IF (ASSOCIATED(pw_to_deriv_rho(1)%array)) THEN
1323 IF (.NOT. ASSOCIATED(pw_to_deriv(1)%array)) THEN
1324 pw_to_deriv = pw_to_deriv_rho
1325 dealloc_pw_to_deriv = ((.NOT. lsd) .OR. (ispin == 2))
1326 dealloc_pw_to_deriv = dealloc_pw_to_deriv .AND. dealloc_pw_to_deriv_rho
1327 ELSE
1328 ! This branch is called in case of open-shell systems
1329 ! Add the contributions from norm_drho and norm_drho_spin
1330 DO idir = 1, 3
1331 CALL pw_axpy(pw_to_deriv_rho(idir), pw_to_deriv(idir))
1332 IF (ispin == 2) THEN
1333 IF (dealloc_pw_to_deriv_rho) THEN
1334 CALL pw_pool%give_back_pw(pw_to_deriv_rho(idir))
1335 END IF
1336 END IF
1337 END DO
1338 END IF
1339 END IF
1340
1341 IF (ASSOCIATED(pw_to_deriv(1)%array)) THEN
1342 DO idir = 1, 3
1343 CALL pw_scale(pw_to_deriv(idir), -1.0_dp)
1344 END DO
1345
1346 CALL xc_pw_divergence(xc_deriv_method_id, pw_to_deriv, tmp_g, vxc_g, vxc_rho(ispin))
1347
1348 IF (dealloc_pw_to_deriv) THEN
1349 DO idir = 1, 3
1350 CALL pw_pool%give_back_pw(pw_to_deriv(idir))
1351 END DO
1352 END IF
1353 END IF
1354
1355 ! Add laplace part to vxc_rho
1356 IF (has_laplace) THEN
1357 IF (lsd) THEN
1358 IF (ispin == 1) THEN
1359 deriv_id = deriv_laplace_rhoa
1360 ELSE
1361 deriv_id = deriv_laplace_rhob
1362 END IF
1363 ELSE
1364 deriv_id = deriv_laplace_rho
1365 END IF
1366
1367 CALL xc_dset_recover_pw(deriv_set, [deriv_id], pw_to_deriv(1), pw_grid)
1368
1369 IF (use_virial) CALL virial_laplace(rho_r(ispin), pw_pool, virial_xc, pw_to_deriv(1)%array)
1370
1371 CALL xc_pw_laplace(pw_to_deriv(1), pw_pool, xc_deriv_method_id)
1372
1373 CALL pw_axpy(pw_to_deriv(1), vxc_rho(ispin))
1374
1375 CALL pw_pool%give_back_pw(pw_to_deriv(1))
1376 END IF
1377
1378 IF (pw_grid%spherical) THEN
1379 ! filter vxc
1380 CALL pw_transfer(vxc_rho(ispin), vxc_g)
1381 CALL pw_transfer(vxc_g, vxc_rho(ispin))
1382 END IF
1383 CALL smooth_cutoff(pot=vxc_rho(ispin)%array, rho=rho, rhoa=rhoa, rhob=rhob, &
1384 rho_cutoff=rho_cutoff*density_smooth_cut_range, &
1385 rho_smooth_cutoff_range=density_smooth_cut_range)
1386
1387 v_drho_r = vxc_rho(ispin)
1388 CALL pw_pool%create_pw(vxc_rho(ispin))
1389 CALL xc_pw_smooth(v_drho_r, vxc_rho(ispin), xc_rho_smooth_id)
1390 CALL pw_pool%give_back_pw(v_drho_r)
1391 END DO
1392
1393 CALL pw_pool%give_back_pw(vxc_g)
1394 CALL pw_pool%give_back_pw(tmp_g)
1395
1396 ! 0-deriv -> value of exc
1397 ! this has to be kept consistent with xc_exc_calc
1398 IF (has_derivs) THEN
1399 CALL xc_dset_recover_pw(deriv_set, [INTEGER::], v_drho_r, pw_grid)
1400
1401 CALL smooth_cutoff(pot=v_drho_r%array, rho=rho, rhoa=rhoa, rhob=rhob, &
1402 rho_cutoff=rho_cutoff, &
1403 rho_smooth_cutoff_range=density_smooth_cut_range)
1404
1405 exc = pw_integrate_function(v_drho_r)
1406 !
1407 ! return the xc functional value at the grid points
1408 !
1409 IF (PRESENT(exc_r)) THEN
1410 exc_r = v_drho_r
1411 ELSE
1412 CALL v_drho_r%release()
1413 END IF
1414 ELSE
1415 exc = 0.0_dp
1416 END IF
1417
1418 CALL xc_rho_set_release(rho_set, pw_pool=pw_pool)
1419
1420 ! tau part
1421 IF (has_tau) THEN
1422 ALLOCATE (vxc_tau(nspins))
1423 IF (lsd) THEN
1424 CALL xc_dset_recover_pw(deriv_set, [deriv_tau_a], vxc_tau(1), pw_grid)
1425 CALL xc_dset_recover_pw(deriv_set, [deriv_tau_b], vxc_tau(2), pw_grid)
1426 ELSE
1427 CALL xc_dset_recover_pw(deriv_set, [deriv_tau], vxc_tau(1), pw_grid)
1428 END IF
1429 DO ispin = 1, nspins
1430 cpassert(ASSOCIATED(vxc_tau(ispin)%array))
1431 END DO
1432 END IF
1433 CALL xc_dset_release(deriv_set)
1434
1435 CALL timestop(handle)
1436
1437 END SUBROUTINE xc_vxc_pw_create
1438
1439! **************************************************************************************************
1440!> \brief calculates just the exchange and correlation energy
1441!> (no vxc)
1442!> \param rho_r realspace density on the grid
1443!> \param rho_g g-space density on the grid
1444!> \param tau kinetic energy density on the grid
1445!> \param xc_section XC parameters
1446!> \param pw_pool pool of plain-wave grids
1447!> \return the XC energy
1448!> \par History
1449!> 11.2003 created [fawzi]
1450!> \author fawzi
1451!> \note
1452!> has to be kept consistent with xc_vxc_pw_create
1453! **************************************************************************************************
1454 FUNCTION xc_exc_calc(rho_r, rho_g, tau, xc_section, pw_pool) &
1455 result(exc)
1456 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau
1457 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
1458 TYPE(section_vals_type), POINTER :: xc_section
1459 TYPE(pw_pool_type), POINTER :: pw_pool
1460 REAL(kind=dp) :: exc
1461
1462 CHARACTER(len=*), PARAMETER :: routinen = 'xc_exc_calc'
1463
1464 INTEGER :: handle
1465 REAL(dp) :: density_smooth_cut_range, rho_cutoff
1466 REAL(dp), DIMENSION(:, :, :), POINTER :: e_0
1467 TYPE(xc_derivative_set_type) :: deriv_set
1468 TYPE(xc_derivative_type), POINTER :: deriv
1469 TYPE(xc_rho_set_type) :: rho_set
1470
1471 CALL timeset(routinen, handle)
1472 NULLIFY (deriv, e_0)
1473 exc = 0.0_dp
1474
1475 ! this has to be consistent with what is done in xc_vxc_pw_create
1476 CALL xc_rho_set_and_dset_create(rho_set=rho_set, &
1477 deriv_set=deriv_set, deriv_order=0, &
1478 rho_r=rho_r, rho_g=rho_g, tau=tau, xc_section=xc_section, &
1479 pw_pool=pw_pool, &
1480 calc_potential=.false.)
1481 deriv => xc_dset_get_derivative(deriv_set, [INTEGER::])
1482
1483 IF (ASSOCIATED(deriv)) THEN
1484 CALL xc_derivative_get(deriv, deriv_data=e_0)
1485
1486 CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", &
1487 r_val=rho_cutoff)
1488 CALL section_vals_val_get(xc_section, "DENSITY_SMOOTH_CUTOFF_RANGE", &
1489 r_val=density_smooth_cut_range)
1490 CALL smooth_cutoff(pot=e_0, rho=rho_set%rho, &
1491 rhoa=rho_set%rhoa, rhob=rho_set%rhob, &
1492 rho_cutoff=rho_cutoff, &
1493 rho_smooth_cutoff_range=density_smooth_cut_range)
1494
1495 exc = accurate_sum(e_0)*rho_r(1)%pw_grid%dvol
1496 IF (rho_r(1)%pw_grid%para%mode == pw_mode_distributed) THEN
1497 CALL rho_r(1)%pw_grid%para%group%sum(exc)
1498 END IF
1499
1500 CALL xc_rho_set_release(rho_set, pw_pool=pw_pool)
1501 CALL xc_dset_release(deriv_set)
1502 END IF
1503 CALL timestop(handle)
1504 END FUNCTION xc_exc_calc
1505
1506! **************************************************************************************************
1507!> \brief Caller routine to calculate the second order potential in the direction of rho1_r
1508!> \param v_xc XC potential, will be allocated, to be integrated with the KS density
1509!> \param v_xc_tau ...
1510!> \param deriv_set XC derivatives from xc_prep_2nd_deriv
1511!> \param rho_set XC rho set from KS rho from xc_prep_2nd_deriv
1512!> \param rho1_r first-order density in r space
1513!> \param rho1_g first-order density in g space
1514!> \param tau1_r ...
1515!> \param pw_pool pw pool to create new grids
1516!> \param xc_section XC section to calculate the derivatives from
1517!> \param gapw whether to carry out GAPW (not possible with numerical derivatives)
1518!> \param vxg GAPW potential
1519!> \param do_excitations ...
1520!> \param do_triplet ...
1521!> \param compute_virial ...
1522!> \param virial_xc virial terms will be collected here
1523! **************************************************************************************************
1524 SUBROUTINE xc_calc_2nd_deriv(v_xc, v_xc_tau, deriv_set, rho_set, rho1_r, rho1_g, tau1_r, &
1525 pw_pool, xc_section, gapw, vxg, &
1526 do_excitations, do_triplet, &
1527 compute_virial, virial_xc)
1528
1529 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: v_xc, v_xc_tau
1530 TYPE(xc_derivative_set_type) :: deriv_set
1531 TYPE(xc_rho_set_type) :: rho_set
1532 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho1_r, tau1_r
1533 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho1_g
1534 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
1535 TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section
1536 LOGICAL, INTENT(IN) :: gapw
1537 REAL(kind=dp), DIMENSION(:, :, :, :), OPTIONAL, &
1538 POINTER :: vxg
1539 LOGICAL, INTENT(IN), OPTIONAL :: do_excitations, &
1540 do_triplet, compute_virial
1541 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT), &
1542 OPTIONAL :: virial_xc
1543
1544 CHARACTER(len=*), PARAMETER :: routinen = 'xc_calc_2nd_deriv'
1545
1546 INTEGER :: handle, ispin, nspins
1547 INTEGER, DIMENSION(2, 3) :: bo
1548 LOGICAL :: lsd, my_compute_virial, &
1549 my_do_excitations, &
1550 my_do_triplet
1551 REAL(kind=dp) :: fac
1552 TYPE(section_vals_type), POINTER :: xc_fun_section
1553 TYPE(xc_rho_cflags_type) :: needs
1554 TYPE(xc_rho_set_type) :: rho1_set
1555
1556 CALL timeset(routinen, handle)
1557
1558 my_compute_virial = .false.
1559 IF (PRESENT(compute_virial)) my_compute_virial = compute_virial
1560
1561 my_do_excitations = .false.
1562 IF (PRESENT(do_excitations)) my_do_excitations = do_excitations
1563
1564 my_do_triplet = .false.
1565 IF (PRESENT(do_triplet)) my_do_triplet = do_triplet
1566
1567 nspins = SIZE(rho1_r)
1568 lsd = (nspins == 2)
1569 IF (nspins == 1 .AND. my_do_excitations .AND. my_do_triplet) THEN
1570 nspins = 2
1571 lsd = .true.
1572 END IF
1573
1574 NULLIFY (v_xc, v_xc_tau)
1575 ALLOCATE (v_xc(nspins))
1576 DO ispin = 1, nspins
1577 CALL pw_pool%create_pw(v_xc(ispin))
1578 CALL pw_zero(v_xc(ispin))
1579 END DO
1580
1581 xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
1582 needs = xc_functionals_get_needs(xc_fun_section, lsd, .true.)
1583
1584 IF (needs%tau .OR. needs%tau_spin) THEN
1585 IF (.NOT. ASSOCIATED(tau1_r)) &
1586 cpabort("Tau-dependent functionals requires allocated kinetic energy density grid")
1587 ALLOCATE (v_xc_tau(nspins))
1588 DO ispin = 1, nspins
1589 CALL pw_pool%create_pw(v_xc_tau(ispin))
1590 CALL pw_zero(v_xc_tau(ispin))
1591 END DO
1592 END IF
1593
1594 IF (section_get_lval(xc_section, "2ND_DERIV_ANALYTICAL")) THEN
1595 !------!
1596 ! rho1 !
1597 !------!
1598 bo = rho1_r(1)%pw_grid%bounds_local
1599 ! create the place where to store the argument for the functionals
1600 CALL xc_rho_set_create(rho1_set, bo, &
1601 rho_cutoff=section_get_rval(xc_section, "DENSITY_CUTOFF"), &
1602 drho_cutoff=section_get_rval(xc_section, "GRADIENT_CUTOFF"), &
1603 tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF"))
1604
1605 ! calculate the arguments needed by the functionals
1606 CALL xc_rho_set_update(rho1_set, rho1_r, rho1_g, tau1_r, needs, &
1607 section_get_ival(xc_section, "XC_GRID%XC_DERIV"), &
1608 section_get_ival(xc_section, "XC_GRID%XC_SMOOTH_RHO"), &
1609 pw_pool)
1610
1611 fac = 0._dp
1612 IF (nspins == 1 .AND. my_do_excitations) THEN
1613 IF (my_do_triplet) fac = -1.0_dp
1614 END IF
1615
1616 CALL xc_calc_2nd_deriv_analytical(v_xc, v_xc_tau, deriv_set, rho_set, &
1617 rho1_set, pw_pool, xc_section, gapw, vxg=vxg, &
1618 tddfpt_fac=fac, compute_virial=compute_virial, virial_xc=virial_xc)
1619
1620 CALL xc_rho_set_release(rho1_set)
1621
1622 ELSE
1623 IF (gapw) cpabort("Numerical 2nd derivatives not implemented with GAPW")
1624
1625 CALL xc_calc_2nd_deriv_numerical(v_xc, v_xc_tau, rho_set, rho1_r, rho1_g, tau1_r, &
1626 pw_pool, xc_section, &
1627 my_do_excitations .AND. my_do_triplet, &
1628 compute_virial, virial_xc, deriv_set)
1629 END IF
1630
1631 CALL timestop(handle)
1632
1633 END SUBROUTINE xc_calc_2nd_deriv
1634
1635! **************************************************************************************************
1636!> \brief calculates 2nd derivative numerically
1637!> \param v_xc potential to be calculated (has to be allocated already)
1638!> \param v_tau tau-part of the potential to be calculated (has to be allocated already)
1639!> \param rho_set KS density from xc_prep_2nd_deriv
1640!> \param rho1_r first-order density in r-space
1641!> \param rho1_g first-order density in g-space
1642!> \param tau1_r first-order kinetic-energy density in r-space
1643!> \param pw_pool pw pool for new grids
1644!> \param xc_section XC section to calculate the derivatives from
1645!> \param do_triplet ...
1646!> \param calc_virial whether to calculate virial terms
1647!> \param virial_xc collects stress tensor components (no metaGGAs!)
1648!> \param deriv_set deriv set from xc_prep_2nd_deriv (only for virials)
1649! **************************************************************************************************
1650 SUBROUTINE xc_calc_2nd_deriv_numerical(v_xc, v_tau, rho_set, rho1_r, rho1_g, tau1_r, &
1651 pw_pool, xc_section, &
1652 do_triplet, calc_virial, virial_xc, deriv_set)
1653
1654 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(IN), POINTER :: v_xc, v_tau
1655 TYPE(xc_rho_set_type), INTENT(IN) :: rho_set
1656 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(IN), POINTER :: rho1_r, tau1_r
1657 TYPE(pw_c1d_gs_type), DIMENSION(:), INTENT(IN), POINTER :: rho1_g
1658 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
1659 TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section
1660 LOGICAL, INTENT(IN) :: do_triplet
1661 LOGICAL, INTENT(IN), OPTIONAL :: calc_virial
1662 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT), &
1663 OPTIONAL :: virial_xc
1664 TYPE(xc_derivative_set_type), OPTIONAL :: deriv_set
1665
1666 CHARACTER(len=*), PARAMETER :: routinen = 'xc_calc_2nd_deriv_numerical'
1667 REAL(kind=dp), DIMENSION(-4:4, 4), PARAMETER :: &
1668 weights = reshape([0.0_dp, 0.0_dp, 0.0_dp, -0.5_dp, 0.0_dp, 0.5_dp, 0.0_dp, 0.0_dp, 0.0_dp, &
1669 0.0_dp, 0.0_dp, 1.0_dp/12.0_dp, -2.0_dp/3.0_dp, 0.0_dp, 2.0_dp/3.0_dp, -1.0_dp/12.0_dp, 0.0_dp, 0.0_dp, &
1670 0.0_dp, -1.0_dp/60.0_dp, 0.15_dp, -0.75_dp, 0.0_dp, 0.75_dp, -0.15_dp, 1.0_dp/60.0_dp, 0.0_dp, &
1671 1.0_dp/280.0_dp, -4.0_dp/105.0_dp, 0.2_dp, -0.8_dp, 0.0_dp, 0.8_dp, -0.2_dp, 4.0_dp/105.0_dp, -1.0_dp/280.0_dp], [9, 4])
1672
1673 INTEGER :: handle, idir, ispin, nspins, istep, nsteps
1674 INTEGER, DIMENSION(2, 3) :: bo
1675 LOGICAL :: gradient_f, lsd, my_calc_virial, tau_f, laplace_f, rho_f
1676 REAL(kind=dp) :: exc, gradient_cut, h, weight, step, rho_cutoff
1677 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :) :: dr1dr, dra1dra, drb1drb
1678 REAL(kind=dp), DIMENSION(3, 3) :: virial_dummy
1679 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: norm_drho, norm_drho2, norm_drho2a, &
1680 norm_drho2b, norm_drhoa, norm_drhob, &
1681 rho, rho1, rho1a, rho1b, rhoa, rhob, &
1682 tau_a, tau_b, tau, tau1, tau1a, tau1b, laplace, laplace1, &
1683 laplacea, laplaceb, laplace1a, laplace1b, &
1684 laplace2, laplace2a, laplace2b, deriv_data
1685 TYPE(cp_3d_r_cp_type), DIMENSION(3) :: drho, drho1, drho1a, drho1b, drhoa, drhob
1686 TYPE(pw_r3d_rs_type) :: v_drho, v_drhoa, v_drhob
1687 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau
1688 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
1689 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau_r
1690 TYPE(pw_r3d_rs_type) :: virial_pw, v_laplace, v_laplacea, v_laplaceb
1691 TYPE(section_vals_type), POINTER :: xc_fun_section
1692 TYPE(xc_derivative_set_type) :: deriv_set1
1693 TYPE(xc_rho_cflags_type) :: needs
1694 TYPE(xc_rho_set_type) :: rho1_set, rho2_set
1695
1696 CALL timeset(routinen, handle)
1697
1698 my_calc_virial = .false.
1699 IF (PRESENT(calc_virial) .AND. PRESENT(virial_xc)) my_calc_virial = calc_virial
1700
1701 nspins = SIZE(v_xc)
1702
1703 NULLIFY (tau, tau_r, tau_a, tau_b)
1704
1705 h = section_get_rval(xc_section, "STEP_SIZE")
1706 nsteps = section_get_ival(xc_section, "NSTEPS")
1707 IF (nsteps < lbound(weights, 2) .OR. nspins > ubound(weights, 2)) THEN
1708 cpabort("The number of steps must be a value from 1 to 4.")
1709 END IF
1710
1711 IF (nspins == 2) THEN
1712 NULLIFY (vxc_rho, rho_g, vxc_tau)
1713 ALLOCATE (rho_r(2))
1714 DO ispin = 1, nspins
1715 CALL pw_pool%create_pw(rho_r(ispin))
1716 END DO
1717 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(v_tau)) THEN
1718 ALLOCATE (tau_r(2))
1719 DO ispin = 1, nspins
1720 CALL pw_pool%create_pw(tau_r(ispin))
1721 END DO
1722 END IF
1723 CALL xc_rho_set_get(rho_set, can_return_null=.true., rhoa=rhoa, rhob=rhob, tau_a=tau_a, tau_b=tau_b)
1724 DO istep = -nsteps, nsteps
1725 IF (istep == 0) cycle
1726 weight = weights(istep, nsteps)/h
1727 step = real(istep, dp)*h
1728 CALL calc_resp_potential_numer_ab(rho_r, rho_g, rho1_r, rhoa, rhob, vxc_rho, &
1729 tau_r, tau1_r, tau_a, tau_b, vxc_tau, xc_section, pw_pool, step)
1730 DO ispin = 1, nspins
1731 CALL pw_axpy(vxc_rho(ispin), v_xc(ispin), weight)
1732 IF (ASSOCIATED(vxc_tau) .AND. ASSOCIATED(v_tau)) THEN
1733 CALL pw_axpy(vxc_tau(ispin), v_tau(ispin), weight)
1734 END IF
1735 END DO
1736 DO ispin = 1, nspins
1737 CALL vxc_rho(ispin)%release()
1738 END DO
1739 DEALLOCATE (vxc_rho)
1740 IF (ASSOCIATED(vxc_tau)) THEN
1741 DO ispin = 1, nspins
1742 CALL vxc_tau(ispin)%release()
1743 END DO
1744 DEALLOCATE (vxc_tau)
1745 END IF
1746 END DO
1747 ELSE IF (nspins == 1 .AND. do_triplet) THEN
1748 NULLIFY (vxc_rho, vxc_tau, rho_g)
1749 ALLOCATE (rho_r(2))
1750 DO ispin = 1, 2
1751 CALL pw_pool%create_pw(rho_r(ispin))
1752 END DO
1753 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(v_tau)) THEN
1754 ALLOCATE (tau_r(2))
1755 DO ispin = 1, nspins
1756 CALL pw_pool%create_pw(tau_r(ispin))
1757 END DO
1758 END IF
1759 CALL xc_rho_set_get(rho_set, can_return_null=.true., rhoa=rhoa, rhob=rhob, tau_a=tau_a, tau_b=tau_b)
1760 DO istep = -nsteps, nsteps
1761 IF (istep == 0) cycle
1762 weight = weights(istep, nsteps)/h
1763 step = real(istep, dp)*h
1764 ! K(alpha,alpha)
1765!$OMP PARALLEL DEFAULT(NONE) SHARED(rho_r,rhoa,rhob,step,rho1_r,tau_r,tau_a,tau_b,tau1_r)
1766!$OMP WORKSHARE
1767 rho_r(1)%array(:, :, :) = rhoa(:, :, :) + step*rho1_r(1)%array(:, :, :)
1768!$OMP END WORKSHARE NOWAIT
1769!$OMP WORKSHARE
1770 rho_r(2)%array(:, :, :) = rhob(:, :, :)
1771!$OMP END WORKSHARE NOWAIT
1772 IF (ASSOCIATED(tau1_r)) THEN
1773!$OMP WORKSHARE
1774 tau_r(1)%array(:, :, :) = tau_a(:, :, :) + step*tau1_r(1)%array(:, :, :)
1775!$OMP END WORKSHARE NOWAIT
1776!$OMP WORKSHARE
1777 tau_r(2)%array(:, :, :) = tau_b(:, :, :)
1778!$OMP END WORKSHARE NOWAIT
1779 END IF
1780!$OMP END PARALLEL
1781 CALL xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau_r, xc_section, &
1782 pw_pool, .false., virial_dummy)
1783 CALL pw_axpy(vxc_rho(1), v_xc(1), weight)
1784 IF (ASSOCIATED(vxc_tau) .AND. ASSOCIATED(v_tau)) THEN
1785 CALL pw_axpy(vxc_tau(1), v_tau(1), weight)
1786 END IF
1787 DO ispin = 1, 2
1788 CALL vxc_rho(ispin)%release()
1789 END DO
1790 DEALLOCATE (vxc_rho)
1791 IF (ASSOCIATED(vxc_tau)) THEN
1792 DO ispin = 1, 2
1793 CALL vxc_tau(ispin)%release()
1794 END DO
1795 DEALLOCATE (vxc_tau)
1796 END IF
1797!$OMP PARALLEL DEFAULT(NONE) SHARED(rho_r,rhoa,rhob,step,rho1_r,tau_r,tau_a,tau_b,tau1_r)
1798!$OMP WORKSHARE
1799 ! K(alpha,beta)
1800 rho_r(1)%array(:, :, :) = rhoa(:, :, :)
1801!$OMP END WORKSHARE NOWAIT
1802!$OMP WORKSHARE
1803 rho_r(2)%array(:, :, :) = rhob(:, :, :) + step*rho1_r(1)%array(:, :, :)
1804!$OMP END WORKSHARE NOWAIT
1805 IF (ASSOCIATED(tau1_r)) THEN
1806!$OMP WORKSHARE
1807 tau_r(1)%array(:, :, :) = tau_a(:, :, :)
1808!$OMP END WORKSHARE NOWAIT
1809!$OMP WORKSHARE
1810 tau_r(2)%array(:, :, :) = tau_b(:, :, :) + step*tau1_r(1)%array(:, :, :)
1811!$OMP END WORKSHARE NOWAIT
1812 END IF
1813!$OMP END PARALLEL
1814 CALL xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau_r, xc_section, &
1815 pw_pool, .false., virial_dummy)
1816 CALL pw_axpy(vxc_rho(1), v_xc(1), weight)
1817 IF (ASSOCIATED(vxc_tau) .AND. ASSOCIATED(v_tau)) THEN
1818 CALL pw_axpy(vxc_tau(1), v_tau(1), weight)
1819 END IF
1820 DO ispin = 1, 2
1821 CALL vxc_rho(ispin)%release()
1822 END DO
1823 DEALLOCATE (vxc_rho)
1824 IF (ASSOCIATED(vxc_tau)) THEN
1825 DO ispin = 1, 2
1826 CALL vxc_tau(ispin)%release()
1827 END DO
1828 DEALLOCATE (vxc_tau)
1829 END IF
1830 END DO
1831 ELSE
1832 NULLIFY (vxc_rho, rho_r, rho_g, vxc_tau, tau_r, tau)
1833 ALLOCATE (rho_r(1))
1834 CALL pw_pool%create_pw(rho_r(1))
1835 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(v_tau)) THEN
1836 ALLOCATE (tau_r(1))
1837 CALL pw_pool%create_pw(tau_r(1))
1838 END IF
1839 CALL xc_rho_set_get(rho_set, can_return_null=.true., rho=rho, tau=tau)
1840 DO istep = -nsteps, nsteps
1841 IF (istep == 0) cycle
1842 weight = weights(istep, nsteps)/h
1843 step = real(istep, dp)*h
1844!$OMP PARALLEL DEFAULT(NONE) SHARED(rho_r,rho,step,rho1_r,tau1_r,tau,tau_r)
1845!$OMP WORKSHARE
1846 rho_r(1)%array(:, :, :) = rho(:, :, :) + step*rho1_r(1)%array(:, :, :)
1847!$OMP END WORKSHARE NOWAIT
1848 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(tau) .AND. ASSOCIATED(tau1_r)) THEN
1849!$OMP WORKSHARE
1850 tau_r(1)%array(:, :, :) = tau(:, :, :) + step*tau1_r(1)%array(:, :, :)
1851!$OMP END WORKSHARE NOWAIT
1852 END IF
1853!$OMP END PARALLEL
1854 CALL xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau_r, xc_section, &
1855 pw_pool, .false., virial_dummy)
1856 CALL pw_axpy(vxc_rho(1), v_xc(1), weight)
1857 IF (ASSOCIATED(vxc_tau) .AND. ASSOCIATED(v_tau)) THEN
1858 CALL pw_axpy(vxc_tau(1), v_tau(1), weight)
1859 END IF
1860 CALL vxc_rho(1)%release()
1861 DEALLOCATE (vxc_rho)
1862 IF (ASSOCIATED(vxc_tau)) THEN
1863 CALL vxc_tau(1)%release()
1864 DEALLOCATE (vxc_tau)
1865 END IF
1866 END DO
1867 END IF
1868
1869 IF (my_calc_virial) THEN
1870 lsd = (nspins == 2)
1871 IF (nspins == 1 .AND. do_triplet) THEN
1872 lsd = .true.
1873 END IF
1874
1875 CALL check_for_derivatives(deriv_set, (nspins == 2), rho_f, gradient_f, tau_f, laplace_f)
1876
1877 ! Calculate the virial terms
1878 ! Those arising from the first derivatives are treated like in xc_calc_2nd_deriv_analytical
1879 ! Those arising from the second derivatives are calculated numerically
1880 ! We assume that all metaGGA functionals require the gradient
1881 IF (gradient_f) THEN
1882 bo = rho_set%local_bounds
1883
1884 ! Create the work grid for the virial terms
1885 CALL allocate_pw(virial_pw, pw_pool, bo)
1886
1887 gradient_cut = section_get_rval(xc_section, "GRADIENT_CUTOFF")
1888
1889 ! create the container to store the argument of the functionals
1890 CALL xc_rho_set_create(rho1_set, bo, &
1891 rho_cutoff=section_get_rval(xc_section, "DENSITY_CUTOFF"), &
1892 drho_cutoff=gradient_cut, &
1893 tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF"))
1894
1895 xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
1896 needs = xc_functionals_get_needs(xc_fun_section, lsd, .true.)
1897
1898 ! calculate the arguments needed by the functionals
1899 CALL xc_rho_set_update(rho1_set, rho1_r, rho1_g, tau1_r, needs, &
1900 section_get_ival(xc_section, "XC_GRID%XC_DERIV"), &
1901 section_get_ival(xc_section, "XC_GRID%XC_SMOOTH_RHO"), &
1902 pw_pool)
1903
1904 IF (lsd) THEN
1905 CALL xc_rho_set_get(rho_set, drhoa=drhoa, drhob=drhob, norm_drho=norm_drho, &
1906 norm_drhoa=norm_drhoa, norm_drhob=norm_drhob, tau_a=tau_a, tau_b=tau_b, &
1907 laplace_rhoa=laplacea, laplace_rhob=laplaceb, can_return_null=.true.)
1908 CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b, drhoa=drho1a, drhob=drho1b, laplace_rhoa=laplace1a, &
1909 laplace_rhob=laplace1b, can_return_null=.true.)
1910
1911 CALL calc_drho_from_ab(drho, drhoa, drhob)
1912 CALL calc_drho_from_ab(drho1, drho1a, drho1b)
1913 ELSE
1914 CALL xc_rho_set_get(rho_set, drho=drho, norm_drho=norm_drho, tau=tau, laplace_rho=laplace, can_return_null=.true.)
1915 CALL xc_rho_set_get(rho1_set, rho=rho1, drho=drho1, laplace_rho=laplace1, can_return_null=.true.)
1916 END IF
1917
1918 CALL prepare_dr1dr(dr1dr, drho, drho1)
1919
1920 IF (lsd) THEN
1921 CALL prepare_dr1dr(dra1dra, drhoa, drho1a)
1922 CALL prepare_dr1dr(drb1drb, drhob, drho1b)
1923
1924 CALL allocate_pw(v_drho, pw_pool, bo)
1925 CALL allocate_pw(v_drhoa, pw_pool, bo)
1926 CALL allocate_pw(v_drhob, pw_pool, bo)
1927
1928 IF (ASSOCIATED(norm_drhoa)) CALL apply_drho(deriv_set, [deriv_norm_drhoa], virial_pw, drhoa, drho1a, virial_xc, &
1929 norm_drhoa, gradient_cut, dra1dra, v_drhoa%array)
1930 IF (ASSOCIATED(norm_drhob)) CALL apply_drho(deriv_set, [deriv_norm_drhob], virial_pw, drhob, drho1b, virial_xc, &
1931 norm_drhob, gradient_cut, drb1drb, v_drhob%array)
1932 IF (ASSOCIATED(norm_drho)) CALL apply_drho(deriv_set, [deriv_norm_drho], virial_pw, drho, drho1, virial_xc, &
1933 norm_drho, gradient_cut, dr1dr, v_drho%array)
1934 IF (laplace_f) THEN
1935 CALL xc_derivative_get(xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa]), deriv_data=deriv_data)
1936 cpassert(ASSOCIATED(deriv_data))
1937 virial_pw%array(:, :, :) = -rho1a(:, :, :)
1938 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
1939
1940 CALL allocate_pw(v_laplacea, pw_pool, bo)
1941
1942 CALL xc_derivative_get(xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob]), deriv_data=deriv_data)
1943 cpassert(ASSOCIATED(deriv_data))
1944 virial_pw%array(:, :, :) = -rho1b(:, :, :)
1945 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
1946
1947 CALL allocate_pw(v_laplaceb, pw_pool, bo)
1948 END IF
1949
1950 ELSE
1951
1952 ! Create the work grid for the potential of the gradient part
1953 CALL allocate_pw(v_drho, pw_pool, bo)
1954
1955 CALL apply_drho(deriv_set, [deriv_norm_drho], virial_pw, drho, drho1, virial_xc, &
1956 norm_drho, gradient_cut, dr1dr, v_drho%array)
1957 IF (laplace_f) THEN
1958 CALL xc_derivative_get(xc_dset_get_derivative(deriv_set, [deriv_laplace_rho]), deriv_data=deriv_data)
1959 cpassert(ASSOCIATED(deriv_data))
1960 virial_pw%array(:, :, :) = -rho1(:, :, :)
1961 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
1962
1963 CALL allocate_pw(v_laplace, pw_pool, bo)
1964 END IF
1965
1966 END IF
1967
1968 IF (lsd) THEN
1969 rho_r(1)%array = rhoa
1970 rho_r(2)%array = rhob
1971 ELSE
1972 rho_r(1)%array = rho
1973 END IF
1974 IF (ASSOCIATED(tau1_r)) THEN
1975 IF (lsd) THEN
1976 tau_r(1)%array = tau_a
1977 tau_r(2)%array = tau_b
1978 ELSE
1979 tau_r(1)%array = tau
1980 END IF
1981 END IF
1982
1983 ! Create deriv sets with same densities but different gradients
1984 CALL xc_dset_create(deriv_set1, pw_pool)
1985
1986 rho_cutoff = section_get_rval(xc_section, "DENSITY_CUTOFF")
1987
1988 ! create the place where to store the argument for the functionals
1989 CALL xc_rho_set_create(rho2_set, bo, &
1990 rho_cutoff=rho_cutoff, &
1991 drho_cutoff=section_get_rval(xc_section, "GRADIENT_CUTOFF"), &
1992 tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF"))
1993
1994 ! calculate the arguments needed by the functionals
1995 CALL xc_rho_set_update(rho2_set, rho_r, rho_g, tau_r, needs, &
1996 section_get_ival(xc_section, "XC_GRID%XC_DERIV"), &
1997 section_get_ival(xc_section, "XC_GRID%XC_SMOOTH_RHO"), &
1998 pw_pool)
1999
2000 IF (lsd) THEN
2001 CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b, tau_a=tau1a, tau_b=tau1b, &
2002 laplace_rhoa=laplace1a, laplace_rhob=laplace1b, can_return_null=.true.)
2003 CALL xc_rho_set_get(rho2_set, norm_drhoa=norm_drho2a, norm_drhob=norm_drho2b, &
2004 norm_drho=norm_drho2, laplace_rhoa=laplace2a, laplace_rhob=laplace2b, can_return_null=.true.)
2005
2006 DO istep = -nsteps, nsteps
2007 IF (istep == 0) cycle
2008 weight = weights(istep, nsteps)/h
2009 step = real(istep, dp)*h
2010 IF (ASSOCIATED(norm_drhoa)) THEN
2011 CALL get_derivs_rho(norm_drho2a, norm_drhoa, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2012 CALL update_deriv_rho(deriv_set1, [deriv_rhoa], bo, &
2013 norm_drhoa, gradient_cut, weight, rho1a, v_drhoa%array)
2014 CALL update_deriv_rho(deriv_set1, [deriv_rhob], bo, &
2015 norm_drhoa, gradient_cut, weight, rho1b, v_drhoa%array)
2016 CALL update_deriv_rho(deriv_set1, [deriv_norm_drhoa], bo, &
2017 norm_drhoa, gradient_cut, weight, dra1dra, v_drhoa%array)
2018 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drhob], bo, &
2019 norm_drhoa, gradient_cut, weight, dra1dra, drb1drb, v_drhoa%array, v_drhob%array)
2020 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drho], bo, &
2021 norm_drhoa, gradient_cut, weight, dra1dra, dr1dr, v_drhoa%array, v_drho%array)
2022 IF (tau_f) THEN
2023 CALL update_deriv_rho(deriv_set1, [deriv_tau_a], bo, &
2024 norm_drhoa, gradient_cut, weight, tau1a, v_drhoa%array)
2025 CALL update_deriv_rho(deriv_set1, [deriv_tau_b], bo, &
2026 norm_drhoa, gradient_cut, weight, tau1b, v_drhoa%array)
2027 END IF
2028 IF (laplace_f) THEN
2029 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhoa], bo, &
2030 norm_drhoa, gradient_cut, weight, laplace1a, v_drhoa%array)
2031 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhob], bo, &
2032 norm_drhoa, gradient_cut, weight, laplace1b, v_drhoa%array)
2033 END IF
2034 END IF
2035
2036 IF (ASSOCIATED(norm_drhob)) THEN
2037 CALL get_derivs_rho(norm_drho2b, norm_drhob, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2038 CALL update_deriv_rho(deriv_set1, [deriv_rhoa], bo, &
2039 norm_drhob, gradient_cut, weight, rho1a, v_drhob%array)
2040 CALL update_deriv_rho(deriv_set1, [deriv_rhob], bo, &
2041 norm_drhob, gradient_cut, weight, rho1b, v_drhob%array)
2042 CALL update_deriv_rho(deriv_set1, [deriv_norm_drhob], bo, &
2043 norm_drhob, gradient_cut, weight, drb1drb, v_drhob%array)
2044 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drhoa], bo, &
2045 norm_drhob, gradient_cut, weight, drb1drb, dra1dra, v_drhob%array, v_drhoa%array)
2046 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drho], bo, &
2047 norm_drhob, gradient_cut, weight, drb1drb, dr1dr, v_drhob%array, v_drho%array)
2048 IF (tau_f) THEN
2049 CALL update_deriv_rho(deriv_set1, [deriv_tau_a], bo, &
2050 norm_drhob, gradient_cut, weight, tau1a, v_drhob%array)
2051 CALL update_deriv_rho(deriv_set1, [deriv_tau_b], bo, &
2052 norm_drhob, gradient_cut, weight, tau1b, v_drhob%array)
2053 END IF
2054 IF (laplace_f) THEN
2055 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhoa], bo, &
2056 norm_drhob, gradient_cut, weight, laplace1a, v_drhob%array)
2057 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhob], bo, &
2058 norm_drhob, gradient_cut, weight, laplace1b, v_drhob%array)
2059 END IF
2060 END IF
2061
2062 IF (ASSOCIATED(norm_drho)) THEN
2063 CALL get_derivs_rho(norm_drho2, norm_drho, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2064 CALL update_deriv_rho(deriv_set1, [deriv_rhoa], bo, &
2065 norm_drho, gradient_cut, weight, rho1a, v_drho%array)
2066 CALL update_deriv_rho(deriv_set1, [deriv_rhob], bo, &
2067 norm_drho, gradient_cut, weight, rho1b, v_drho%array)
2068 CALL update_deriv_rho(deriv_set1, [deriv_norm_drho], bo, &
2069 norm_drho, gradient_cut, weight, dr1dr, v_drho%array)
2070 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drhoa], bo, &
2071 norm_drho, gradient_cut, weight, dr1dr, dra1dra, v_drho%array, v_drhoa%array)
2072 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drhob], bo, &
2073 norm_drho, gradient_cut, weight, dr1dr, drb1drb, v_drho%array, v_drhob%array)
2074 IF (tau_f) THEN
2075 CALL update_deriv_rho(deriv_set1, [deriv_tau_a], bo, &
2076 norm_drho, gradient_cut, weight, tau1a, v_drho%array)
2077 CALL update_deriv_rho(deriv_set1, [deriv_tau_b], bo, &
2078 norm_drho, gradient_cut, weight, tau1b, v_drho%array)
2079 END IF
2080 IF (laplace_f) THEN
2081 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhoa], bo, &
2082 norm_drho, gradient_cut, weight, laplace1a, v_drho%array)
2083 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhob], bo, &
2084 norm_drho, gradient_cut, weight, laplace1b, v_drho%array)
2085 END IF
2086 END IF
2087
2088 IF (laplace_f) THEN
2089
2090 CALL get_derivs_rho(laplace2a, laplacea, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2091
2092 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2093 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_rhoa], bo, &
2094 weight, rho1a, v_laplacea%array)
2095 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_rhob], bo, &
2096 weight, rho1b, v_laplacea%array)
2097 IF (ASSOCIATED(norm_drho)) THEN
2098 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_norm_drho], bo, &
2099 weight, dr1dr, v_laplacea%array)
2100 END IF
2101 IF (ASSOCIATED(norm_drhoa)) THEN
2102 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_norm_drhoa], bo, &
2103 weight, dra1dra, v_laplacea%array)
2104 END IF
2105 IF (ASSOCIATED(norm_drhob)) THEN
2106 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_norm_drhob], bo, &
2107 weight, drb1drb, v_laplacea%array)
2108 END IF
2109
2110 IF (ASSOCIATED(tau1a)) THEN
2111 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_tau_a], bo, &
2112 weight, tau1a, v_laplacea%array)
2113 END IF
2114 IF (ASSOCIATED(tau1b)) THEN
2115 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_tau_b], bo, &
2116 weight, tau1b, v_laplacea%array)
2117 END IF
2118
2119 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_laplace_rhoa], bo, &
2120 weight, laplace1a, v_laplacea%array)
2121
2122 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_laplace_rhob], bo, &
2123 weight, laplace1b, v_laplacea%array)
2124
2125 ! The same for the beta spin
2126 CALL get_derivs_rho(laplace2b, laplaceb, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2127
2128 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2129 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_rhoa], bo, &
2130 weight, rho1a, v_laplaceb%array)
2131 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_rhob], bo, &
2132 weight, rho1b, v_laplaceb%array)
2133 IF (ASSOCIATED(norm_drho)) THEN
2134 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_norm_drho], bo, &
2135 weight, dr1dr, v_laplaceb%array)
2136 END IF
2137 IF (ASSOCIATED(norm_drhoa)) THEN
2138 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_norm_drhoa], bo, &
2139 weight, dra1dra, v_laplaceb%array)
2140 END IF
2141 IF (ASSOCIATED(norm_drhob)) THEN
2142 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_norm_drhob], bo, &
2143 weight, drb1drb, v_laplaceb%array)
2144 END IF
2145
2146 IF (tau_f) THEN
2147 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_tau_a], bo, &
2148 weight, tau1a, v_laplaceb%array)
2149 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_tau_b], bo, &
2150 weight, tau1b, v_laplaceb%array)
2151 END IF
2152
2153 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_laplace_rhoa], bo, &
2154 weight, laplace1a, v_laplaceb%array)
2155
2156 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_laplace_rhob], bo, &
2157 weight, laplace1b, v_laplaceb%array)
2158 END IF
2159 END DO
2160
2161 CALL virial_drho_drho(virial_pw, drhoa, v_drhoa, virial_xc)
2162 CALL virial_drho_drho(virial_pw, drhob, v_drhob, virial_xc)
2163 CALL virial_drho_drho(virial_pw, drho, v_drho, virial_xc)
2164
2165 CALL deallocate_pw(v_drho, pw_pool)
2166 CALL deallocate_pw(v_drhoa, pw_pool)
2167 CALL deallocate_pw(v_drhob, pw_pool)
2168
2169 IF (laplace_f) THEN
2170 virial_pw%array(:, :, :) = -rhoa(:, :, :)
2171 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplacea%array)
2172 CALL deallocate_pw(v_laplacea, pw_pool)
2173
2174 virial_pw%array(:, :, :) = -rhob(:, :, :)
2175 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplaceb%array)
2176 CALL deallocate_pw(v_laplaceb, pw_pool)
2177 END IF
2178
2179 CALL deallocate_pw(virial_pw, pw_pool)
2180
2181 DO idir = 1, 3
2182 DEALLOCATE (drho(idir)%array)
2183 DEALLOCATE (drho1(idir)%array)
2184 END DO
2185 DEALLOCATE (dra1dra, drb1drb)
2186
2187 ELSE
2188 CALL xc_rho_set_get(rho1_set, rho=rho1, tau=tau1, laplace_rho=laplace1, can_return_null=.true.)
2189 CALL xc_rho_set_get(rho2_set, norm_drho=norm_drho2, laplace_rho=laplace2, can_return_null=.true.)
2190
2191 DO istep = -nsteps, nsteps
2192 IF (istep == 0) cycle
2193 weight = weights(istep, nsteps)/h
2194 step = real(istep, dp)*h
2195 CALL get_derivs_rho(norm_drho2, norm_drho, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2196
2197 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2198 CALL update_deriv_rho(deriv_set1, [deriv_rho], bo, &
2199 norm_drho, gradient_cut, weight, rho1, v_drho%array)
2200 CALL update_deriv_rho(deriv_set1, [deriv_norm_drho], bo, &
2201 norm_drho, gradient_cut, weight, dr1dr, v_drho%array)
2202
2203 IF (tau_f) THEN
2204 CALL update_deriv_rho(deriv_set1, [deriv_tau], bo, &
2205 norm_drho, gradient_cut, weight, tau1, v_drho%array)
2206 END IF
2207 IF (laplace_f) THEN
2208 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rho], bo, &
2209 norm_drho, gradient_cut, weight, laplace1, v_drho%array)
2210
2211 CALL get_derivs_rho(laplace2, laplace, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2212
2213 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2214 CALL update_deriv(deriv_set1, laplace, rho_cutoff, [deriv_rho], bo, &
2215 weight, rho1, v_laplace%array)
2216 CALL update_deriv(deriv_set1, laplace, rho_cutoff, [deriv_norm_drho], bo, &
2217 weight, dr1dr, v_laplace%array)
2218
2219 IF (tau_f) THEN
2220 CALL update_deriv(deriv_set1, laplace, rho_cutoff, [deriv_tau], bo, &
2221 weight, tau1, v_laplace%array)
2222 END IF
2223
2224 CALL update_deriv(deriv_set1, laplace, rho_cutoff, [deriv_laplace_rho], bo, &
2225 weight, laplace1, v_laplace%array)
2226 END IF
2227 END DO
2228
2229 ! Calculate the virial contribution from the potential
2230 CALL virial_drho_drho(virial_pw, drho, v_drho, virial_xc)
2231
2232 CALL deallocate_pw(v_drho, pw_pool)
2233
2234 IF (laplace_f) THEN
2235 virial_pw%array(:, :, :) = -rho(:, :, :)
2236 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplace%array)
2237 CALL deallocate_pw(v_laplace, pw_pool)
2238 END IF
2239
2240 CALL deallocate_pw(virial_pw, pw_pool)
2241 END IF
2242
2243 END IF
2244
2245 CALL xc_dset_release(deriv_set1)
2246
2247 DEALLOCATE (dr1dr)
2248
2249 CALL xc_rho_set_release(rho1_set)
2250 CALL xc_rho_set_release(rho2_set)
2251 END IF
2252
2253 DO ispin = 1, SIZE(rho_r)
2254 CALL pw_pool%give_back_pw(rho_r(ispin))
2255 END DO
2256 DEALLOCATE (rho_r)
2257
2258 IF (ASSOCIATED(tau_r)) THEN
2259 DO ispin = 1, SIZE(tau_r)
2260 CALL pw_pool%give_back_pw(tau_r(ispin))
2261 END DO
2262 DEALLOCATE (tau_r)
2263 END IF
2264
2265 CALL timestop(handle)
2266
2267 END SUBROUTINE xc_calc_2nd_deriv_numerical
2268
2269! **************************************************************************************************
2270!> \brief ...
2271!> \param rho_r ...
2272!> \param rho_g ...
2273!> \param rho1_r ...
2274!> \param rhoa ...
2275!> \param rhob ...
2276!> \param vxc_rho ...
2277!> \param tau_r ...
2278!> \param tau1_r ...
2279!> \param tau_a ...
2280!> \param tau_b ...
2281!> \param vxc_tau ...
2282!> \param xc_section ...
2283!> \param pw_pool ...
2284!> \param step ...
2285! **************************************************************************************************
2286 SUBROUTINE calc_resp_potential_numer_ab(rho_r, rho_g, rho1_r, rhoa, rhob, vxc_rho, &
2287 tau_r, tau1_r, tau_a, tau_b, vxc_tau, &
2288 xc_section, pw_pool, step)
2289
2290 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER, INTENT(IN) :: vxc_rho, vxc_tau
2291 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(IN) :: rho1_r
2292 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(IN), POINTER :: tau1_r
2293 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
2294 TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section
2295 REAL(kind=dp), INTENT(IN) :: step
2296 REAL(kind=dp), DIMENSION(:, :, :), POINTER, INTENT(IN) :: rhoa, rhob, tau_a, tau_b
2297 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER, INTENT(IN) :: rho_r
2298 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
2299 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: tau_r
2300
2301 CHARACTER(len=*), PARAMETER :: routinen = 'calc_resp_potential_numer_ab'
2302
2303 INTEGER :: handle
2304 REAL(kind=dp) :: exc
2305 REAL(kind=dp), DIMENSION(3, 3) :: virial_dummy
2306
2307 CALL timeset(routinen, handle)
2308
2309!$OMP PARALLEL DEFAULT(NONE) SHARED(rho_r,rhoa,rhob,step,rho1_r,tau_r,tau_a,tau_b,tau1_r)
2310!$OMP WORKSHARE
2311 rho_r(1)%array(:, :, :) = rhoa(:, :, :) + step*rho1_r(1)%array(:, :, :)
2312!$OMP END WORKSHARE NOWAIT
2313!$OMP WORKSHARE
2314 rho_r(2)%array(:, :, :) = rhob(:, :, :) + step*rho1_r(2)%array(:, :, :)
2315!$OMP END WORKSHARE NOWAIT
2316 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(tau_r) .AND. ASSOCIATED(tau_a) .AND. ASSOCIATED(tau_b)) THEN
2317!$OMP WORKSHARE
2318 tau_r(1)%array(:, :, :) = tau_a(:, :, :) + step*tau1_r(1)%array(:, :, :)
2319!$OMP END WORKSHARE NOWAIT
2320!$OMP WORKSHARE
2321 tau_r(2)%array(:, :, :) = tau_b(:, :, :) + step*tau1_r(2)%array(:, :, :)
2322!$OMP END WORKSHARE NOWAIT
2323 END IF
2324!$OMP END PARALLEL
2325 CALL xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau_r, xc_section, &
2326 pw_pool, .false., virial_dummy)
2327
2328 CALL timestop(handle)
2329
2330 END SUBROUTINE calc_resp_potential_numer_ab
2331
2332! **************************************************************************************************
2333!> \brief calculates stress tensor and potential contributions from the first derivative
2334!> \param deriv_set ...
2335!> \param description ...
2336!> \param virial_pw ...
2337!> \param drho ...
2338!> \param drho1 ...
2339!> \param virial_xc ...
2340!> \param norm_drho ...
2341!> \param gradient_cut ...
2342!> \param dr1dr ...
2343!> \param v_drho ...
2344! **************************************************************************************************
2345 SUBROUTINE apply_drho(deriv_set, description, virial_pw, drho, drho1, virial_xc, norm_drho, gradient_cut, dr1dr, v_drho)
2346
2347 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set
2348 INTEGER, DIMENSION(:), INTENT(in) :: description
2349 TYPE(pw_r3d_rs_type), INTENT(IN) :: virial_pw
2350 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drho, drho1
2351 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT) :: virial_xc
2352 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: norm_drho
2353 REAL(kind=dp), INTENT(IN) :: gradient_cut
2354 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: dr1dr
2355 REAL(kind=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v_drho
2356
2357 CHARACTER(len=*), PARAMETER :: routinen = 'apply_drho'
2358
2359 INTEGER :: handle
2360 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data
2361 TYPE(xc_derivative_type), POINTER :: deriv_att
2362
2363 CALL timeset(routinen, handle)
2364
2365 deriv_att => xc_dset_get_derivative(deriv_set, description)
2366 IF (ASSOCIATED(deriv_att)) THEN
2367 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2368 CALL virial_drho_drho1(virial_pw, drho, drho1, deriv_data, virial_xc)
2369
2370!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,gradient_cut,norm_drho,v_drho,deriv_data)
2371 v_drho(:, :, :) = v_drho(:, :, :) + &
2372 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
2373!$OMP END PARALLEL WORKSHARE
2374 END IF
2375
2376 CALL timestop(handle)
2377
2378 END SUBROUTINE apply_drho
2379
2380! **************************************************************************************************
2381!> \brief adds potential contributions from derivatives of rho or diagonal terms of norm_drho
2382!> \param deriv_set1 ...
2383!> \param description ...
2384!> \param bo ...
2385!> \param norm_drho norm_drho of which derivative is calculated
2386!> \param gradient_cut ...
2387!> \param h ...
2388!> \param rho1 function to contract the derivative with (rho1 for rho, dr1dr for norm_drho)
2389!> \param v_drho ...
2390! **************************************************************************************************
2391 SUBROUTINE update_deriv_rho(deriv_set1, description, bo, norm_drho, gradient_cut, weight, rho1, v_drho)
2392
2393 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set1
2394 INTEGER, DIMENSION(:), INTENT(in) :: description
2395 INTEGER, DIMENSION(2, 3), INTENT(IN) :: bo
2396 REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, 1), bo(1, & 2):bo(2, 2), bo(1, 3):bo(2, 3)), INTENT(IN) :: norm_drho
2397 REAL(kind=dp), INTENT(IN) :: gradient_cut, weight
2398 REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, 1), bo(1, & 2):bo(2, 2), bo(1, 3):bo(2, 3)), INTENT(IN) :: rho1
2399 REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, 1), bo(1, & 2):bo(2, 2), bo(1, 3):bo(2, 3)), INTENT(INOUT) :: v_drho
2400
2401 CHARACTER(len=*), PARAMETER :: routinen = 'update_deriv_rho'
2402
2403 INTEGER :: handle, i, j, k
2404 REAL(kind=dp) :: de
2405 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data1
2406 TYPE(xc_derivative_type), POINTER :: deriv_att1
2407
2408 CALL timeset(routinen, handle)
2409
2410 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2411 deriv_att1 => xc_dset_get_derivative(deriv_set1, description)
2412 IF (ASSOCIATED(deriv_att1)) THEN
2413 CALL xc_derivative_get(deriv_att1, deriv_data=deriv_data1)
2414!$OMP PARALLEL DO DEFAULT(NONE) &
2415!$OMP SHARED(bo,deriv_data1,weight,norm_drho,v_drho,rho1,gradient_cut) &
2416!$OMP PRIVATE(i,j,k,de) &
2417!$OMP COLLAPSE(3)
2418 DO k = bo(1, 3), bo(2, 3)
2419 DO j = bo(1, 2), bo(2, 2)
2420 DO i = bo(1, 1), bo(2, 1)
2421 de = weight*deriv_data1(i, j, k)/max(gradient_cut, norm_drho(i, j, k))**2
2422 v_drho(i, j, k) = v_drho(i, j, k) - de*rho1(i, j, k)
2423 END DO
2424 END DO
2425 END DO
2426!$OMP END PARALLEL DO
2427 END IF
2428
2429 CALL timestop(handle)
2430
2431 END SUBROUTINE update_deriv_rho
2432
2433! **************************************************************************************************
2434!> \brief adds potential contributions from derivatives of a component with positive and negative values
2435!> \param deriv_set1 ...
2436!> \param description ...
2437!> \param bo ...
2438!> \param h ...
2439!> \param rho1 function to contract the derivative with (rho1 for rho, dr1dr for norm_drho)
2440!> \param v ...
2441! **************************************************************************************************
2442 SUBROUTINE update_deriv(deriv_set1, rho, rho_cutoff, description, bo, weight, rho1, v)
2443
2444 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set1
2445 INTEGER, DIMENSION(:), INTENT(in) :: description
2446 INTEGER, DIMENSION(2, 3), INTENT(IN) :: bo
2447 REAL(kind=dp), INTENT(IN) :: weight, rho_cutoff
2448 REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, 1), bo(1, & 2):bo(2, 2), bo(1, 3):bo(2, 3)), INTENT(IN) :: rho, rho1
2449 REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, 1), bo(1, & 2):bo(2, 2), bo(1, 3):bo(2, 3)), INTENT(INOUT) :: v
2450
2451 CHARACTER(len=*), PARAMETER :: routinen = 'update_deriv'
2452
2453 INTEGER :: handle, i, j, k
2454 REAL(kind=dp) :: de
2455 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data1
2456 TYPE(xc_derivative_type), POINTER :: deriv_att1
2457
2458 CALL timeset(routinen, handle)
2459
2460 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2461 deriv_att1 => xc_dset_get_derivative(deriv_set1, description)
2462 IF (ASSOCIATED(deriv_att1)) THEN
2463 CALL xc_derivative_get(deriv_att1, deriv_data=deriv_data1)
2464!$OMP PARALLEL DO DEFAULT(NONE) &
2465!$OMP SHARED(bo,deriv_data1,weight,v,rho1,rho, rho_cutoff) &
2466!$OMP PRIVATE(i,j,k,de) &
2467!$OMP COLLAPSE(3)
2468 DO k = bo(1, 3), bo(2, 3)
2469 DO j = bo(1, 2), bo(2, 2)
2470 DO i = bo(1, 1), bo(2, 1)
2471 ! We have to consider that the given density (mostly the Laplacian) may have positive and negative values
2472 de = weight*deriv_data1(i, j, k)/sign(max(abs(rho(i, j, k)), rho_cutoff), rho(i, j, k))
2473 v(i, j, k) = v(i, j, k) + de*rho1(i, j, k)
2474 END DO
2475 END DO
2476 END DO
2477!$OMP END PARALLEL DO
2478 END IF
2479
2480 CALL timestop(handle)
2481
2482 END SUBROUTINE update_deriv
2483
2484! **************************************************************************************************
2485!> \brief adds mixed derivatives of norm_drho
2486!> \param deriv_set1 ...
2487!> \param description ...
2488!> \param bo ...
2489!> \param norm_drhoa norm_drho of which derivatives is calculated
2490!> \param gradient_cut ...
2491!> \param h ...
2492!> \param dra1dra dr1dr corresponding to norm_drho
2493!> \param drb1drb ...
2494!> \param v_drhoa potential corresponding to norm_drho
2495!> \param v_drhob ...
2496! **************************************************************************************************
2497 SUBROUTINE update_deriv_drho_ab(deriv_set1, description, bo, &
2498 norm_drhoa, gradient_cut, weight, dra1dra, drb1drb, v_drhoa, v_drhob)
2499
2500 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set1
2501 INTEGER, DIMENSION(:), INTENT(in) :: description
2502 INTEGER, DIMENSION(2, 3), INTENT(IN) :: bo
2503 REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, 1), bo(1, & 2):bo(2, 2), bo(1, 3):bo(2, 3)), INTENT(IN) :: norm_drhoa
2504 REAL(kind=dp), INTENT(IN) :: gradient_cut, weight
2505 REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, 1), bo(1, & 2):bo(2, 2), bo(1, 3):bo(2, 3)), INTENT(IN) :: dra1dra, drb1drb
2506 REAL(kind=dp), DIMENSION(bo(1, 1):bo(2, 1), bo(1, & 2):bo(2, 2), bo(1, 3):bo(2, 3)), INTENT(INOUT) :: v_drhoa, v_drhob
2507
2508 CHARACTER(len=*), PARAMETER :: routinen = 'update_deriv_drho_ab'
2509
2510 INTEGER :: handle, i, j, k
2511 REAL(kind=dp) :: de
2512 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data1
2513 TYPE(xc_derivative_type), POINTER :: deriv_att1
2514
2515 CALL timeset(routinen, handle)
2516
2517 deriv_att1 => xc_dset_get_derivative(deriv_set1, description)
2518 IF (ASSOCIATED(deriv_att1)) THEN
2519 CALL xc_derivative_get(deriv_att1, deriv_data=deriv_data1)
2520!$OMP PARALLEL DO DEFAULT(NONE) &
2521!$OMP PRIVATE(k,j,i,de) &
2522!$OMP SHARED(bo,drb1drb,dra1dra,deriv_data1,weight,gradient_cut,norm_drhoa,v_drhoa,v_drhob) &
2523!$OMP COLLAPSE(3)
2524 DO k = bo(1, 3), bo(2, 3)
2525 DO j = bo(1, 2), bo(2, 2)
2526 DO i = bo(1, 1), bo(2, 1)
2527 ! We introduce a factor of two because we will average between both numerical derivatives
2528 de = 0.5_dp*weight*deriv_data1(i, j, k)/max(gradient_cut, norm_drhoa(i, j, k))**2
2529 v_drhoa(i, j, k) = v_drhoa(i, j, k) - de*drb1drb(i, j, k)
2530 v_drhob(i, j, k) = v_drhob(i, j, k) - de*dra1dra(i, j, k)
2531 END DO
2532 END DO
2533 END DO
2534!$OMP END PARALLEL DO
2535 END IF
2536
2537 CALL timestop(handle)
2538
2539 END SUBROUTINE update_deriv_drho_ab
2540
2541! **************************************************************************************************
2542!> \brief calculate derivative sets for helper points
2543!> \param norm_drho2 norm_drho of new points
2544!> \param norm_drho norm_drho of KS density
2545!> \param h ...
2546!> \param xc_fun_section ...
2547!> \param lsd ...
2548!> \param rho2_set rho_set for new points
2549!> \param deriv_set1 will contain derivatives of the perturbed density
2550! **************************************************************************************************
2551 SUBROUTINE get_derivs_rho(norm_drho2, norm_drho, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2552 REAL(kind=dp), DIMENSION(:, :, :), INTENT(OUT) :: norm_drho2
2553 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: norm_drho
2554 REAL(kind=dp), INTENT(IN) :: step
2555 TYPE(section_vals_type), INTENT(IN), POINTER :: xc_fun_section
2556 LOGICAL, INTENT(IN) :: lsd
2557 TYPE(xc_rho_set_type), INTENT(INOUT) :: rho2_set
2558 TYPE(xc_derivative_set_type) :: deriv_set1
2559
2560 CHARACTER(len=*), PARAMETER :: routinen = 'get_derivs_rho'
2561
2562 INTEGER :: handle
2563
2564 CALL timeset(routinen, handle)
2565
2566 ! Copy the densities, do one step into the direction of drho
2567!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(norm_drho,norm_drho2,step)
2568 norm_drho2 = norm_drho*(1.0_dp + step)
2569!$OMP END PARALLEL WORKSHARE
2570
2571 CALL xc_dset_zero_all(deriv_set1)
2572
2573 ! Calculate the derivatives of the functional
2574 CALL xc_functionals_eval(xc_fun_section, &
2575 lsd=lsd, &
2576 rho_set=rho2_set, &
2577 deriv_set=deriv_set1, &
2578 deriv_order=1)
2579
2580 ! Return to the original values
2581!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(norm_drho,norm_drho2)
2582 norm_drho2 = norm_drho
2583!$OMP END PARALLEL WORKSHARE
2584
2585 CALL divide_by_norm_drho(deriv_set1, rho2_set, lsd)
2586
2587 CALL timestop(handle)
2588
2589 END SUBROUTINE get_derivs_rho
2590
2591! **************************************************************************************************
2592!> \brief Calculates the second derivative of E_xc at rho in the direction
2593!> rho1 (if you see the second derivative as bilinear form)
2594!> partial_rho|_(rho=rho) partial_rho|_(rho=rho) E_xc drho(rho1)drho
2595!> The other direction is still undetermined, thus it returns
2596!> a potential (partial integration is performed to reduce it to
2597!> function of rho, removing the dependence from its partial derivs)
2598!> Has to be called after the setup by xc_prep_2nd_deriv.
2599!> \param v_xc exchange-correlation potential
2600!> \param v_xc_tau ...
2601!> \param deriv_set derivatives of the exchange-correlation potential
2602!> \param rho_set object containing the density at which the derivatives were calculated
2603!> \param rho1_set object containing the density with which to fold
2604!> \param pw_pool the pool for the grids
2605!> \param xc_section XC parameters
2606!> \param gapw Gaussian and augmented plane waves calculation
2607!> \param vxg ...
2608!> \param tddfpt_fac factor that multiplies the crossterms (tddfpt triplets
2609!> on a closed shell system it should be -1, defaults to 1)
2610!> \param compute_virial ...
2611!> \param virial_xc ...
2612!> \note
2613!> The old version of this routine was smarter: it handled split_desc(1)
2614!> and split_desc(2) separately, thus the code automatically handled all
2615!> possible cross terms (you only had to check if it was diagonal to avoid
2616!> double counting). I think that is the way to go if you want to add more
2617!> terms (tau,rho in LSD,...). The problem with the old code was that it
2618!> because of the old functional structure it sometime guessed wrongly
2619!> which derivative was where. There were probably still bugs with gradient
2620!> corrected functionals (never tested), and it didn't contain first
2621!> derivatives with respect to drho (that contribute also to the second
2622!> derivative wrt. rho).
2623!> The code was a little complex because it really tried to handle any
2624!> functional derivative in the most efficient way with the given contents of
2625!> rho_set.
2626!> Anyway I strongly encourage whoever wants to modify this code to give a
2627!> look to the old version. [fawzi]
2628! **************************************************************************************************
2629 SUBROUTINE xc_calc_2nd_deriv_analytical(v_xc, v_xc_tau, deriv_set, rho_set, rho1_set, &
2630 pw_pool, xc_section, gapw, vxg, tddfpt_fac, &
2631 compute_virial, virial_xc)
2632
2633 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: v_xc, v_xc_tau
2634 TYPE(xc_derivative_set_type) :: deriv_set
2635 TYPE(xc_rho_set_type), INTENT(IN) :: rho_set, rho1_set
2636 TYPE(pw_pool_type), POINTER :: pw_pool
2637 TYPE(section_vals_type), POINTER :: xc_section
2638 LOGICAL, INTENT(IN), OPTIONAL :: gapw
2639 REAL(kind=dp), DIMENSION(:, :, :, :), OPTIONAL, &
2640 POINTER :: vxg
2641 REAL(kind=dp), INTENT(in), OPTIONAL :: tddfpt_fac
2642 LOGICAL, INTENT(IN), OPTIONAL :: compute_virial
2643 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT), &
2644 OPTIONAL :: virial_xc
2645
2646 CHARACTER(len=*), PARAMETER :: routinen = 'xc_calc_2nd_deriv_analytical'
2647
2648 INTEGER :: handle, i, ia, idir, ir, ispin, j, jdir, &
2649 k, nspins, xc_deriv_method_id
2650 INTEGER, DIMENSION(2, 3) :: bo
2651 LOGICAL :: gradient_f, lsd, my_compute_virial, &
2652 my_gapw, tau_f, laplace_f, rho_f
2653 REAL(kind=dp) :: fac, gradient_cut, tmp, factor2
2654 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :) :: dr1dr, dra1dra, drb1drb
2655 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data, e_drhoa, e_drhob, &
2656 e_drho, norm_drho, norm_drhoa, &
2657 norm_drhob, rho1, rho1a, rho1b, &
2658 tau1, tau1a, tau1b, laplace1, laplace1a, laplace1b, &
2659 rho, rhoa, rhob
2660 TYPE(cp_3d_r_cp_type), DIMENSION(3) :: drho, drho1, drho1a, drho1b, drhoa, drhob
2661 TYPE(pw_r3d_rs_type), DIMENSION(:), ALLOCATABLE :: v_drhoa, v_drhob, v_drho, v_laplace
2662 TYPE(pw_r3d_rs_type), DIMENSION(:, :), ALLOCATABLE :: v_drho_r
2663 TYPE(pw_r3d_rs_type) :: virial_pw
2664 TYPE(pw_c1d_gs_type) :: tmp_g, vxc_g
2665 TYPE(xc_derivative_type), POINTER :: deriv_att
2666
2667 CALL timeset(routinen, handle)
2668
2669 NULLIFY (e_drhoa, e_drhob, e_drho)
2670
2671 my_gapw = .false.
2672 IF (PRESENT(gapw)) my_gapw = gapw
2673
2674 my_compute_virial = .false.
2675 IF (PRESENT(compute_virial)) my_compute_virial = compute_virial
2676
2677 cpassert(ASSOCIATED(v_xc))
2678 cpassert(ASSOCIATED(xc_section))
2679 IF (my_gapw) THEN
2680 cpassert(PRESENT(vxg))
2681 END IF
2682 IF (my_compute_virial) THEN
2683 cpassert(PRESENT(virial_xc))
2684 END IF
2685
2686 CALL section_vals_val_get(xc_section, "XC_GRID%XC_DERIV", &
2687 i_val=xc_deriv_method_id)
2688 CALL xc_rho_set_get(rho_set, drho_cutoff=gradient_cut)
2689 nspins = SIZE(v_xc)
2690 lsd = ASSOCIATED(rho_set%rhoa)
2691 fac = 0.0_dp
2692 factor2 = 1.0_dp
2693 IF (PRESENT(tddfpt_fac)) fac = tddfpt_fac
2694 IF (PRESENT(tddfpt_fac)) factor2 = tddfpt_fac
2695
2696 bo = rho_set%local_bounds
2697
2698 CALL check_for_derivatives(deriv_set, lsd, rho_f, gradient_f, tau_f, laplace_f)
2699
2700 IF (tau_f) THEN
2701 cpassert(ASSOCIATED(v_xc_tau))
2702 END IF
2703
2704 IF (gradient_f) THEN
2705 ALLOCATE (v_drho_r(3, nspins), v_drho(nspins))
2706 DO ispin = 1, nspins
2707 DO idir = 1, 3
2708 CALL allocate_pw(v_drho_r(idir, ispin), pw_pool, bo)
2709 END DO
2710 CALL allocate_pw(v_drho(ispin), pw_pool, bo)
2711 END DO
2712
2713 IF (xc_requires_tmp_g(xc_deriv_method_id) .AND. .NOT. my_gapw) THEN
2714 IF (ASSOCIATED(pw_pool)) THEN
2715 CALL pw_pool%create_pw(tmp_g)
2716 CALL pw_pool%create_pw(vxc_g)
2717 ELSE
2718 ! remember to refix for gapw
2719 cpabort("XC_DERIV method is not implemented in GAPW")
2720 END IF
2721 END IF
2722 END IF
2723
2724 DO ispin = 1, nspins
2725 v_xc(ispin)%array = 0.0_dp
2726 END DO
2727
2728 IF (tau_f) THEN
2729 DO ispin = 1, nspins
2730 v_xc_tau(ispin)%array = 0.0_dp
2731 END DO
2732 END IF
2733
2734 IF (laplace_f .AND. my_gapw) &
2735 cpabort("Laplace-dependent functional not implemented with GAPW!")
2736
2737 IF (my_compute_virial .AND. (gradient_f .OR. laplace_f)) CALL allocate_pw(virial_pw, pw_pool, bo)
2738
2739 IF (lsd) THEN
2740
2741 !-------------------!
2742 ! UNrestricted case !
2743 !-------------------!
2744
2745 CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b)
2746
2747 IF (gradient_f) THEN
2748 CALL xc_rho_set_get(rho_set, drhoa=drhoa, drhob=drhob, &
2749 norm_drho=norm_drho, norm_drhoa=norm_drhoa, norm_drhob=norm_drhob)
2750 CALL xc_rho_set_get(rho1_set, drhoa=drho1a, drhob=drho1b)
2751
2752 CALL calc_drho_from_ab(drho, drhoa, drhob)
2753 CALL calc_drho_from_ab(drho1, drho1a, drho1b)
2754
2755 CALL prepare_dr1dr(dra1dra, drhoa, drho1a)
2756 IF (nspins /= 1) THEN
2757 CALL prepare_dr1dr(drb1drb, drhob, drho1b)
2758 CALL prepare_dr1dr(dr1dr, drho, drho1)
2759 ELSE
2760 CALL prepare_dr1dr(drb1drb, drhob, drho1b)
2761 CALL prepare_dr1dr_ab(dr1dr, drhoa, drhob, drho1a, drho1b, fac)
2762 END IF
2763
2764 ALLOCATE (v_drhoa(nspins), v_drhob(nspins))
2765 DO ispin = 1, nspins
2766 CALL allocate_pw(v_drhoa(ispin), pw_pool, bo)
2767 CALL allocate_pw(v_drhob(ispin), pw_pool, bo)
2768 END DO
2769
2770 END IF
2771
2772 IF (laplace_f) THEN
2773 CALL xc_rho_set_get(rho1_set, laplace_rhoa=laplace1a, laplace_rhob=laplace1b)
2774
2775 ALLOCATE (v_laplace(nspins))
2776 DO ispin = 1, nspins
2777 CALL allocate_pw(v_laplace(ispin), pw_pool, bo)
2778 END DO
2779
2780 IF (my_compute_virial) CALL xc_rho_set_get(rho_set, rhoa=rhoa, rhob=rhob)
2781 END IF
2782
2783 IF (tau_f) THEN
2784 CALL xc_rho_set_get(rho1_set, tau_a=tau1a, tau_b=tau1b)
2785 END IF
2786
2787 IF (nspins /= 1) THEN
2788
2789 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhoa])
2790 IF (ASSOCIATED(deriv_att)) THEN
2791 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2792!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2793!$OMP SHARED(bo,v_xc,deriv_data,rho1a,fac) COLLAPSE(3)
2794 DO k = bo(1, 3), bo(2, 3)
2795 DO j = bo(1, 2), bo(2, 2)
2796 DO i = bo(1, 1), bo(2, 1)
2797 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2798 deriv_data(i, j, k)*rho1a(i, j, k)
2799 END DO
2800 END DO
2801 END DO
2802 END IF
2803 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhob])
2804 IF (ASSOCIATED(deriv_att)) THEN
2805 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2806!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2807!$OMP SHARED(bo,v_xc,deriv_data,rho1b,fac) COLLAPSE(3)
2808 DO k = bo(1, 3), bo(2, 3)
2809 DO j = bo(1, 2), bo(2, 2)
2810 DO i = bo(1, 1), bo(2, 1)
2811 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2812 deriv_data(i, j, k)*rho1b(i, j, k)
2813 END DO
2814 END DO
2815 END DO
2816 END IF
2817 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drho])
2818 IF (ASSOCIATED(deriv_att)) THEN
2819 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2820!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2821!$OMP SHARED(bo,v_xc,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
2822 DO k = bo(1, 3), bo(2, 3)
2823 DO j = bo(1, 2), bo(2, 2)
2824 DO i = bo(1, 1), bo(2, 1)
2825 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2826 deriv_data(i, j, k)*dr1dr(i, j, k)
2827 END DO
2828 END DO
2829 END DO
2830 END IF
2831 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhoa])
2832 IF (ASSOCIATED(deriv_att)) THEN
2833 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2834!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2835!$OMP SHARED(bo,v_xc,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
2836 DO k = bo(1, 3), bo(2, 3)
2837 DO j = bo(1, 2), bo(2, 2)
2838 DO i = bo(1, 1), bo(2, 1)
2839 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2840 deriv_data(i, j, k)*dra1dra(i, j, k)
2841 END DO
2842 END DO
2843 END DO
2844 END IF
2845 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhob])
2846 IF (ASSOCIATED(deriv_att)) THEN
2847 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2848!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2849!$OMP SHARED(bo,v_xc,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
2850 DO k = bo(1, 3), bo(2, 3)
2851 DO j = bo(1, 2), bo(2, 2)
2852 DO i = bo(1, 1), bo(2, 1)
2853 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2854 deriv_data(i, j, k)*drb1drb(i, j, k)
2855 END DO
2856 END DO
2857 END DO
2858 END IF
2859 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_tau_a])
2860 IF (ASSOCIATED(deriv_att)) THEN
2861 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2862!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2863!$OMP SHARED(bo,v_xc,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
2864 DO k = bo(1, 3), bo(2, 3)
2865 DO j = bo(1, 2), bo(2, 2)
2866 DO i = bo(1, 1), bo(2, 1)
2867 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2868 deriv_data(i, j, k)*tau1a(i, j, k)
2869 END DO
2870 END DO
2871 END DO
2872 END IF
2873 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_tau_b])
2874 IF (ASSOCIATED(deriv_att)) THEN
2875 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2876!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2877!$OMP SHARED(bo,v_xc,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
2878 DO k = bo(1, 3), bo(2, 3)
2879 DO j = bo(1, 2), bo(2, 2)
2880 DO i = bo(1, 1), bo(2, 1)
2881 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2882 deriv_data(i, j, k)*tau1b(i, j, k)
2883 END DO
2884 END DO
2885 END DO
2886 END IF
2887 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_laplace_rhoa])
2888 IF (ASSOCIATED(deriv_att)) THEN
2889 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2890!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2891!$OMP SHARED(bo,v_xc,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
2892 DO k = bo(1, 3), bo(2, 3)
2893 DO j = bo(1, 2), bo(2, 2)
2894 DO i = bo(1, 1), bo(2, 1)
2895 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2896 deriv_data(i, j, k)*laplace1a(i, j, k)
2897 END DO
2898 END DO
2899 END DO
2900 END IF
2901 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_laplace_rhob])
2902 IF (ASSOCIATED(deriv_att)) THEN
2903 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2904!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2905!$OMP SHARED(bo,v_xc,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
2906 DO k = bo(1, 3), bo(2, 3)
2907 DO j = bo(1, 2), bo(2, 2)
2908 DO i = bo(1, 1), bo(2, 1)
2909 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2910 deriv_data(i, j, k)*laplace1b(i, j, k)
2911 END DO
2912 END DO
2913 END DO
2914 END IF
2915
2916
2917 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_rhoa])
2918 IF (ASSOCIATED(deriv_att)) THEN
2919 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2920!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2921!$OMP SHARED(bo,v_xc,deriv_data,rho1a,fac) COLLAPSE(3)
2922 DO k = bo(1, 3), bo(2, 3)
2923 DO j = bo(1, 2), bo(2, 2)
2924 DO i = bo(1, 1), bo(2, 1)
2925 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
2926 deriv_data(i, j, k)*rho1a(i, j, k)
2927 END DO
2928 END DO
2929 END DO
2930 END IF
2931 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_rhob])
2932 IF (ASSOCIATED(deriv_att)) THEN
2933 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2934!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2935!$OMP SHARED(bo,v_xc,deriv_data,rho1b,fac) COLLAPSE(3)
2936 DO k = bo(1, 3), bo(2, 3)
2937 DO j = bo(1, 2), bo(2, 2)
2938 DO i = bo(1, 1), bo(2, 1)
2939 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
2940 deriv_data(i, j, k)*rho1b(i, j, k)
2941 END DO
2942 END DO
2943 END DO
2944 END IF
2945 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_norm_drho])
2946 IF (ASSOCIATED(deriv_att)) THEN
2947 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2948!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2949!$OMP SHARED(bo,v_xc,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
2950 DO k = bo(1, 3), bo(2, 3)
2951 DO j = bo(1, 2), bo(2, 2)
2952 DO i = bo(1, 1), bo(2, 1)
2953 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
2954 deriv_data(i, j, k)*dr1dr(i, j, k)
2955 END DO
2956 END DO
2957 END DO
2958 END IF
2959 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_norm_drhoa])
2960 IF (ASSOCIATED(deriv_att)) THEN
2961 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2962!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2963!$OMP SHARED(bo,v_xc,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
2964 DO k = bo(1, 3), bo(2, 3)
2965 DO j = bo(1, 2), bo(2, 2)
2966 DO i = bo(1, 1), bo(2, 1)
2967 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
2968 deriv_data(i, j, k)*dra1dra(i, j, k)
2969 END DO
2970 END DO
2971 END DO
2972 END IF
2973 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_norm_drhob])
2974 IF (ASSOCIATED(deriv_att)) THEN
2975 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2976!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2977!$OMP SHARED(bo,v_xc,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
2978 DO k = bo(1, 3), bo(2, 3)
2979 DO j = bo(1, 2), bo(2, 2)
2980 DO i = bo(1, 1), bo(2, 1)
2981 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
2982 deriv_data(i, j, k)*drb1drb(i, j, k)
2983 END DO
2984 END DO
2985 END DO
2986 END IF
2987 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_tau_a])
2988 IF (ASSOCIATED(deriv_att)) THEN
2989 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2990!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2991!$OMP SHARED(bo,v_xc,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
2992 DO k = bo(1, 3), bo(2, 3)
2993 DO j = bo(1, 2), bo(2, 2)
2994 DO i = bo(1, 1), bo(2, 1)
2995 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
2996 deriv_data(i, j, k)*tau1a(i, j, k)
2997 END DO
2998 END DO
2999 END DO
3000 END IF
3001 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_tau_b])
3002 IF (ASSOCIATED(deriv_att)) THEN
3003 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3004!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3005!$OMP SHARED(bo,v_xc,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3006 DO k = bo(1, 3), bo(2, 3)
3007 DO j = bo(1, 2), bo(2, 2)
3008 DO i = bo(1, 1), bo(2, 1)
3009 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3010 deriv_data(i, j, k)*tau1b(i, j, k)
3011 END DO
3012 END DO
3013 END DO
3014 END IF
3015 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_laplace_rhoa])
3016 IF (ASSOCIATED(deriv_att)) THEN
3017 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3018!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3019!$OMP SHARED(bo,v_xc,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3020 DO k = bo(1, 3), bo(2, 3)
3021 DO j = bo(1, 2), bo(2, 2)
3022 DO i = bo(1, 1), bo(2, 1)
3023 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3024 deriv_data(i, j, k)*laplace1a(i, j, k)
3025 END DO
3026 END DO
3027 END DO
3028 END IF
3029 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_laplace_rhob])
3030 IF (ASSOCIATED(deriv_att)) THEN
3031 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3032!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3033!$OMP SHARED(bo,v_xc,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3034 DO k = bo(1, 3), bo(2, 3)
3035 DO j = bo(1, 2), bo(2, 2)
3036 DO i = bo(1, 1), bo(2, 1)
3037 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3038 deriv_data(i, j, k)*laplace1b(i, j, k)
3039 END DO
3040 END DO
3041 END DO
3042 END IF
3043
3044
3045 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rhoa])
3046 IF (ASSOCIATED(deriv_att)) THEN
3047 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3048!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3049!$OMP SHARED(bo,v_drho,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3050 DO k = bo(1, 3), bo(2, 3)
3051 DO j = bo(1, 2), bo(2, 2)
3052 DO i = bo(1, 1), bo(2, 1)
3053 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3054 deriv_data(i, j, k)*rho1a(i, j, k)
3055 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3056 deriv_data(i, j, k)*rho1a(i, j, k)
3057 END DO
3058 END DO
3059 END DO
3060 END IF
3061 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rhob])
3062 IF (ASSOCIATED(deriv_att)) THEN
3063 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3064!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3065!$OMP SHARED(bo,v_drho,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3066 DO k = bo(1, 3), bo(2, 3)
3067 DO j = bo(1, 2), bo(2, 2)
3068 DO i = bo(1, 1), bo(2, 1)
3069 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3070 deriv_data(i, j, k)*rho1b(i, j, k)
3071 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3072 deriv_data(i, j, k)*rho1b(i, j, k)
3073 END DO
3074 END DO
3075 END DO
3076 END IF
3077 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drho])
3078 IF (ASSOCIATED(deriv_att)) THEN
3079 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3080!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3081!$OMP SHARED(bo,v_drho,deriv_data,dr1dr,fac) COLLAPSE(3)
3082 DO k = bo(1, 3), bo(2, 3)
3083 DO j = bo(1, 2), bo(2, 2)
3084 DO i = bo(1, 1), bo(2, 1)
3085 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3086 deriv_data(i, j, k)*dr1dr(i, j, k)
3087 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3088 deriv_data(i, j, k)*dr1dr(i, j, k)
3089 END DO
3090 END DO
3091 END DO
3092 END IF
3093 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhoa])
3094 IF (ASSOCIATED(deriv_att)) THEN
3095 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3096!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3097!$OMP SHARED(bo,v_drho,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3098 DO k = bo(1, 3), bo(2, 3)
3099 DO j = bo(1, 2), bo(2, 2)
3100 DO i = bo(1, 1), bo(2, 1)
3101 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3102 deriv_data(i, j, k)*dra1dra(i, j, k)
3103 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3104 deriv_data(i, j, k)*dra1dra(i, j, k)
3105 END DO
3106 END DO
3107 END DO
3108 END IF
3109 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhob])
3110 IF (ASSOCIATED(deriv_att)) THEN
3111 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3112!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3113!$OMP SHARED(bo,v_drho,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3114 DO k = bo(1, 3), bo(2, 3)
3115 DO j = bo(1, 2), bo(2, 2)
3116 DO i = bo(1, 1), bo(2, 1)
3117 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3118 deriv_data(i, j, k)*drb1drb(i, j, k)
3119 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3120 deriv_data(i, j, k)*drb1drb(i, j, k)
3121 END DO
3122 END DO
3123 END DO
3124 END IF
3125 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_tau_a])
3126 IF (ASSOCIATED(deriv_att)) THEN
3127 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3128!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3129!$OMP SHARED(bo,v_drho,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3130 DO k = bo(1, 3), bo(2, 3)
3131 DO j = bo(1, 2), bo(2, 2)
3132 DO i = bo(1, 1), bo(2, 1)
3133 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3134 deriv_data(i, j, k)*tau1a(i, j, k)
3135 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3136 deriv_data(i, j, k)*tau1a(i, j, k)
3137 END DO
3138 END DO
3139 END DO
3140 END IF
3141 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_tau_b])
3142 IF (ASSOCIATED(deriv_att)) THEN
3143 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3144!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3145!$OMP SHARED(bo,v_drho,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3146 DO k = bo(1, 3), bo(2, 3)
3147 DO j = bo(1, 2), bo(2, 2)
3148 DO i = bo(1, 1), bo(2, 1)
3149 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3150 deriv_data(i, j, k)*tau1b(i, j, k)
3151 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3152 deriv_data(i, j, k)*tau1b(i, j, k)
3153 END DO
3154 END DO
3155 END DO
3156 END IF
3157 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_laplace_rhoa])
3158 IF (ASSOCIATED(deriv_att)) THEN
3159 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3160!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3161!$OMP SHARED(bo,v_drho,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3162 DO k = bo(1, 3), bo(2, 3)
3163 DO j = bo(1, 2), bo(2, 2)
3164 DO i = bo(1, 1), bo(2, 1)
3165 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3166 deriv_data(i, j, k)*laplace1a(i, j, k)
3167 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3168 deriv_data(i, j, k)*laplace1a(i, j, k)
3169 END DO
3170 END DO
3171 END DO
3172 END IF
3173 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_laplace_rhob])
3174 IF (ASSOCIATED(deriv_att)) THEN
3175 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3176!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3177!$OMP SHARED(bo,v_drho,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3178 DO k = bo(1, 3), bo(2, 3)
3179 DO j = bo(1, 2), bo(2, 2)
3180 DO i = bo(1, 1), bo(2, 1)
3181 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3182 deriv_data(i, j, k)*laplace1b(i, j, k)
3183 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3184 deriv_data(i, j, k)*laplace1b(i, j, k)
3185 END DO
3186 END DO
3187 END DO
3188 END IF
3189
3190 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho])
3191 IF (ASSOCIATED(deriv_att)) THEN
3192 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3193 CALL xc_derivative_get(deriv_att, deriv_data=e_drho)
3194
3195 IF (my_compute_virial) THEN
3196 CALL virial_drho_drho1(virial_pw, drho, drho1, deriv_data, virial_xc)
3197 END IF ! my_compute_virial
3198
3199!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,gradient_cut,norm_drho,v_drho,deriv_data)
3200 v_drho(1)%array(:, :, :) = v_drho(1)%array(:, :, :) + &
3201 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
3202 v_drho(2)%array(:, :, :) = v_drho(2)%array(:, :, :) + &
3203 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
3204!$OMP END PARALLEL WORKSHARE
3205 END IF
3206
3207 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhoa])
3208 IF (ASSOCIATED(deriv_att)) THEN
3209 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3210!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3211!$OMP SHARED(bo,v_drhoa,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3212 DO k = bo(1, 3), bo(2, 3)
3213 DO j = bo(1, 2), bo(2, 2)
3214 DO i = bo(1, 1), bo(2, 1)
3215 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3216 deriv_data(i, j, k)*rho1a(i, j, k)
3217 END DO
3218 END DO
3219 END DO
3220 END IF
3221 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhob])
3222 IF (ASSOCIATED(deriv_att)) THEN
3223 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3224!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3225!$OMP SHARED(bo,v_drhoa,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3226 DO k = bo(1, 3), bo(2, 3)
3227 DO j = bo(1, 2), bo(2, 2)
3228 DO i = bo(1, 1), bo(2, 1)
3229 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3230 deriv_data(i, j, k)*rho1b(i, j, k)
3231 END DO
3232 END DO
3233 END DO
3234 END IF
3235 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drho])
3236 IF (ASSOCIATED(deriv_att)) THEN
3237 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3238!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3239!$OMP SHARED(bo,v_drhoa,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3240 DO k = bo(1, 3), bo(2, 3)
3241 DO j = bo(1, 2), bo(2, 2)
3242 DO i = bo(1, 1), bo(2, 1)
3243 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3244 deriv_data(i, j, k)*dr1dr(i, j, k)
3245 END DO
3246 END DO
3247 END DO
3248 END IF
3249 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhoa])
3250 IF (ASSOCIATED(deriv_att)) THEN
3251 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3252!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3253!$OMP SHARED(bo,v_drhoa,deriv_data,dra1dra,fac) COLLAPSE(3)
3254 DO k = bo(1, 3), bo(2, 3)
3255 DO j = bo(1, 2), bo(2, 2)
3256 DO i = bo(1, 1), bo(2, 1)
3257 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3258 deriv_data(i, j, k)*dra1dra(i, j, k)
3259 END DO
3260 END DO
3261 END DO
3262 END IF
3263 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhob])
3264 IF (ASSOCIATED(deriv_att)) THEN
3265 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3266!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3267!$OMP SHARED(bo,v_drhoa,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3268 DO k = bo(1, 3), bo(2, 3)
3269 DO j = bo(1, 2), bo(2, 2)
3270 DO i = bo(1, 1), bo(2, 1)
3271 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3272 deriv_data(i, j, k)*drb1drb(i, j, k)
3273 END DO
3274 END DO
3275 END DO
3276 END IF
3277 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_tau_a])
3278 IF (ASSOCIATED(deriv_att)) THEN
3279 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3280!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3281!$OMP SHARED(bo,v_drhoa,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3282 DO k = bo(1, 3), bo(2, 3)
3283 DO j = bo(1, 2), bo(2, 2)
3284 DO i = bo(1, 1), bo(2, 1)
3285 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3286 deriv_data(i, j, k)*tau1a(i, j, k)
3287 END DO
3288 END DO
3289 END DO
3290 END IF
3291 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_tau_b])
3292 IF (ASSOCIATED(deriv_att)) THEN
3293 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3294!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3295!$OMP SHARED(bo,v_drhoa,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3296 DO k = bo(1, 3), bo(2, 3)
3297 DO j = bo(1, 2), bo(2, 2)
3298 DO i = bo(1, 1), bo(2, 1)
3299 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3300 deriv_data(i, j, k)*tau1b(i, j, k)
3301 END DO
3302 END DO
3303 END DO
3304 END IF
3305 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_laplace_rhoa])
3306 IF (ASSOCIATED(deriv_att)) THEN
3307 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3308!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3309!$OMP SHARED(bo,v_drhoa,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3310 DO k = bo(1, 3), bo(2, 3)
3311 DO j = bo(1, 2), bo(2, 2)
3312 DO i = bo(1, 1), bo(2, 1)
3313 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3314 deriv_data(i, j, k)*laplace1a(i, j, k)
3315 END DO
3316 END DO
3317 END DO
3318 END IF
3319 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_laplace_rhob])
3320 IF (ASSOCIATED(deriv_att)) THEN
3321 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3322!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3323!$OMP SHARED(bo,v_drhoa,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3324 DO k = bo(1, 3), bo(2, 3)
3325 DO j = bo(1, 2), bo(2, 2)
3326 DO i = bo(1, 1), bo(2, 1)
3327 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3328 deriv_data(i, j, k)*laplace1b(i, j, k)
3329 END DO
3330 END DO
3331 END DO
3332 END IF
3333
3334 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa])
3335 IF (ASSOCIATED(deriv_att)) THEN
3336 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3337 CALL xc_derivative_get(deriv_att, deriv_data=e_drhoa)
3338
3339 IF (my_compute_virial) THEN
3340 CALL virial_drho_drho1(virial_pw, drhoa, drho1a, deriv_data, virial_xc)
3341 END IF ! my_compute_virial
3342
3343!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dra1dra,gradient_cut,norm_drhoa,v_drhoa,deriv_data)
3344 v_drhoa(1)%array(:, :, :) = v_drhoa(1)%array(:, :, :) + &
3345 deriv_data(:, :, :)*dra1dra(:, :, :)/max(gradient_cut, norm_drhoa(:, :, :))**2
3346!$OMP END PARALLEL WORKSHARE
3347 END IF
3348
3349 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_rhoa])
3350 IF (ASSOCIATED(deriv_att)) THEN
3351 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3352!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3353!$OMP SHARED(bo,v_drhob,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3354 DO k = bo(1, 3), bo(2, 3)
3355 DO j = bo(1, 2), bo(2, 2)
3356 DO i = bo(1, 1), bo(2, 1)
3357 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3358 deriv_data(i, j, k)*rho1a(i, j, k)
3359 END DO
3360 END DO
3361 END DO
3362 END IF
3363 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_rhob])
3364 IF (ASSOCIATED(deriv_att)) THEN
3365 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3366!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3367!$OMP SHARED(bo,v_drhob,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3368 DO k = bo(1, 3), bo(2, 3)
3369 DO j = bo(1, 2), bo(2, 2)
3370 DO i = bo(1, 1), bo(2, 1)
3371 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3372 deriv_data(i, j, k)*rho1b(i, j, k)
3373 END DO
3374 END DO
3375 END DO
3376 END IF
3377 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_norm_drho])
3378 IF (ASSOCIATED(deriv_att)) THEN
3379 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3380!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3381!$OMP SHARED(bo,v_drhob,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3382 DO k = bo(1, 3), bo(2, 3)
3383 DO j = bo(1, 2), bo(2, 2)
3384 DO i = bo(1, 1), bo(2, 1)
3385 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3386 deriv_data(i, j, k)*dr1dr(i, j, k)
3387 END DO
3388 END DO
3389 END DO
3390 END IF
3391 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_norm_drhoa])
3392 IF (ASSOCIATED(deriv_att)) THEN
3393 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3394!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3395!$OMP SHARED(bo,v_drhob,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3396 DO k = bo(1, 3), bo(2, 3)
3397 DO j = bo(1, 2), bo(2, 2)
3398 DO i = bo(1, 1), bo(2, 1)
3399 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3400 deriv_data(i, j, k)*dra1dra(i, j, k)
3401 END DO
3402 END DO
3403 END DO
3404 END IF
3405 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_norm_drhob])
3406 IF (ASSOCIATED(deriv_att)) THEN
3407 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3408!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3409!$OMP SHARED(bo,v_drhob,deriv_data,drb1drb,fac) COLLAPSE(3)
3410 DO k = bo(1, 3), bo(2, 3)
3411 DO j = bo(1, 2), bo(2, 2)
3412 DO i = bo(1, 1), bo(2, 1)
3413 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3414 deriv_data(i, j, k)*drb1drb(i, j, k)
3415 END DO
3416 END DO
3417 END DO
3418 END IF
3419 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_tau_a])
3420 IF (ASSOCIATED(deriv_att)) THEN
3421 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3422!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3423!$OMP SHARED(bo,v_drhob,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3424 DO k = bo(1, 3), bo(2, 3)
3425 DO j = bo(1, 2), bo(2, 2)
3426 DO i = bo(1, 1), bo(2, 1)
3427 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3428 deriv_data(i, j, k)*tau1a(i, j, k)
3429 END DO
3430 END DO
3431 END DO
3432 END IF
3433 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_tau_b])
3434 IF (ASSOCIATED(deriv_att)) THEN
3435 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3436!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3437!$OMP SHARED(bo,v_drhob,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3438 DO k = bo(1, 3), bo(2, 3)
3439 DO j = bo(1, 2), bo(2, 2)
3440 DO i = bo(1, 1), bo(2, 1)
3441 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3442 deriv_data(i, j, k)*tau1b(i, j, k)
3443 END DO
3444 END DO
3445 END DO
3446 END IF
3447 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_laplace_rhoa])
3448 IF (ASSOCIATED(deriv_att)) THEN
3449 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3450!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3451!$OMP SHARED(bo,v_drhob,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3452 DO k = bo(1, 3), bo(2, 3)
3453 DO j = bo(1, 2), bo(2, 2)
3454 DO i = bo(1, 1), bo(2, 1)
3455 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3456 deriv_data(i, j, k)*laplace1a(i, j, k)
3457 END DO
3458 END DO
3459 END DO
3460 END IF
3461 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_laplace_rhob])
3462 IF (ASSOCIATED(deriv_att)) THEN
3463 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3464!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3465!$OMP SHARED(bo,v_drhob,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3466 DO k = bo(1, 3), bo(2, 3)
3467 DO j = bo(1, 2), bo(2, 2)
3468 DO i = bo(1, 1), bo(2, 1)
3469 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3470 deriv_data(i, j, k)*laplace1b(i, j, k)
3471 END DO
3472 END DO
3473 END DO
3474 END IF
3475
3476 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob])
3477 IF (ASSOCIATED(deriv_att)) THEN
3478 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3479 CALL xc_derivative_get(deriv_att, deriv_data=e_drhob)
3480
3481 IF (my_compute_virial) THEN
3482 CALL virial_drho_drho1(virial_pw, drhob, drho1b, deriv_data, virial_xc)
3483 END IF ! my_compute_virial
3484
3485!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drb1drb,gradient_cut,norm_drhob,v_drhob,deriv_data)
3486 v_drhob(2)%array(:, :, :) = v_drhob(2)%array(:, :, :) + &
3487 deriv_data(:, :, :)*drb1drb(:, :, :)/max(gradient_cut, norm_drhob(:, :, :))**2
3488!$OMP END PARALLEL WORKSHARE
3489 END IF
3490
3491 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_rhoa])
3492 IF (ASSOCIATED(deriv_att)) THEN
3493 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3494!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3495!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3496 DO k = bo(1, 3), bo(2, 3)
3497 DO j = bo(1, 2), bo(2, 2)
3498 DO i = bo(1, 1), bo(2, 1)
3499 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3500 deriv_data(i, j, k)*rho1a(i, j, k)
3501 END DO
3502 END DO
3503 END DO
3504 END IF
3505 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_rhob])
3506 IF (ASSOCIATED(deriv_att)) THEN
3507 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3508!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3509!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3510 DO k = bo(1, 3), bo(2, 3)
3511 DO j = bo(1, 2), bo(2, 2)
3512 DO i = bo(1, 1), bo(2, 1)
3513 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3514 deriv_data(i, j, k)*rho1b(i, j, k)
3515 END DO
3516 END DO
3517 END DO
3518 END IF
3519 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drho])
3520 IF (ASSOCIATED(deriv_att)) THEN
3521 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3522!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3523!$OMP SHARED(bo,v_xc_tau,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3524 DO k = bo(1, 3), bo(2, 3)
3525 DO j = bo(1, 2), bo(2, 2)
3526 DO i = bo(1, 1), bo(2, 1)
3527 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3528 deriv_data(i, j, k)*dr1dr(i, j, k)
3529 END DO
3530 END DO
3531 END DO
3532 END IF
3533 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drhoa])
3534 IF (ASSOCIATED(deriv_att)) THEN
3535 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3536!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3537!$OMP SHARED(bo,v_xc_tau,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3538 DO k = bo(1, 3), bo(2, 3)
3539 DO j = bo(1, 2), bo(2, 2)
3540 DO i = bo(1, 1), bo(2, 1)
3541 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3542 deriv_data(i, j, k)*dra1dra(i, j, k)
3543 END DO
3544 END DO
3545 END DO
3546 END IF
3547 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drhob])
3548 IF (ASSOCIATED(deriv_att)) THEN
3549 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3550!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3551!$OMP SHARED(bo,v_xc_tau,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3552 DO k = bo(1, 3), bo(2, 3)
3553 DO j = bo(1, 2), bo(2, 2)
3554 DO i = bo(1, 1), bo(2, 1)
3555 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3556 deriv_data(i, j, k)*drb1drb(i, j, k)
3557 END DO
3558 END DO
3559 END DO
3560 END IF
3561 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_tau_a])
3562 IF (ASSOCIATED(deriv_att)) THEN
3563 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3564!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3565!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1a,fac) COLLAPSE(3)
3566 DO k = bo(1, 3), bo(2, 3)
3567 DO j = bo(1, 2), bo(2, 2)
3568 DO i = bo(1, 1), bo(2, 1)
3569 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3570 deriv_data(i, j, k)*tau1a(i, j, k)
3571 END DO
3572 END DO
3573 END DO
3574 END IF
3575 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_tau_b])
3576 IF (ASSOCIATED(deriv_att)) THEN
3577 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3578!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3579!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1b,fac) COLLAPSE(3)
3580 DO k = bo(1, 3), bo(2, 3)
3581 DO j = bo(1, 2), bo(2, 2)
3582 DO i = bo(1, 1), bo(2, 1)
3583 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3584 deriv_data(i, j, k)*tau1b(i, j, k)
3585 END DO
3586 END DO
3587 END DO
3588 END IF
3589 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_laplace_rhoa])
3590 IF (ASSOCIATED(deriv_att)) THEN
3591 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3592!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3593!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3594 DO k = bo(1, 3), bo(2, 3)
3595 DO j = bo(1, 2), bo(2, 2)
3596 DO i = bo(1, 1), bo(2, 1)
3597 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3598 deriv_data(i, j, k)*laplace1a(i, j, k)
3599 END DO
3600 END DO
3601 END DO
3602 END IF
3603 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_laplace_rhob])
3604 IF (ASSOCIATED(deriv_att)) THEN
3605 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3606!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3607!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3608 DO k = bo(1, 3), bo(2, 3)
3609 DO j = bo(1, 2), bo(2, 2)
3610 DO i = bo(1, 1), bo(2, 1)
3611 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3612 deriv_data(i, j, k)*laplace1b(i, j, k)
3613 END DO
3614 END DO
3615 END DO
3616 END IF
3617
3618
3619 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_rhoa])
3620 IF (ASSOCIATED(deriv_att)) THEN
3621 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3622!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3623!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3624 DO k = bo(1, 3), bo(2, 3)
3625 DO j = bo(1, 2), bo(2, 2)
3626 DO i = bo(1, 1), bo(2, 1)
3627 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3628 deriv_data(i, j, k)*rho1a(i, j, k)
3629 END DO
3630 END DO
3631 END DO
3632 END IF
3633 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_rhob])
3634 IF (ASSOCIATED(deriv_att)) THEN
3635 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3636!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3637!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3638 DO k = bo(1, 3), bo(2, 3)
3639 DO j = bo(1, 2), bo(2, 2)
3640 DO i = bo(1, 1), bo(2, 1)
3641 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3642 deriv_data(i, j, k)*rho1b(i, j, k)
3643 END DO
3644 END DO
3645 END DO
3646 END IF
3647 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_norm_drho])
3648 IF (ASSOCIATED(deriv_att)) THEN
3649 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3650!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3651!$OMP SHARED(bo,v_xc_tau,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3652 DO k = bo(1, 3), bo(2, 3)
3653 DO j = bo(1, 2), bo(2, 2)
3654 DO i = bo(1, 1), bo(2, 1)
3655 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3656 deriv_data(i, j, k)*dr1dr(i, j, k)
3657 END DO
3658 END DO
3659 END DO
3660 END IF
3661 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_norm_drhoa])
3662 IF (ASSOCIATED(deriv_att)) THEN
3663 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3664!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3665!$OMP SHARED(bo,v_xc_tau,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3666 DO k = bo(1, 3), bo(2, 3)
3667 DO j = bo(1, 2), bo(2, 2)
3668 DO i = bo(1, 1), bo(2, 1)
3669 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3670 deriv_data(i, j, k)*dra1dra(i, j, k)
3671 END DO
3672 END DO
3673 END DO
3674 END IF
3675 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_norm_drhob])
3676 IF (ASSOCIATED(deriv_att)) THEN
3677 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3678!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3679!$OMP SHARED(bo,v_xc_tau,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3680 DO k = bo(1, 3), bo(2, 3)
3681 DO j = bo(1, 2), bo(2, 2)
3682 DO i = bo(1, 1), bo(2, 1)
3683 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3684 deriv_data(i, j, k)*drb1drb(i, j, k)
3685 END DO
3686 END DO
3687 END DO
3688 END IF
3689 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_tau_a])
3690 IF (ASSOCIATED(deriv_att)) THEN
3691 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3692!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3693!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1a,fac) COLLAPSE(3)
3694 DO k = bo(1, 3), bo(2, 3)
3695 DO j = bo(1, 2), bo(2, 2)
3696 DO i = bo(1, 1), bo(2, 1)
3697 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3698 deriv_data(i, j, k)*tau1a(i, j, k)
3699 END DO
3700 END DO
3701 END DO
3702 END IF
3703 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_tau_b])
3704 IF (ASSOCIATED(deriv_att)) THEN
3705 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3706!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3707!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1b,fac) COLLAPSE(3)
3708 DO k = bo(1, 3), bo(2, 3)
3709 DO j = bo(1, 2), bo(2, 2)
3710 DO i = bo(1, 1), bo(2, 1)
3711 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3712 deriv_data(i, j, k)*tau1b(i, j, k)
3713 END DO
3714 END DO
3715 END DO
3716 END IF
3717 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_laplace_rhoa])
3718 IF (ASSOCIATED(deriv_att)) THEN
3719 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3720!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3721!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3722 DO k = bo(1, 3), bo(2, 3)
3723 DO j = bo(1, 2), bo(2, 2)
3724 DO i = bo(1, 1), bo(2, 1)
3725 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3726 deriv_data(i, j, k)*laplace1a(i, j, k)
3727 END DO
3728 END DO
3729 END DO
3730 END IF
3731 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_laplace_rhob])
3732 IF (ASSOCIATED(deriv_att)) THEN
3733 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3734!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3735!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3736 DO k = bo(1, 3), bo(2, 3)
3737 DO j = bo(1, 2), bo(2, 2)
3738 DO i = bo(1, 1), bo(2, 1)
3739 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3740 deriv_data(i, j, k)*laplace1b(i, j, k)
3741 END DO
3742 END DO
3743 END DO
3744 END IF
3745
3746
3747 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_rhoa])
3748 IF (ASSOCIATED(deriv_att)) THEN
3749 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3750!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3751!$OMP SHARED(bo,v_laplace,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3752 DO k = bo(1, 3), bo(2, 3)
3753 DO j = bo(1, 2), bo(2, 2)
3754 DO i = bo(1, 1), bo(2, 1)
3755 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3756 deriv_data(i, j, k)*rho1a(i, j, k)
3757 END DO
3758 END DO
3759 END DO
3760 END IF
3761 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_rhob])
3762 IF (ASSOCIATED(deriv_att)) THEN
3763 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3764!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3765!$OMP SHARED(bo,v_laplace,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3766 DO k = bo(1, 3), bo(2, 3)
3767 DO j = bo(1, 2), bo(2, 2)
3768 DO i = bo(1, 1), bo(2, 1)
3769 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3770 deriv_data(i, j, k)*rho1b(i, j, k)
3771 END DO
3772 END DO
3773 END DO
3774 END IF
3775 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_norm_drho])
3776 IF (ASSOCIATED(deriv_att)) THEN
3777 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3778!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3779!$OMP SHARED(bo,v_laplace,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3780 DO k = bo(1, 3), bo(2, 3)
3781 DO j = bo(1, 2), bo(2, 2)
3782 DO i = bo(1, 1), bo(2, 1)
3783 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3784 deriv_data(i, j, k)*dr1dr(i, j, k)
3785 END DO
3786 END DO
3787 END DO
3788 END IF
3789 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_norm_drhoa])
3790 IF (ASSOCIATED(deriv_att)) THEN
3791 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3792!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3793!$OMP SHARED(bo,v_laplace,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3794 DO k = bo(1, 3), bo(2, 3)
3795 DO j = bo(1, 2), bo(2, 2)
3796 DO i = bo(1, 1), bo(2, 1)
3797 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3798 deriv_data(i, j, k)*dra1dra(i, j, k)
3799 END DO
3800 END DO
3801 END DO
3802 END IF
3803 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_norm_drhob])
3804 IF (ASSOCIATED(deriv_att)) THEN
3805 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3806!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3807!$OMP SHARED(bo,v_laplace,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3808 DO k = bo(1, 3), bo(2, 3)
3809 DO j = bo(1, 2), bo(2, 2)
3810 DO i = bo(1, 1), bo(2, 1)
3811 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3812 deriv_data(i, j, k)*drb1drb(i, j, k)
3813 END DO
3814 END DO
3815 END DO
3816 END IF
3817 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_tau_a])
3818 IF (ASSOCIATED(deriv_att)) THEN
3819 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3820!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3821!$OMP SHARED(bo,v_laplace,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3822 DO k = bo(1, 3), bo(2, 3)
3823 DO j = bo(1, 2), bo(2, 2)
3824 DO i = bo(1, 1), bo(2, 1)
3825 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3826 deriv_data(i, j, k)*tau1a(i, j, k)
3827 END DO
3828 END DO
3829 END DO
3830 END IF
3831 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_tau_b])
3832 IF (ASSOCIATED(deriv_att)) THEN
3833 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3834!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3835!$OMP SHARED(bo,v_laplace,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3836 DO k = bo(1, 3), bo(2, 3)
3837 DO j = bo(1, 2), bo(2, 2)
3838 DO i = bo(1, 1), bo(2, 1)
3839 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3840 deriv_data(i, j, k)*tau1b(i, j, k)
3841 END DO
3842 END DO
3843 END DO
3844 END IF
3845 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_laplace_rhoa])
3846 IF (ASSOCIATED(deriv_att)) THEN
3847 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3848!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3849!$OMP SHARED(bo,v_laplace,deriv_data,laplace1a,fac) COLLAPSE(3)
3850 DO k = bo(1, 3), bo(2, 3)
3851 DO j = bo(1, 2), bo(2, 2)
3852 DO i = bo(1, 1), bo(2, 1)
3853 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3854 deriv_data(i, j, k)*laplace1a(i, j, k)
3855 END DO
3856 END DO
3857 END DO
3858 END IF
3859 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_laplace_rhob])
3860 IF (ASSOCIATED(deriv_att)) THEN
3861 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3862!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3863!$OMP SHARED(bo,v_laplace,deriv_data,laplace1b,fac) COLLAPSE(3)
3864 DO k = bo(1, 3), bo(2, 3)
3865 DO j = bo(1, 2), bo(2, 2)
3866 DO i = bo(1, 1), bo(2, 1)
3867 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3868 deriv_data(i, j, k)*laplace1b(i, j, k)
3869 END DO
3870 END DO
3871 END DO
3872 END IF
3873
3874
3875 IF (my_compute_virial) THEN
3876 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa])
3877 IF (ASSOCIATED(deriv_att)) THEN
3878 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3879
3880 virial_pw%array(:, :, :) = -rho1a(:, :, :)
3881 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
3882 END IF
3883 END IF ! my_compute_virial
3884 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_rhoa])
3885 IF (ASSOCIATED(deriv_att)) THEN
3886 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3887!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3888!$OMP SHARED(bo,v_laplace,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3889 DO k = bo(1, 3), bo(2, 3)
3890 DO j = bo(1, 2), bo(2, 2)
3891 DO i = bo(1, 1), bo(2, 1)
3892 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3893 deriv_data(i, j, k)*rho1a(i, j, k)
3894 END DO
3895 END DO
3896 END DO
3897 END IF
3898 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_rhob])
3899 IF (ASSOCIATED(deriv_att)) THEN
3900 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3901!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3902!$OMP SHARED(bo,v_laplace,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3903 DO k = bo(1, 3), bo(2, 3)
3904 DO j = bo(1, 2), bo(2, 2)
3905 DO i = bo(1, 1), bo(2, 1)
3906 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3907 deriv_data(i, j, k)*rho1b(i, j, k)
3908 END DO
3909 END DO
3910 END DO
3911 END IF
3912 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_norm_drho])
3913 IF (ASSOCIATED(deriv_att)) THEN
3914 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3915!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3916!$OMP SHARED(bo,v_laplace,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3917 DO k = bo(1, 3), bo(2, 3)
3918 DO j = bo(1, 2), bo(2, 2)
3919 DO i = bo(1, 1), bo(2, 1)
3920 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3921 deriv_data(i, j, k)*dr1dr(i, j, k)
3922 END DO
3923 END DO
3924 END DO
3925 END IF
3926 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_norm_drhoa])
3927 IF (ASSOCIATED(deriv_att)) THEN
3928 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3929!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3930!$OMP SHARED(bo,v_laplace,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3931 DO k = bo(1, 3), bo(2, 3)
3932 DO j = bo(1, 2), bo(2, 2)
3933 DO i = bo(1, 1), bo(2, 1)
3934 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3935 deriv_data(i, j, k)*dra1dra(i, j, k)
3936 END DO
3937 END DO
3938 END DO
3939 END IF
3940 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_norm_drhob])
3941 IF (ASSOCIATED(deriv_att)) THEN
3942 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3943!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3944!$OMP SHARED(bo,v_laplace,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3945 DO k = bo(1, 3), bo(2, 3)
3946 DO j = bo(1, 2), bo(2, 2)
3947 DO i = bo(1, 1), bo(2, 1)
3948 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3949 deriv_data(i, j, k)*drb1drb(i, j, k)
3950 END DO
3951 END DO
3952 END DO
3953 END IF
3954 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_tau_a])
3955 IF (ASSOCIATED(deriv_att)) THEN
3956 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3957!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3958!$OMP SHARED(bo,v_laplace,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3959 DO k = bo(1, 3), bo(2, 3)
3960 DO j = bo(1, 2), bo(2, 2)
3961 DO i = bo(1, 1), bo(2, 1)
3962 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3963 deriv_data(i, j, k)*tau1a(i, j, k)
3964 END DO
3965 END DO
3966 END DO
3967 END IF
3968 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_tau_b])
3969 IF (ASSOCIATED(deriv_att)) THEN
3970 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3971!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3972!$OMP SHARED(bo,v_laplace,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3973 DO k = bo(1, 3), bo(2, 3)
3974 DO j = bo(1, 2), bo(2, 2)
3975 DO i = bo(1, 1), bo(2, 1)
3976 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3977 deriv_data(i, j, k)*tau1b(i, j, k)
3978 END DO
3979 END DO
3980 END DO
3981 END IF
3982 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_laplace_rhoa])
3983 IF (ASSOCIATED(deriv_att)) THEN
3984 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3985!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3986!$OMP SHARED(bo,v_laplace,deriv_data,laplace1a,fac) COLLAPSE(3)
3987 DO k = bo(1, 3), bo(2, 3)
3988 DO j = bo(1, 2), bo(2, 2)
3989 DO i = bo(1, 1), bo(2, 1)
3990 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3991 deriv_data(i, j, k)*laplace1a(i, j, k)
3992 END DO
3993 END DO
3994 END DO
3995 END IF
3996 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_laplace_rhob])
3997 IF (ASSOCIATED(deriv_att)) THEN
3998 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3999!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4000!$OMP SHARED(bo,v_laplace,deriv_data,laplace1b,fac) COLLAPSE(3)
4001 DO k = bo(1, 3), bo(2, 3)
4002 DO j = bo(1, 2), bo(2, 2)
4003 DO i = bo(1, 1), bo(2, 1)
4004 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4005 deriv_data(i, j, k)*laplace1b(i, j, k)
4006 END DO
4007 END DO
4008 END DO
4009 END IF
4010
4011
4012 IF (my_compute_virial) THEN
4013 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob])
4014 IF (ASSOCIATED(deriv_att)) THEN
4015 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4016
4017 virial_pw%array(:, :, :) = -rho1b(:, :, :)
4018 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
4019 END IF
4020 END IF ! my_compute_virial
4021
4022
4023 ELSE
4024
4025 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhoa])
4026 IF (ASSOCIATED(deriv_att)) THEN
4027 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4028!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4029!$OMP SHARED(bo,v_xc,deriv_data,rho1a,fac) COLLAPSE(3)
4030 DO k = bo(1, 3), bo(2, 3)
4031 DO j = bo(1, 2), bo(2, 2)
4032 DO i = bo(1, 1), bo(2, 1)
4033 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4034 deriv_data(i, j, k)*rho1a(i, j, k)
4035 END DO
4036 END DO
4037 END DO
4038 END IF
4039 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drho])
4040 IF (ASSOCIATED(deriv_att)) THEN
4041 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4042!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4043!$OMP SHARED(bo,v_xc,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4044 DO k = bo(1, 3), bo(2, 3)
4045 DO j = bo(1, 2), bo(2, 2)
4046 DO i = bo(1, 1), bo(2, 1)
4047 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4048 deriv_data(i, j, k)*dr1dr(i, j, k)
4049 END DO
4050 END DO
4051 END DO
4052 END IF
4053 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhoa])
4054 IF (ASSOCIATED(deriv_att)) THEN
4055 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4056!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4057!$OMP SHARED(bo,v_xc,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4058 DO k = bo(1, 3), bo(2, 3)
4059 DO j = bo(1, 2), bo(2, 2)
4060 DO i = bo(1, 1), bo(2, 1)
4061 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4062 deriv_data(i, j, k)*dra1dra(i, j, k)
4063 END DO
4064 END DO
4065 END DO
4066 END IF
4067 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_tau_a])
4068 IF (ASSOCIATED(deriv_att)) THEN
4069 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4070!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4071!$OMP SHARED(bo,v_xc,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
4072 DO k = bo(1, 3), bo(2, 3)
4073 DO j = bo(1, 2), bo(2, 2)
4074 DO i = bo(1, 1), bo(2, 1)
4075 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4076 deriv_data(i, j, k)*tau1a(i, j, k)
4077 END DO
4078 END DO
4079 END DO
4080 END IF
4081 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_laplace_rhoa])
4082 IF (ASSOCIATED(deriv_att)) THEN
4083 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4084!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4085!$OMP SHARED(bo,v_xc,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
4086 DO k = bo(1, 3), bo(2, 3)
4087 DO j = bo(1, 2), bo(2, 2)
4088 DO i = bo(1, 1), bo(2, 1)
4089 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4090 deriv_data(i, j, k)*laplace1a(i, j, k)
4091 END DO
4092 END DO
4093 END DO
4094 END IF
4095 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhob])
4096 IF (ASSOCIATED(deriv_att)) THEN
4097 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4098!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4099!$OMP SHARED(bo,v_xc,deriv_data,rho1b,fac) COLLAPSE(3)
4100 DO k = bo(1, 3), bo(2, 3)
4101 DO j = bo(1, 2), bo(2, 2)
4102 DO i = bo(1, 1), bo(2, 1)
4103 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4104 fac*deriv_data(i, j, k)*rho1b(i, j, k)
4105 END DO
4106 END DO
4107 END DO
4108 END IF
4109 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhob])
4110 IF (ASSOCIATED(deriv_att)) THEN
4111 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4112!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4113!$OMP SHARED(bo,v_xc,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4114 DO k = bo(1, 3), bo(2, 3)
4115 DO j = bo(1, 2), bo(2, 2)
4116 DO i = bo(1, 1), bo(2, 1)
4117 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4118 fac*deriv_data(i, j, k)*drb1drb(i, j, k)
4119 END DO
4120 END DO
4121 END DO
4122 END IF
4123 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_tau_b])
4124 IF (ASSOCIATED(deriv_att)) THEN
4125 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4126!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4127!$OMP SHARED(bo,v_xc,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
4128 DO k = bo(1, 3), bo(2, 3)
4129 DO j = bo(1, 2), bo(2, 2)
4130 DO i = bo(1, 1), bo(2, 1)
4131 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4132 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4133 END DO
4134 END DO
4135 END DO
4136 END IF
4137 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_laplace_rhob])
4138 IF (ASSOCIATED(deriv_att)) THEN
4139 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4140!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4141!$OMP SHARED(bo,v_xc,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
4142 DO k = bo(1, 3), bo(2, 3)
4143 DO j = bo(1, 2), bo(2, 2)
4144 DO i = bo(1, 1), bo(2, 1)
4145 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4146 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4147 END DO
4148 END DO
4149 END DO
4150 END IF
4151
4152
4153 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rhoa])
4154 IF (ASSOCIATED(deriv_att)) THEN
4155 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4156!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4157!$OMP SHARED(bo,v_drho,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
4158 DO k = bo(1, 3), bo(2, 3)
4159 DO j = bo(1, 2), bo(2, 2)
4160 DO i = bo(1, 1), bo(2, 1)
4161 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4162 deriv_data(i, j, k)*rho1a(i, j, k)
4163 END DO
4164 END DO
4165 END DO
4166 END IF
4167 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drho])
4168 IF (ASSOCIATED(deriv_att)) THEN
4169 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4170!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4171!$OMP SHARED(bo,v_drho,deriv_data,dr1dr,fac) COLLAPSE(3)
4172 DO k = bo(1, 3), bo(2, 3)
4173 DO j = bo(1, 2), bo(2, 2)
4174 DO i = bo(1, 1), bo(2, 1)
4175 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4176 deriv_data(i, j, k)*dr1dr(i, j, k)
4177 END DO
4178 END DO
4179 END DO
4180 END IF
4181 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhoa])
4182 IF (ASSOCIATED(deriv_att)) THEN
4183 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4184!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4185!$OMP SHARED(bo,v_drho,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4186 DO k = bo(1, 3), bo(2, 3)
4187 DO j = bo(1, 2), bo(2, 2)
4188 DO i = bo(1, 1), bo(2, 1)
4189 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4190 deriv_data(i, j, k)*dra1dra(i, j, k)
4191 END DO
4192 END DO
4193 END DO
4194 END IF
4195 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_tau_a])
4196 IF (ASSOCIATED(deriv_att)) THEN
4197 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4198!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4199!$OMP SHARED(bo,v_drho,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
4200 DO k = bo(1, 3), bo(2, 3)
4201 DO j = bo(1, 2), bo(2, 2)
4202 DO i = bo(1, 1), bo(2, 1)
4203 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4204 deriv_data(i, j, k)*tau1a(i, j, k)
4205 END DO
4206 END DO
4207 END DO
4208 END IF
4209 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_laplace_rhoa])
4210 IF (ASSOCIATED(deriv_att)) THEN
4211 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4212!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4213!$OMP SHARED(bo,v_drho,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
4214 DO k = bo(1, 3), bo(2, 3)
4215 DO j = bo(1, 2), bo(2, 2)
4216 DO i = bo(1, 1), bo(2, 1)
4217 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4218 deriv_data(i, j, k)*laplace1a(i, j, k)
4219 END DO
4220 END DO
4221 END DO
4222 END IF
4223 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rhob])
4224 IF (ASSOCIATED(deriv_att)) THEN
4225 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4226!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4227!$OMP SHARED(bo,v_drho,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
4228 DO k = bo(1, 3), bo(2, 3)
4229 DO j = bo(1, 2), bo(2, 2)
4230 DO i = bo(1, 1), bo(2, 1)
4231 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4232 fac*deriv_data(i, j, k)*rho1b(i, j, k)
4233 END DO
4234 END DO
4235 END DO
4236 END IF
4237 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhob])
4238 IF (ASSOCIATED(deriv_att)) THEN
4239 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4240!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4241!$OMP SHARED(bo,v_drho,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4242 DO k = bo(1, 3), bo(2, 3)
4243 DO j = bo(1, 2), bo(2, 2)
4244 DO i = bo(1, 1), bo(2, 1)
4245 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4246 fac*deriv_data(i, j, k)*drb1drb(i, j, k)
4247 END DO
4248 END DO
4249 END DO
4250 END IF
4251 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_tau_b])
4252 IF (ASSOCIATED(deriv_att)) THEN
4253 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4254!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4255!$OMP SHARED(bo,v_drho,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
4256 DO k = bo(1, 3), bo(2, 3)
4257 DO j = bo(1, 2), bo(2, 2)
4258 DO i = bo(1, 1), bo(2, 1)
4259 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4260 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4261 END DO
4262 END DO
4263 END DO
4264 END IF
4265 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_laplace_rhob])
4266 IF (ASSOCIATED(deriv_att)) THEN
4267 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4268!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4269!$OMP SHARED(bo,v_drho,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
4270 DO k = bo(1, 3), bo(2, 3)
4271 DO j = bo(1, 2), bo(2, 2)
4272 DO i = bo(1, 1), bo(2, 1)
4273 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4274 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4275 END DO
4276 END DO
4277 END DO
4278 END IF
4279
4280 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho])
4281 IF (ASSOCIATED(deriv_att)) THEN
4282 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4283 CALL xc_derivative_get(deriv_att, deriv_data=e_drho)
4284
4285
4286!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,gradient_cut,norm_drho,v_drho,deriv_data)
4287 v_drho(1)%array(:, :, :) = v_drho(1)%array(:, :, :) + &
4288 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
4289!$OMP END PARALLEL WORKSHARE
4290 END IF
4291
4292 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhoa])
4293 IF (ASSOCIATED(deriv_att)) THEN
4294 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4295!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4296!$OMP SHARED(bo,v_drhoa,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
4297 DO k = bo(1, 3), bo(2, 3)
4298 DO j = bo(1, 2), bo(2, 2)
4299 DO i = bo(1, 1), bo(2, 1)
4300 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4301 deriv_data(i, j, k)*rho1a(i, j, k)
4302 END DO
4303 END DO
4304 END DO
4305 END IF
4306 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drho])
4307 IF (ASSOCIATED(deriv_att)) THEN
4308 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4309!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4310!$OMP SHARED(bo,v_drhoa,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4311 DO k = bo(1, 3), bo(2, 3)
4312 DO j = bo(1, 2), bo(2, 2)
4313 DO i = bo(1, 1), bo(2, 1)
4314 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4315 deriv_data(i, j, k)*dr1dr(i, j, k)
4316 END DO
4317 END DO
4318 END DO
4319 END IF
4320 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhoa])
4321 IF (ASSOCIATED(deriv_att)) THEN
4322 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4323!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4324!$OMP SHARED(bo,v_drhoa,deriv_data,dra1dra,fac) COLLAPSE(3)
4325 DO k = bo(1, 3), bo(2, 3)
4326 DO j = bo(1, 2), bo(2, 2)
4327 DO i = bo(1, 1), bo(2, 1)
4328 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4329 deriv_data(i, j, k)*dra1dra(i, j, k)
4330 END DO
4331 END DO
4332 END DO
4333 END IF
4334 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_tau_a])
4335 IF (ASSOCIATED(deriv_att)) THEN
4336 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4337!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4338!$OMP SHARED(bo,v_drhoa,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
4339 DO k = bo(1, 3), bo(2, 3)
4340 DO j = bo(1, 2), bo(2, 2)
4341 DO i = bo(1, 1), bo(2, 1)
4342 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4343 deriv_data(i, j, k)*tau1a(i, j, k)
4344 END DO
4345 END DO
4346 END DO
4347 END IF
4348 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_laplace_rhoa])
4349 IF (ASSOCIATED(deriv_att)) THEN
4350 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4351!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4352!$OMP SHARED(bo,v_drhoa,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
4353 DO k = bo(1, 3), bo(2, 3)
4354 DO j = bo(1, 2), bo(2, 2)
4355 DO i = bo(1, 1), bo(2, 1)
4356 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4357 deriv_data(i, j, k)*laplace1a(i, j, k)
4358 END DO
4359 END DO
4360 END DO
4361 END IF
4362 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhob])
4363 IF (ASSOCIATED(deriv_att)) THEN
4364 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4365!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4366!$OMP SHARED(bo,v_drhoa,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
4367 DO k = bo(1, 3), bo(2, 3)
4368 DO j = bo(1, 2), bo(2, 2)
4369 DO i = bo(1, 1), bo(2, 1)
4370 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4371 fac*deriv_data(i, j, k)*rho1b(i, j, k)
4372 END DO
4373 END DO
4374 END DO
4375 END IF
4376 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhob])
4377 IF (ASSOCIATED(deriv_att)) THEN
4378 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4379!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4380!$OMP SHARED(bo,v_drhoa,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4381 DO k = bo(1, 3), bo(2, 3)
4382 DO j = bo(1, 2), bo(2, 2)
4383 DO i = bo(1, 1), bo(2, 1)
4384 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4385 fac*deriv_data(i, j, k)*drb1drb(i, j, k)
4386 END DO
4387 END DO
4388 END DO
4389 END IF
4390 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_tau_b])
4391 IF (ASSOCIATED(deriv_att)) THEN
4392 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4393!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4394!$OMP SHARED(bo,v_drhoa,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
4395 DO k = bo(1, 3), bo(2, 3)
4396 DO j = bo(1, 2), bo(2, 2)
4397 DO i = bo(1, 1), bo(2, 1)
4398 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4399 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4400 END DO
4401 END DO
4402 END DO
4403 END IF
4404 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_laplace_rhob])
4405 IF (ASSOCIATED(deriv_att)) THEN
4406 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4407!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4408!$OMP SHARED(bo,v_drhoa,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
4409 DO k = bo(1, 3), bo(2, 3)
4410 DO j = bo(1, 2), bo(2, 2)
4411 DO i = bo(1, 1), bo(2, 1)
4412 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4413 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4414 END DO
4415 END DO
4416 END DO
4417 END IF
4418
4419 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa])
4420 IF (ASSOCIATED(deriv_att)) THEN
4421 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4422 CALL xc_derivative_get(deriv_att, deriv_data=e_drhoa)
4423
4424
4425!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dra1dra,gradient_cut,norm_drhoa,v_drhoa,deriv_data)
4426 v_drhoa(1)%array(:, :, :) = v_drhoa(1)%array(:, :, :) + &
4427 deriv_data(:, :, :)*dra1dra(:, :, :)/max(gradient_cut, norm_drhoa(:, :, :))**2
4428!$OMP END PARALLEL WORKSHARE
4429 END IF
4430
4431 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_rhoa])
4432 IF (ASSOCIATED(deriv_att)) THEN
4433 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4434!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4435!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
4436 DO k = bo(1, 3), bo(2, 3)
4437 DO j = bo(1, 2), bo(2, 2)
4438 DO i = bo(1, 1), bo(2, 1)
4439 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4440 deriv_data(i, j, k)*rho1a(i, j, k)
4441 END DO
4442 END DO
4443 END DO
4444 END IF
4445 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drho])
4446 IF (ASSOCIATED(deriv_att)) THEN
4447 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4448!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4449!$OMP SHARED(bo,v_xc_tau,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4450 DO k = bo(1, 3), bo(2, 3)
4451 DO j = bo(1, 2), bo(2, 2)
4452 DO i = bo(1, 1), bo(2, 1)
4453 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4454 deriv_data(i, j, k)*dr1dr(i, j, k)
4455 END DO
4456 END DO
4457 END DO
4458 END IF
4459 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drhoa])
4460 IF (ASSOCIATED(deriv_att)) THEN
4461 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4462!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4463!$OMP SHARED(bo,v_xc_tau,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4464 DO k = bo(1, 3), bo(2, 3)
4465 DO j = bo(1, 2), bo(2, 2)
4466 DO i = bo(1, 1), bo(2, 1)
4467 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4468 deriv_data(i, j, k)*dra1dra(i, j, k)
4469 END DO
4470 END DO
4471 END DO
4472 END IF
4473 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_tau_a])
4474 IF (ASSOCIATED(deriv_att)) THEN
4475 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4476!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4477!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1a,fac) COLLAPSE(3)
4478 DO k = bo(1, 3), bo(2, 3)
4479 DO j = bo(1, 2), bo(2, 2)
4480 DO i = bo(1, 1), bo(2, 1)
4481 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4482 deriv_data(i, j, k)*tau1a(i, j, k)
4483 END DO
4484 END DO
4485 END DO
4486 END IF
4487 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_laplace_rhoa])
4488 IF (ASSOCIATED(deriv_att)) THEN
4489 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4490!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4491!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
4492 DO k = bo(1, 3), bo(2, 3)
4493 DO j = bo(1, 2), bo(2, 2)
4494 DO i = bo(1, 1), bo(2, 1)
4495 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4496 deriv_data(i, j, k)*laplace1a(i, j, k)
4497 END DO
4498 END DO
4499 END DO
4500 END IF
4501 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_rhob])
4502 IF (ASSOCIATED(deriv_att)) THEN
4503 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4504!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4505!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
4506 DO k = bo(1, 3), bo(2, 3)
4507 DO j = bo(1, 2), bo(2, 2)
4508 DO i = bo(1, 1), bo(2, 1)
4509 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4510 fac*deriv_data(i, j, k)*rho1b(i, j, k)
4511 END DO
4512 END DO
4513 END DO
4514 END IF
4515 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drhob])
4516 IF (ASSOCIATED(deriv_att)) THEN
4517 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4518!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4519!$OMP SHARED(bo,v_xc_tau,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4520 DO k = bo(1, 3), bo(2, 3)
4521 DO j = bo(1, 2), bo(2, 2)
4522 DO i = bo(1, 1), bo(2, 1)
4523 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4524 fac*deriv_data(i, j, k)*drb1drb(i, j, k)
4525 END DO
4526 END DO
4527 END DO
4528 END IF
4529 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_tau_b])
4530 IF (ASSOCIATED(deriv_att)) THEN
4531 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4532!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4533!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1b,fac) COLLAPSE(3)
4534 DO k = bo(1, 3), bo(2, 3)
4535 DO j = bo(1, 2), bo(2, 2)
4536 DO i = bo(1, 1), bo(2, 1)
4537 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4538 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4539 END DO
4540 END DO
4541 END DO
4542 END IF
4543 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_laplace_rhob])
4544 IF (ASSOCIATED(deriv_att)) THEN
4545 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4546!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4547!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
4548 DO k = bo(1, 3), bo(2, 3)
4549 DO j = bo(1, 2), bo(2, 2)
4550 DO i = bo(1, 1), bo(2, 1)
4551 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4552 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4553 END DO
4554 END DO
4555 END DO
4556 END IF
4557
4558
4559 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_rhoa])
4560 IF (ASSOCIATED(deriv_att)) THEN
4561 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4562!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4563!$OMP SHARED(bo,v_laplace,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
4564 DO k = bo(1, 3), bo(2, 3)
4565 DO j = bo(1, 2), bo(2, 2)
4566 DO i = bo(1, 1), bo(2, 1)
4567 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4568 deriv_data(i, j, k)*rho1a(i, j, k)
4569 END DO
4570 END DO
4571 END DO
4572 END IF
4573 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_norm_drho])
4574 IF (ASSOCIATED(deriv_att)) THEN
4575 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4576!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4577!$OMP SHARED(bo,v_laplace,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4578 DO k = bo(1, 3), bo(2, 3)
4579 DO j = bo(1, 2), bo(2, 2)
4580 DO i = bo(1, 1), bo(2, 1)
4581 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4582 deriv_data(i, j, k)*dr1dr(i, j, k)
4583 END DO
4584 END DO
4585 END DO
4586 END IF
4587 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_norm_drhoa])
4588 IF (ASSOCIATED(deriv_att)) THEN
4589 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4590!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4591!$OMP SHARED(bo,v_laplace,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4592 DO k = bo(1, 3), bo(2, 3)
4593 DO j = bo(1, 2), bo(2, 2)
4594 DO i = bo(1, 1), bo(2, 1)
4595 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4596 deriv_data(i, j, k)*dra1dra(i, j, k)
4597 END DO
4598 END DO
4599 END DO
4600 END IF
4601 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_tau_a])
4602 IF (ASSOCIATED(deriv_att)) THEN
4603 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4604!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4605!$OMP SHARED(bo,v_laplace,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
4606 DO k = bo(1, 3), bo(2, 3)
4607 DO j = bo(1, 2), bo(2, 2)
4608 DO i = bo(1, 1), bo(2, 1)
4609 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4610 deriv_data(i, j, k)*tau1a(i, j, k)
4611 END DO
4612 END DO
4613 END DO
4614 END IF
4615 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_laplace_rhoa])
4616 IF (ASSOCIATED(deriv_att)) THEN
4617 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4618!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4619!$OMP SHARED(bo,v_laplace,deriv_data,laplace1a,fac) COLLAPSE(3)
4620 DO k = bo(1, 3), bo(2, 3)
4621 DO j = bo(1, 2), bo(2, 2)
4622 DO i = bo(1, 1), bo(2, 1)
4623 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4624 deriv_data(i, j, k)*laplace1a(i, j, k)
4625 END DO
4626 END DO
4627 END DO
4628 END IF
4629 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_rhob])
4630 IF (ASSOCIATED(deriv_att)) THEN
4631 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4632!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4633!$OMP SHARED(bo,v_laplace,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
4634 DO k = bo(1, 3), bo(2, 3)
4635 DO j = bo(1, 2), bo(2, 2)
4636 DO i = bo(1, 1), bo(2, 1)
4637 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4638 fac*deriv_data(i, j, k)*rho1b(i, j, k)
4639 END DO
4640 END DO
4641 END DO
4642 END IF
4643 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_norm_drhob])
4644 IF (ASSOCIATED(deriv_att)) THEN
4645 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4646!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4647!$OMP SHARED(bo,v_laplace,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4648 DO k = bo(1, 3), bo(2, 3)
4649 DO j = bo(1, 2), bo(2, 2)
4650 DO i = bo(1, 1), bo(2, 1)
4651 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4652 fac*deriv_data(i, j, k)*drb1drb(i, j, k)
4653 END DO
4654 END DO
4655 END DO
4656 END IF
4657 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_tau_b])
4658 IF (ASSOCIATED(deriv_att)) THEN
4659 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4660!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4661!$OMP SHARED(bo,v_laplace,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
4662 DO k = bo(1, 3), bo(2, 3)
4663 DO j = bo(1, 2), bo(2, 2)
4664 DO i = bo(1, 1), bo(2, 1)
4665 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4666 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4667 END DO
4668 END DO
4669 END DO
4670 END IF
4671 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_laplace_rhob])
4672 IF (ASSOCIATED(deriv_att)) THEN
4673 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4674!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4675!$OMP SHARED(bo,v_laplace,deriv_data,laplace1b,fac) COLLAPSE(3)
4676 DO k = bo(1, 3), bo(2, 3)
4677 DO j = bo(1, 2), bo(2, 2)
4678 DO i = bo(1, 1), bo(2, 1)
4679 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4680 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4681 END DO
4682 END DO
4683 END DO
4684 END IF
4685
4686
4687
4688
4689 END IF
4690
4691 IF (gradient_f) THEN
4692
4693 IF (my_compute_virial) THEN
4694 CALL virial_drho_drho(virial_pw, drhoa, v_drhoa(1), virial_xc)
4695 CALL virial_drho_drho(virial_pw, drhob, v_drhob(2), virial_xc)
4696 DO idir = 1, 3
4697!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,idir,v_drho,virial_pw)
4698 virial_pw%array(:, :, :) = drho(idir)%array(:, :, :)*(v_drho(1)%array(:, :, :) + v_drho(2)%array(:, :, :))
4699!$OMP END PARALLEL WORKSHARE
4700 DO jdir = 1, idir
4701 tmp = -0.5_dp*virial_pw%pw_grid%dvol*accurate_dot_product(virial_pw%array(:, :, :), &
4702 drho(jdir)%array(:, :, :))
4703 virial_xc(jdir, idir) = virial_xc(jdir, idir) + tmp
4704 virial_xc(idir, jdir) = virial_xc(jdir, idir)
4705 END DO
4706 END DO
4707 END IF ! my_compute_virial
4708
4709 IF (my_gapw) THEN
4710!$OMP PARALLEL DO DEFAULT(NONE) &
4711!$OMP PRIVATE(ia,idir,ispin,ir) &
4712!$OMP SHARED(bo,nspins,vxg,drhoa,drhob,v_drhoa,v_drhob,v_drho, &
4713!$OMP e_drhoa,e_drhob,e_drho,drho1a,drho1b,fac,drho,drho1) &
4714!$OMP COLLAPSE(3)
4715 DO ir = bo(1, 2), bo(2, 2)
4716 DO ia = bo(1, 1), bo(2, 1)
4717 DO idir = 1, 3
4718 DO ispin = 1, nspins
4719 vxg(idir, ia, ir, ispin) = &
4720 -(v_drhoa(ispin)%array(ia, ir, 1)*drhoa(idir)%array(ia, ir, 1) + &
4721 v_drhob(ispin)%array(ia, ir, 1)*drhob(idir)%array(ia, ir, 1) + &
4722 v_drho(ispin)%array(ia, ir, 1)*drho(idir)%array(ia, ir, 1))
4723 END DO
4724 IF (ASSOCIATED(e_drhoa)) THEN
4725 vxg(idir, ia, ir, 1) = vxg(idir, ia, ir, 1) + &
4726 e_drhoa(ia, ir, 1)*drho1a(idir)%array(ia, ir, 1)
4727 END IF
4728 IF (nspins /= 1 .AND. ASSOCIATED(e_drhob)) THEN
4729 vxg(idir, ia, ir, 2) = vxg(idir, ia, ir, 2) + &
4730 e_drhob(ia, ir, 1)*drho1b(idir)%array(ia, ir, 1)
4731 END IF
4732 IF (ASSOCIATED(e_drho)) THEN
4733 IF (nspins /= 1) THEN
4734 vxg(idir, ia, ir, 1) = vxg(idir, ia, ir, 1) + &
4735 e_drho(ia, ir, 1)*drho1(idir)%array(ia, ir, 1)
4736 vxg(idir, ia, ir, 2) = vxg(idir, ia, ir, 2) + &
4737 e_drho(ia, ir, 1)*drho1(idir)%array(ia, ir, 1)
4738 ELSE
4739 vxg(idir, ia, ir, 1) = vxg(idir, ia, ir, 1) + &
4740 e_drho(ia, ir, 1)*(drho1a(idir)%array(ia, ir, 1) + &
4741 fac*drho1b(idir)%array(ia, ir, 1))
4742 END IF
4743 END IF
4744 END DO
4745 END DO
4746 END DO
4747!$OMP END PARALLEL DO
4748 ELSE
4749
4750 ! partial integration
4751 DO idir = 1, 3
4752
4753 DO ispin = 1, nspins
4754!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(v_drho_r,v_drhoa,v_drhob,v_drho,drhoa,drhob,drho,ispin,idir)
4755 v_drho_r(idir, ispin)%array(:, :, :) = &
4756 v_drhoa(ispin)%array(:, :, :)*drhoa(idir)%array(:, :, :) + &
4757 v_drhob(ispin)%array(:, :, :)*drhob(idir)%array(:, :, :) + &
4758 v_drho(ispin)%array(:, :, :)*drho(idir)%array(:, :, :)
4759!$OMP END PARALLEL WORKSHARE
4760 END DO
4761 IF (ASSOCIATED(e_drhoa)) THEN
4762!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(v_drho_r,e_drhoa,drho1a,idir)
4763 v_drho_r(idir, 1)%array(:, :, :) = v_drho_r(idir, 1)%array(:, :, :) - &
4764 e_drhoa(:, :, :)*drho1a(idir)%array(:, :, :)
4765!$OMP END PARALLEL WORKSHARE
4766 END IF
4767 IF (nspins /= 1 .AND. ASSOCIATED(e_drhob)) THEN
4768!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(v_drho_r,e_drhob,drho1b,idir)
4769 v_drho_r(idir, 2)%array(:, :, :) = v_drho_r(idir, 2)%array(:, :, :) - &
4770 e_drhob(:, :, :)*drho1b(idir)%array(:, :, :)
4771!$OMP END PARALLEL WORKSHARE
4772 END IF
4773 IF (ASSOCIATED(e_drho)) THEN
4774!$OMP PARALLEL DO DEFAULT(NONE) &
4775!$OMP PRIVATE(k,j,i) &
4776!$OMP SHARED(bo,v_drho_r,e_drho,drho1a,drho1b,drho1,fac,idir,nspins) &
4777!$OMP COLLAPSE(3)
4778 DO k = bo(1, 3), bo(2, 3)
4779 DO j = bo(1, 2), bo(2, 2)
4780 DO i = bo(1, 1), bo(2, 1)
4781 IF (nspins /= 1) THEN
4782 v_drho_r(idir, 1)%array(i, j, k) = v_drho_r(idir, 1)%array(i, j, k) - &
4783 e_drho(i, j, k)*drho1(idir)%array(i, j, k)
4784 v_drho_r(idir, 2)%array(i, j, k) = v_drho_r(idir, 2)%array(i, j, k) - &
4785 e_drho(i, j, k)*drho1(idir)%array(i, j, k)
4786 ELSE
4787 v_drho_r(idir, 1)%array(i, j, k) = v_drho_r(idir, 1)%array(i, j, k) - &
4788 e_drho(i, j, k)*(drho1a(idir)%array(i, j, k) + &
4789 fac*drho1b(idir)%array(i, j, k))
4790 END IF
4791 END DO
4792 END DO
4793 END DO
4794!$OMP END PARALLEL DO
4795 END IF
4796 END DO
4797
4798 DO ispin = 1, nspins
4799 ! partial integration
4800 CALL xc_pw_divergence(xc_deriv_method_id, v_drho_r(:, ispin), tmp_g, vxc_g, v_xc(ispin))
4801 END DO ! ispin
4802
4803 END IF
4804
4805 DO idir = 1, 3
4806 DEALLOCATE (drho(idir)%array)
4807 DEALLOCATE (drho1(idir)%array)
4808 END DO
4809
4810 DO ispin = 1, nspins
4811 CALL deallocate_pw(v_drhoa(ispin), pw_pool)
4812 CALL deallocate_pw(v_drhob(ispin), pw_pool)
4813 END DO
4814
4815 DEALLOCATE (v_drhoa, v_drhob)
4816
4817 END IF ! gradient_f
4818
4819 IF (laplace_f .AND. my_compute_virial) THEN
4820 virial_pw%array(:, :, :) = -rhoa(:, :, :)
4821 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplace(1)%array)
4822 virial_pw%array(:, :, :) = -rhob(:, :, :)
4823 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplace(2)%array)
4824 END IF
4825
4826 ELSE
4827
4828 !-----------------!
4829 ! restricted case !
4830 !-----------------!
4831
4832 CALL xc_rho_set_get(rho1_set, rho=rho1)
4833
4834 IF (gradient_f) THEN
4835 CALL xc_rho_set_get(rho_set, drho=drho, norm_drho=norm_drho)
4836 CALL xc_rho_set_get(rho1_set, drho=drho1)
4837 CALL prepare_dr1dr(dr1dr, drho, drho1)
4838 END IF
4839
4840 IF (laplace_f) THEN
4841 CALL xc_rho_set_get(rho1_set, laplace_rho=laplace1)
4842
4843 ALLOCATE (v_laplace(nspins))
4844 DO ispin = 1, nspins
4845 CALL allocate_pw(v_laplace(ispin), pw_pool, bo)
4846 END DO
4847
4848 IF (my_compute_virial) CALL xc_rho_set_get(rho_set, rho=rho)
4849 END IF
4850
4851 IF (tau_f) THEN
4852 CALL xc_rho_set_get(rho1_set, tau=tau1)
4853 END IF
4854
4855 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rho, deriv_rho])
4856 IF (ASSOCIATED(deriv_att)) THEN
4857 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4858!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4859!$OMP SHARED(bo,v_xc,deriv_data,rho1,fac) COLLAPSE(3)
4860 DO k = bo(1, 3), bo(2, 3)
4861 DO j = bo(1, 2), bo(2, 2)
4862 DO i = bo(1, 1), bo(2, 1)
4863 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4864 deriv_data(i, j, k)*rho1(i, j, k)
4865 END DO
4866 END DO
4867 END DO
4868 END IF
4869 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rho, deriv_norm_drho])
4870 IF (ASSOCIATED(deriv_att)) THEN
4871 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4872!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4873!$OMP SHARED(bo,v_xc,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4874 DO k = bo(1, 3), bo(2, 3)
4875 DO j = bo(1, 2), bo(2, 2)
4876 DO i = bo(1, 1), bo(2, 1)
4877 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4878 deriv_data(i, j, k)*dr1dr(i, j, k)
4879 END DO
4880 END DO
4881 END DO
4882 END IF
4883 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rho, deriv_tau])
4884 IF (ASSOCIATED(deriv_att)) THEN
4885 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4886!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4887!$OMP SHARED(bo,v_xc,deriv_data,tau1,v_xc_tau,fac) COLLAPSE(3)
4888 DO k = bo(1, 3), bo(2, 3)
4889 DO j = bo(1, 2), bo(2, 2)
4890 DO i = bo(1, 1), bo(2, 1)
4891 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4892 deriv_data(i, j, k)*tau1(i, j, k)
4893 END DO
4894 END DO
4895 END DO
4896 END IF
4897 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rho, deriv_laplace_rho])
4898 IF (ASSOCIATED(deriv_att)) THEN
4899 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4900!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4901!$OMP SHARED(bo,v_xc,deriv_data,laplace1,v_laplace,fac) COLLAPSE(3)
4902 DO k = bo(1, 3), bo(2, 3)
4903 DO j = bo(1, 2), bo(2, 2)
4904 DO i = bo(1, 1), bo(2, 1)
4905 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4906 deriv_data(i, j, k)*laplace1(i, j, k)
4907 END DO
4908 END DO
4909 END DO
4910 END IF
4911
4912
4913 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rho])
4914 IF (ASSOCIATED(deriv_att)) THEN
4915 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4916!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4917!$OMP SHARED(bo,v_drho,deriv_data,rho1,v_xc,fac) COLLAPSE(3)
4918 DO k = bo(1, 3), bo(2, 3)
4919 DO j = bo(1, 2), bo(2, 2)
4920 DO i = bo(1, 1), bo(2, 1)
4921 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4922 deriv_data(i, j, k)*rho1(i, j, k)
4923 END DO
4924 END DO
4925 END DO
4926 END IF
4927 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drho])
4928 IF (ASSOCIATED(deriv_att)) THEN
4929 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4930!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4931!$OMP SHARED(bo,v_drho,deriv_data,dr1dr,fac) COLLAPSE(3)
4932 DO k = bo(1, 3), bo(2, 3)
4933 DO j = bo(1, 2), bo(2, 2)
4934 DO i = bo(1, 1), bo(2, 1)
4935 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4936 deriv_data(i, j, k)*dr1dr(i, j, k)
4937 END DO
4938 END DO
4939 END DO
4940 END IF
4941 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_tau])
4942 IF (ASSOCIATED(deriv_att)) THEN
4943 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4944!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4945!$OMP SHARED(bo,v_drho,deriv_data,tau1,v_xc_tau,fac) COLLAPSE(3)
4946 DO k = bo(1, 3), bo(2, 3)
4947 DO j = bo(1, 2), bo(2, 2)
4948 DO i = bo(1, 1), bo(2, 1)
4949 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4950 deriv_data(i, j, k)*tau1(i, j, k)
4951 END DO
4952 END DO
4953 END DO
4954 END IF
4955 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_laplace_rho])
4956 IF (ASSOCIATED(deriv_att)) THEN
4957 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4958!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4959!$OMP SHARED(bo,v_drho,deriv_data,laplace1,v_laplace,fac) COLLAPSE(3)
4960 DO k = bo(1, 3), bo(2, 3)
4961 DO j = bo(1, 2), bo(2, 2)
4962 DO i = bo(1, 1), bo(2, 1)
4963 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4964 deriv_data(i, j, k)*laplace1(i, j, k)
4965 END DO
4966 END DO
4967 END DO
4968 END IF
4969
4970 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho])
4971 IF (ASSOCIATED(deriv_att)) THEN
4972 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4973 CALL xc_derivative_get(deriv_att, deriv_data=e_drho)
4974
4975 IF (my_compute_virial) THEN
4976 CALL virial_drho_drho1(virial_pw, drho, drho1, deriv_data, virial_xc)
4977 END IF ! my_compute_virial
4978
4979!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,gradient_cut,norm_drho,v_drho,deriv_data)
4980 v_drho(1)%array(:, :, :) = v_drho(1)%array(:, :, :) + &
4981 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
4982!$OMP END PARALLEL WORKSHARE
4983 END IF
4984
4985 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau, deriv_rho])
4986 IF (ASSOCIATED(deriv_att)) THEN
4987 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4988!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4989!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1,v_xc,fac) COLLAPSE(3)
4990 DO k = bo(1, 3), bo(2, 3)
4991 DO j = bo(1, 2), bo(2, 2)
4992 DO i = bo(1, 1), bo(2, 1)
4993 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4994 deriv_data(i, j, k)*rho1(i, j, k)
4995 END DO
4996 END DO
4997 END DO
4998 END IF
4999 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau, deriv_norm_drho])
5000 IF (ASSOCIATED(deriv_att)) THEN
5001 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5002!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5003!$OMP SHARED(bo,v_xc_tau,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
5004 DO k = bo(1, 3), bo(2, 3)
5005 DO j = bo(1, 2), bo(2, 2)
5006 DO i = bo(1, 1), bo(2, 1)
5007 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
5008 deriv_data(i, j, k)*dr1dr(i, j, k)
5009 END DO
5010 END DO
5011 END DO
5012 END IF
5013 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau, deriv_tau])
5014 IF (ASSOCIATED(deriv_att)) THEN
5015 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5016!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5017!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1,fac) COLLAPSE(3)
5018 DO k = bo(1, 3), bo(2, 3)
5019 DO j = bo(1, 2), bo(2, 2)
5020 DO i = bo(1, 1), bo(2, 1)
5021 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
5022 deriv_data(i, j, k)*tau1(i, j, k)
5023 END DO
5024 END DO
5025 END DO
5026 END IF
5027 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau, deriv_laplace_rho])
5028 IF (ASSOCIATED(deriv_att)) THEN
5029 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5030!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5031!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1,v_laplace,fac) COLLAPSE(3)
5032 DO k = bo(1, 3), bo(2, 3)
5033 DO j = bo(1, 2), bo(2, 2)
5034 DO i = bo(1, 1), bo(2, 1)
5035 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
5036 deriv_data(i, j, k)*laplace1(i, j, k)
5037 END DO
5038 END DO
5039 END DO
5040 END IF
5041
5042
5043 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho, deriv_rho])
5044 IF (ASSOCIATED(deriv_att)) THEN
5045 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5046!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5047!$OMP SHARED(bo,v_laplace,deriv_data,rho1,v_xc,fac) COLLAPSE(3)
5048 DO k = bo(1, 3), bo(2, 3)
5049 DO j = bo(1, 2), bo(2, 2)
5050 DO i = bo(1, 1), bo(2, 1)
5051 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
5052 deriv_data(i, j, k)*rho1(i, j, k)
5053 END DO
5054 END DO
5055 END DO
5056 END IF
5057 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho, deriv_norm_drho])
5058 IF (ASSOCIATED(deriv_att)) THEN
5059 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5060!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5061!$OMP SHARED(bo,v_laplace,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
5062 DO k = bo(1, 3), bo(2, 3)
5063 DO j = bo(1, 2), bo(2, 2)
5064 DO i = bo(1, 1), bo(2, 1)
5065 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
5066 deriv_data(i, j, k)*dr1dr(i, j, k)
5067 END DO
5068 END DO
5069 END DO
5070 END IF
5071 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho, deriv_tau])
5072 IF (ASSOCIATED(deriv_att)) THEN
5073 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5074!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5075!$OMP SHARED(bo,v_laplace,deriv_data,tau1,v_xc_tau,fac) COLLAPSE(3)
5076 DO k = bo(1, 3), bo(2, 3)
5077 DO j = bo(1, 2), bo(2, 2)
5078 DO i = bo(1, 1), bo(2, 1)
5079 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
5080 deriv_data(i, j, k)*tau1(i, j, k)
5081 END DO
5082 END DO
5083 END DO
5084 END IF
5085 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho, deriv_laplace_rho])
5086 IF (ASSOCIATED(deriv_att)) THEN
5087 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5088!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5089!$OMP SHARED(bo,v_laplace,deriv_data,laplace1,fac) COLLAPSE(3)
5090 DO k = bo(1, 3), bo(2, 3)
5091 DO j = bo(1, 2), bo(2, 2)
5092 DO i = bo(1, 1), bo(2, 1)
5093 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
5094 deriv_data(i, j, k)*laplace1(i, j, k)
5095 END DO
5096 END DO
5097 END DO
5098 END IF
5099
5100
5101 IF (my_compute_virial) THEN
5102 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho])
5103 IF (ASSOCIATED(deriv_att)) THEN
5104 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5105
5106 virial_pw%array(:, :, :) = -rho1(:, :, :)
5107 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
5108 END IF
5109 END IF ! my_compute_virial
5110
5111
5112 IF (gradient_f) THEN
5113
5114 IF (my_compute_virial) THEN
5115 CALL virial_drho_drho(virial_pw, drho, v_drho(1), virial_xc)
5116 END IF ! my_compute_virial
5117
5118 IF (my_gapw) THEN
5119
5120 DO idir = 1, 3
5121!$OMP PARALLEL DO DEFAULT(NONE) &
5122!$OMP PRIVATE(ia,ir) &
5123!$OMP SHARED(bo,vxg,drho,v_drho,e_drho,drho1,idir,factor2) &
5124!$OMP COLLAPSE(2)
5125 DO ia = bo(1, 1), bo(2, 1)
5126 DO ir = bo(1, 2), bo(2, 2)
5127 vxg(idir, ia, ir, 1) = -drho(idir)%array(ia, ir, 1)*v_drho(1)%array(ia, ir, 1)
5128 IF (ASSOCIATED(e_drho)) THEN
5129 vxg(idir, ia, ir, 1) = vxg(idir, ia, ir, 1) + factor2*drho1(idir)%array(ia, ir, 1)*e_drho(ia, ir, 1)
5130 END IF
5131 END DO
5132 END DO
5133!$OMP END PARALLEL DO
5134 END DO
5135
5136 ELSE
5137 ! partial integration
5138 DO idir = 1, 3
5139!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(v_drho_r,drho,v_drho,drho1,e_drho,idir)
5140 v_drho_r(idir, 1)%array(:, :, :) = drho(idir)%array(:, :, :)*v_drho(1)%array(:, :, :) - &
5141 drho1(idir)%array(:, :, :)*e_drho(:, :, :)
5142!$OMP END PARALLEL WORKSHARE
5143 END DO
5144
5145 CALL xc_pw_divergence(xc_deriv_method_id, v_drho_r(:, 1), tmp_g, vxc_g, v_xc(1))
5146 END IF
5147
5148 END IF
5149
5150 IF (laplace_f .AND. my_compute_virial) THEN
5151 virial_pw%array(:, :, :) = -rho(:, :, :)
5152 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplace(1)%array)
5153 END IF
5154
5155 END IF
5156
5157 IF (laplace_f) THEN
5158 DO ispin = 1, nspins
5159 CALL xc_pw_laplace(v_laplace(ispin), pw_pool, xc_deriv_method_id)
5160 CALL pw_axpy(v_laplace(ispin), v_xc(ispin))
5161 END DO
5162 END IF
5163
5164 IF (gradient_f) THEN
5165
5166 DO ispin = 1, nspins
5167 CALL deallocate_pw(v_drho(ispin), pw_pool)
5168 DO idir = 1, 3
5169 CALL deallocate_pw(v_drho_r(idir, ispin), pw_pool)
5170 END DO
5171 END DO
5172 DEALLOCATE (v_drho, v_drho_r)
5173
5174 END IF
5175
5176 IF (laplace_f) THEN
5177 DO ispin = 1, nspins
5178 CALL deallocate_pw(v_laplace(ispin), pw_pool)
5179 END DO
5180 DEALLOCATE (v_laplace)
5181 END IF
5182
5183 IF (ASSOCIATED(tmp_g%pw_grid) .AND. ASSOCIATED(pw_pool)) THEN
5184 CALL pw_pool%give_back_pw(tmp_g)
5185 END IF
5186
5187 IF (ASSOCIATED(vxc_g%pw_grid) .AND. ASSOCIATED(pw_pool)) THEN
5188 CALL pw_pool%give_back_pw(vxc_g)
5189 END IF
5190
5191 IF (my_compute_virial .AND. (gradient_f .OR. laplace_f)) THEN
5192 CALL deallocate_pw(virial_pw, pw_pool)
5193 END IF
5194
5195 CALL timestop(handle)
5196
5197 END SUBROUTINE xc_calc_2nd_deriv_analytical
5198
5199! **************************************************************************************************
5200!> \brief allocates grids using pw_pool (if associated) or with bounds
5201!> \param pw ...
5202!> \param pw_pool ...
5203!> \param bo ...
5204! **************************************************************************************************
5205 SUBROUTINE allocate_pw(pw, pw_pool, bo)
5206 TYPE(pw_r3d_rs_type), INTENT(OUT) :: pw
5207 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
5208 INTEGER, DIMENSION(2, 3), INTENT(IN) :: bo
5209
5210 IF (ASSOCIATED(pw_pool)) THEN
5211 CALL pw_pool%create_pw(pw)
5212 CALL pw_zero(pw)
5213 ELSE
5214 ALLOCATE (pw%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), bo(1, 3):bo(2, 3)))
5215 pw%array = 0.0_dp
5216 END IF
5217
5218 END SUBROUTINE allocate_pw
5219
5220! **************************************************************************************************
5221!> \brief deallocates grid allocated with allocate_pw
5222!> \param pw ...
5223!> \param pw_pool ...
5224! **************************************************************************************************
5225 SUBROUTINE deallocate_pw(pw, pw_pool)
5226 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw
5227 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
5228
5229 IF (ASSOCIATED(pw_pool)) THEN
5230 CALL pw_pool%give_back_pw(pw)
5231 ELSE
5232 CALL pw%release()
5233 END IF
5234
5235 END SUBROUTINE deallocate_pw
5236
5237! **************************************************************************************************
5238!> \brief updates virial from first derivative w.r.t. norm_drho
5239!> \param virial_pw ...
5240!> \param drho ...
5241!> \param drho1 ...
5242!> \param deriv_data ...
5243!> \param virial_xc ...
5244! **************************************************************************************************
5245 SUBROUTINE virial_drho_drho1(virial_pw, drho, drho1, deriv_data, virial_xc)
5246 TYPE(pw_r3d_rs_type), INTENT(IN) :: virial_pw
5247 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drho, drho1
5248 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: deriv_data
5249 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT) :: virial_xc
5250
5251 INTEGER :: idir, jdir
5252 REAL(kind=dp) :: tmp
5253
5254 DO idir = 1, 3
5255!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,idir,virial_pw,deriv_data)
5256 virial_pw%array(:, :, :) = drho(idir)%array(:, :, :)*deriv_data(:, :, :)
5257!$OMP END PARALLEL WORKSHARE
5258 DO jdir = 1, 3
5259 tmp = virial_pw%pw_grid%dvol*accurate_dot_product(virial_pw%array(:, :, :), &
5260 drho1(jdir)%array(:, :, :))
5261 virial_xc(jdir, idir) = virial_xc(jdir, idir) + tmp
5262 virial_xc(idir, jdir) = virial_xc(idir, jdir) + tmp
5263 END DO
5264 END DO
5265
5266 END SUBROUTINE virial_drho_drho1
5267
5268! **************************************************************************************************
5269!> \brief Adds virial contribution from second order potential parts
5270!> \param virial_pw ...
5271!> \param drho ...
5272!> \param v_drho ...
5273!> \param virial_xc ...
5274! **************************************************************************************************
5275 SUBROUTINE virial_drho_drho(virial_pw, drho, v_drho, virial_xc)
5276 TYPE(pw_r3d_rs_type), INTENT(IN) :: virial_pw
5277 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drho
5278 TYPE(pw_r3d_rs_type), INTENT(IN) :: v_drho
5279 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT) :: virial_xc
5280
5281 INTEGER :: idir, jdir
5282 REAL(kind=dp) :: tmp
5283
5284 DO idir = 1, 3
5285!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,idir,v_drho,virial_pw)
5286 virial_pw%array(:, :, :) = drho(idir)%array(:, :, :)*v_drho%array(:, :, :)
5287!$OMP END PARALLEL WORKSHARE
5288 DO jdir = 1, idir
5289 tmp = -virial_pw%pw_grid%dvol*accurate_dot_product(virial_pw%array(:, :, :), &
5290 drho(jdir)%array(:, :, :))
5291 virial_xc(jdir, idir) = virial_xc(jdir, idir) + tmp
5292 virial_xc(idir, jdir) = virial_xc(jdir, idir)
5293 END DO
5294 END DO
5295
5296 END SUBROUTINE virial_drho_drho
5297
5298! **************************************************************************************************
5299!> \brief ...
5300!> \param rho_r ...
5301!> \param pw_pool ...
5302!> \param virial_xc ...
5303!> \param deriv_data ...
5304! **************************************************************************************************
5305 SUBROUTINE virial_laplace(rho_r, pw_pool, virial_xc, deriv_data)
5306 TYPE(pw_r3d_rs_type), TARGET :: rho_r
5307 TYPE(pw_pool_type), POINTER, INTENT(IN) :: pw_pool
5308 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT) :: virial_xc
5309 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: deriv_data
5310
5311 CHARACTER(len=*), PARAMETER :: routinen = 'virial_laplace'
5312
5313 INTEGER :: handle, idir, jdir
5314 TYPE(pw_r3d_rs_type), POINTER :: virial_pw
5315 TYPE(pw_c1d_gs_type), POINTER :: tmp_g, rho_g
5316 INTEGER, DIMENSION(3) :: my_deriv
5317
5318 CALL timeset(routinen, handle)
5319
5320 NULLIFY (virial_pw, tmp_g, rho_g)
5321 ALLOCATE (virial_pw, tmp_g, rho_g)
5322 CALL pw_pool%create_pw(virial_pw)
5323 CALL pw_pool%create_pw(tmp_g)
5324 CALL pw_pool%create_pw(rho_g)
5325 CALL pw_zero(virial_pw)
5326 CALL pw_transfer(rho_r, rho_g)
5327 DO idir = 1, 3
5328 DO jdir = idir, 3
5329 CALL pw_copy(rho_g, tmp_g)
5330
5331 my_deriv = 0
5332 my_deriv(idir) = 1
5333 my_deriv(jdir) = my_deriv(jdir) + 1
5334
5335 CALL pw_derive(tmp_g, my_deriv)
5336 CALL pw_transfer(tmp_g, virial_pw)
5337 virial_xc(idir, jdir) = virial_xc(idir, jdir) - 2.0_dp*virial_pw%pw_grid%dvol* &
5338 accurate_dot_product(virial_pw%array(:, :, :), &
5339 deriv_data(:, :, :))
5340 virial_xc(jdir, idir) = virial_xc(idir, jdir)
5341 END DO
5342 END DO
5343 CALL pw_pool%give_back_pw(virial_pw)
5344 CALL pw_pool%give_back_pw(tmp_g)
5345 CALL pw_pool%give_back_pw(rho_g)
5346 DEALLOCATE (virial_pw, tmp_g, rho_g)
5347
5348 CALL timestop(handle)
5349
5350 END SUBROUTINE virial_laplace
5351
5352! **************************************************************************************************
5353!> \brief Prepare objects for the calculation of the 2nd derivatives of the density functional.
5354!> The calculation must then be performed with xc_calc_2nd_deriv.
5355!> \param deriv_set object containing the XC derivatives (out)
5356!> \param rho_set object that will contain the density at which the
5357!> derivatives were calculated
5358!> \param rho_r the place where you evaluate the derivative
5359!> \param pw_pool the pool for the grids
5360!> \param xc_section which functional should be used and how to calculate it
5361!> \param tau_r kinetic energy density in real space
5362! **************************************************************************************************
5363 SUBROUTINE xc_prep_2nd_deriv(deriv_set, &
5364 rho_set, rho_r, pw_pool, xc_section, tau_r)
5365
5366 TYPE(xc_derivative_set_type) :: deriv_set
5367 TYPE(xc_rho_set_type) :: rho_set
5368 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r
5369 TYPE(pw_pool_type), POINTER :: pw_pool
5370 TYPE(section_vals_type), POINTER :: xc_section
5371 TYPE(pw_r3d_rs_type), DIMENSION(:), OPTIONAL, POINTER :: tau_r
5372
5373 CHARACTER(len=*), PARAMETER :: routinen = 'xc_prep_2nd_deriv'
5374
5375 INTEGER :: handle, nspins
5376 LOGICAL :: lsd
5377 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
5378 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: tau
5379
5380 CALL timeset(routinen, handle)
5381
5382 cpassert(ASSOCIATED(xc_section))
5383 cpassert(ASSOCIATED(pw_pool))
5384
5385 nspins = SIZE(rho_r)
5386 lsd = (nspins /= 1)
5387
5388 NULLIFY (rho_g, tau)
5389 IF (PRESENT(tau_r)) &
5390 tau => tau_r
5391
5392 IF (section_get_lval(xc_section, "2ND_DERIV_ANALYTICAL")) THEN
5393 CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 2, &
5394 rho_r, rho_g, tau, xc_section, pw_pool, &
5395 calc_potential=.true.)
5396 ELSE
5397 CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 1, &
5398 rho_r, rho_g, tau, xc_section, pw_pool, &
5399 calc_potential=.true.)
5400 END IF
5401
5402 CALL timestop(handle)
5403
5404 END SUBROUTINE xc_prep_2nd_deriv
5405
5406! **************************************************************************************************
5407!> \brief divides derivatives from deriv_set by norm_drho
5408!> \param deriv_set ...
5409!> \param rho_set ...
5410!> \param lsd ...
5411! **************************************************************************************************
5412 SUBROUTINE divide_by_norm_drho(deriv_set, rho_set, lsd)
5413
5414 TYPE(xc_derivative_set_type), INTENT(INOUT) :: deriv_set
5415 TYPE(xc_rho_set_type), INTENT(IN) :: rho_set
5416 LOGICAL, INTENT(IN) :: lsd
5417
5418 INTEGER, DIMENSION(:), POINTER :: split_desc
5419 INTEGER :: idesc
5420 INTEGER, DIMENSION(2, 3) :: bo
5421 REAL(kind=dp) :: drho_cutoff
5422 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: norm_drho, norm_drhoa, norm_drhob
5423 TYPE(cp_3d_r_cp_type), DIMENSION(3) :: drho, drhoa, drhob
5424 TYPE(cp_sll_xc_deriv_type), POINTER :: pos
5425 TYPE(xc_derivative_type), POINTER :: deriv_att
5426
5427! check for unknown derivatives and divide by norm_drho where necessary
5428
5429 bo = rho_set%local_bounds
5430 CALL xc_rho_set_get(rho_set, drho_cutoff=drho_cutoff, norm_drho=norm_drho, &
5431 norm_drhoa=norm_drhoa, norm_drhob=norm_drhob, &
5432 drho=drho, drhoa=drhoa, drhob=drhob, can_return_null=.true.)
5433
5434 pos => deriv_set%derivs
5435 DO WHILE (cp_sll_xc_deriv_next(pos, el_att=deriv_att))
5436 CALL xc_derivative_get(deriv_att, split_desc=split_desc)
5437 DO idesc = 1, SIZE(split_desc)
5438 SELECT CASE (split_desc(idesc))
5439 CASE (deriv_norm_drho)
5440 IF (ASSOCIATED(norm_drho)) THEN
5441!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,norm_drho,drho_cutoff)
5442 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
5443 max(norm_drho(:, :, :), drho_cutoff)
5444!$OMP END PARALLEL WORKSHARE
5445 ELSE IF (ASSOCIATED(drho(1)%array)) THEN
5446!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,drho,drho_cutoff)
5447 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
5448 max(sqrt(drho(1)%array(:, :, :)**2 + &
5449 drho(2)%array(:, :, :)**2 + &
5450 drho(3)%array(:, :, :)**2), drho_cutoff)
5451!$OMP END PARALLEL WORKSHARE
5452 ELSE IF (ASSOCIATED(drhoa(1)%array) .AND. ASSOCIATED(drhob(1)%array)) THEN
5453!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,drhoa,drhob,drho_cutoff)
5454 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
5455 max(sqrt((drhoa(1)%array(:, :, :) + drhob(1)%array(:, :, :))**2 + &
5456 (drhoa(2)%array(:, :, :) + drhob(2)%array(:, :, :))**2 + &
5457 (drhoa(3)%array(:, :, :) + drhob(3)%array(:, :, :))**2), drho_cutoff)
5458!$OMP END PARALLEL WORKSHARE
5459 ELSE
5460 cpabort("Normalization of derivative requires any of norm_drho, drho or drhoa+drhob!")
5461 END IF
5462 CASE (deriv_norm_drhoa)
5463 IF (ASSOCIATED(norm_drhoa)) THEN
5464!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,norm_drhoa,drho_cutoff)
5465 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
5466 max(norm_drhoa(:, :, :), drho_cutoff)
5467!$OMP END PARALLEL WORKSHARE
5468 ELSE IF (ASSOCIATED(drhoa(1)%array)) THEN
5469!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,drhoa,drho_cutoff)
5470 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
5471 max(sqrt(drhoa(1)%array(:, :, :)**2 + &
5472 drhoa(2)%array(:, :, :)**2 + &
5473 drhoa(3)%array(:, :, :)**2), drho_cutoff)
5474!$OMP END PARALLEL WORKSHARE
5475 ELSE
5476 cpabort("Normalization of derivative requires any of norm_drhoa or drhoa!")
5477 END IF
5478 CASE (deriv_norm_drhob)
5479 IF (ASSOCIATED(norm_drhob)) THEN
5480!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,norm_drhob,drho_cutoff)
5481 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
5482 max(norm_drhob(:, :, :), drho_cutoff)
5483!$OMP END PARALLEL WORKSHARE
5484 ELSE IF (ASSOCIATED(drhob(1)%array)) THEN
5485!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,drhob,drho_cutoff)
5486 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
5487 max(sqrt(drhob(1)%array(:, :, :)**2 + &
5488 drhob(2)%array(:, :, :)**2 + &
5489 drhob(3)%array(:, :, :)**2), drho_cutoff)
5490!$OMP END PARALLEL WORKSHARE
5491 ELSE
5492 cpabort("Normalization of derivative requires any of norm_drhob or drhob!")
5493 END IF
5494 CASE (deriv_rho, deriv_tau, deriv_laplace_rho)
5495 IF (lsd) &
5496 cpabort(trim(id_to_desc(split_desc(idesc)))//" not handled in lsd!'")
5497 CASE (deriv_rhoa, deriv_rhob, deriv_tau_a, deriv_tau_b, deriv_laplace_rhoa, deriv_laplace_rhob)
5498 CASE default
5499 cpabort("Unknown derivative id")
5500 END SELECT
5501 END DO
5502 END DO
5503
5504 END SUBROUTINE divide_by_norm_drho
5505
5506! **************************************************************************************************
5507!> \brief allocates and calculates drho from given spin densities drhoa, drhob
5508!> \param drho ...
5509!> \param drhoa ...
5510!> \param drhob ...
5511! **************************************************************************************************
5512 SUBROUTINE calc_drho_from_ab(drho, drhoa, drhob)
5513 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(OUT) :: drho
5514 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drhoa, drhob
5515
5516 CHARACTER(len=*), PARAMETER :: routinen = 'calc_drho_from_ab'
5517
5518 INTEGER :: handle, idir
5519
5520 CALL timeset(routinen, handle)
5521
5522 DO idir = 1, 3
5523 NULLIFY (drho(idir)%array)
5524 ALLOCATE (drho(idir)%array(lbound(drhoa(1)%array, 1):ubound(drhoa(1)%array, 1), &
5525 lbound(drhoa(1)%array, 2):ubound(drhoa(1)%array, 2), &
5526 lbound(drhoa(1)%array, 3):ubound(drhoa(1)%array, 3)))
5527!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,drhoa,drhob,idir)
5528 drho(idir)%array(:, :, :) = drhoa(idir)%array(:, :, :) + drhob(idir)%array(:, :, :)
5529!$OMP END PARALLEL WORKSHARE
5530 END DO
5531
5532 CALL timestop(handle)
5533
5534 END SUBROUTINE calc_drho_from_ab
5535
5536! **************************************************************************************************
5537!> \brief allocates and calculates dot products of two density gradients
5538!> \param dr1dr ...
5539!> \param drho ...
5540!> \param drho1 ...
5541! **************************************************************************************************
5542 SUBROUTINE prepare_dr1dr(dr1dr, drho, drho1)
5543 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :), &
5544 INTENT(OUT) :: dr1dr
5545 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drho, drho1
5546
5547 CHARACTER(len=*), PARAMETER :: routinen = 'prepare_dr1dr'
5548
5549 INTEGER :: handle, idir
5550
5551 CALL timeset(routinen, handle)
5552
5553 ALLOCATE (dr1dr(lbound(drho(1)%array, 1):ubound(drho(1)%array, 1), &
5554 lbound(drho(1)%array, 2):ubound(drho(1)%array, 2), &
5555 lbound(drho(1)%array, 3):ubound(drho(1)%array, 3)))
5556
5557!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,drho,drho1)
5558 dr1dr(:, :, :) = drho(1)%array(:, :, :)*drho1(1)%array(:, :, :)
5559!$OMP END PARALLEL WORKSHARE
5560 DO idir = 2, 3
5561!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,drho,drho1,idir)
5562 dr1dr(:, :, :) = dr1dr(:, :, :) + drho(idir)%array(:, :, :)*drho1(idir)%array(:, :, :)
5563!$OMP END PARALLEL WORKSHARE
5564 END DO
5565
5566 CALL timestop(handle)
5567
5568 END SUBROUTINE prepare_dr1dr
5569
5570! **************************************************************************************************
5571!> \brief allocates and calculates dot product of two densities for triplets
5572!> \param dr1dr ...
5573!> \param drhoa ...
5574!> \param drhob ...
5575!> \param drho1a ...
5576!> \param drho1b ...
5577!> \param fac ...
5578! **************************************************************************************************
5579 SUBROUTINE prepare_dr1dr_ab(dr1dr, drhoa, drhob, drho1a, drho1b, fac)
5580 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :), &
5581 INTENT(OUT) :: dr1dr
5582 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drhoa, drhob, drho1a, drho1b
5583 REAL(kind=dp), INTENT(IN) :: fac
5584
5585 CHARACTER(len=*), PARAMETER :: routinen = 'prepare_dr1dr_ab'
5586
5587 INTEGER :: handle, idir
5588
5589 CALL timeset(routinen, handle)
5590
5591 ALLOCATE (dr1dr(lbound(drhoa(1)%array, 1):ubound(drhoa(1)%array, 1), &
5592 lbound(drhoa(1)%array, 2):ubound(drhoa(1)%array, 2), &
5593 lbound(drhoa(1)%array, 3):ubound(drhoa(1)%array, 3)))
5594
5595!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(fac,dr1dr,drho1a,drho1b,drhoa,drhob)
5596 dr1dr(:, :, :) = drhoa(1)%array(:, :, :)*(drho1a(1)%array(:, :, :) + &
5597 fac*drho1b(1)%array(:, :, :)) + &
5598 drhob(1)%array(:, :, :)*(fac*drho1a(1)%array(:, :, :) + &
5599 drho1b(1)%array(:, :, :))
5600!$OMP END PARALLEL WORKSHARE
5601 DO idir = 2, 3
5602!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(fac,dr1dr,drho1a,drho1b,drhoa,drhob,idir)
5603 dr1dr(:, :, :) = dr1dr(:, :, :) + &
5604 drhoa(idir)%array(:, :, :)*(drho1a(idir)%array(:, :, :) + &
5605 fac*drho1b(idir)%array(:, :, :)) + &
5606 drhob(idir)%array(:, :, :)*(fac*drho1a(idir)%array(:, :, :) + &
5607 drho1b(idir)%array(:, :, :))
5608!$OMP END PARALLEL WORKSHARE
5609 END DO
5610
5611 CALL timestop(handle)
5612
5613 END SUBROUTINE prepare_dr1dr_ab
5614
5615! **************************************************************************************************
5616!> \brief checks for gradients
5617!> \param deriv_set ...
5618!> \param lsd ...
5619!> \param gradient_f ...
5620!> \param tau_f ...
5621!> \param laplace_f ...
5622! **************************************************************************************************
5623 SUBROUTINE check_for_derivatives(deriv_set, lsd, rho_f, gradient_f, tau_f, laplace_f)
5624 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set
5625 LOGICAL, INTENT(IN) :: lsd
5626 LOGICAL, INTENT(OUT) :: rho_f, gradient_f, tau_f, laplace_f
5627
5628 CHARACTER(len=*), PARAMETER :: routinen = 'check_for_derivatives'
5629
5630 INTEGER :: handle, iorder, order
5631 INTEGER, DIMENSION(:), POINTER :: split_desc
5632 TYPE(cp_sll_xc_deriv_type), POINTER :: pos
5633 TYPE(xc_derivative_type), POINTER :: deriv_att
5634
5635 CALL timeset(routinen, handle)
5636
5637 rho_f = .false.
5638 gradient_f = .false.
5639 tau_f = .false.
5640 laplace_f = .false.
5641 ! check for unknown derivatives
5642 pos => deriv_set%derivs
5643 DO WHILE (cp_sll_xc_deriv_next(pos, el_att=deriv_att))
5644 CALL xc_derivative_get(deriv_att, order=order, &
5645 split_desc=split_desc)
5646 IF (lsd) THEN
5647 DO iorder = 1, size(split_desc)
5648 SELECT CASE (split_desc(iorder))
5649 CASE (deriv_rhoa, deriv_rhob)
5650 rho_f = .true.
5651 CASE (deriv_norm_drho, deriv_norm_drhoa, deriv_norm_drhob)
5652 gradient_f = .true.
5653 CASE (deriv_tau_a, deriv_tau_b)
5654 tau_f = .true.
5655 CASE (deriv_laplace_rhoa, deriv_laplace_rhob)
5656 laplace_f = .true.
5657 CASE (deriv_rho, deriv_tau, deriv_laplace_rho)
5658 cpabort("Derivative not handled in lsd!")
5659 CASE default
5660 cpabort("Unknown derivative id")
5661 END SELECT
5662 END DO
5663 ELSE
5664 DO iorder = 1, size(split_desc)
5665 SELECT CASE (split_desc(iorder))
5666 CASE (deriv_rho)
5667 rho_f = .true.
5668 CASE (deriv_tau)
5669 tau_f = .true.
5670 CASE (deriv_norm_drho)
5671 gradient_f = .true.
5672 CASE (deriv_laplace_rho)
5673 laplace_f = .true.
5674 CASE default
5675 cpabort("Unknown derivative id")
5676 END SELECT
5677 END DO
5678 END IF
5679 END DO
5680
5681 CALL timestop(handle)
5682
5683 END SUBROUTINE check_for_derivatives
5684
5685END MODULE xc
5686
fac
static GRID_HOST_DEVICE double fac(const int i)
Factorial function, e.g. fac(5) = 5! = 120.
Definition grid_common.h:51
cp_log_handling::cp_to_string
Definition cp_log_handling.F:90
kahan_sum::accurate_dot_product
Definition kahan_sum.F:52
kahan_sum::accurate_sum
Definition kahan_sum.F:41
pw_methods::pw_axpy
Definition pw_methods.F:164
pw_methods::pw_copy
Definition pw_methods.F:145
pw_methods::pw_integrate_function
Definition pw_methods.F:115
pw_methods::pw_scale
Definition pw_methods.F:93
pw_methods::pw_transfer
Definition pw_methods.F:303
pw_methods::pw_zero
Definition pw_methods.F:82
xc_util::xc_pw_laplace
Definition xc_util.F:46
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_linked_list_xc_deriv
Definition cp_linked_list_xc_deriv.F:9
cp_linked_list_xc_deriv::cp_sll_xc_deriv_next
logical function, public cp_sll_xc_deriv_next(iterator, el_att)
returns true if the actual element is valid (i.e. iterator ont at end) moves the iterator to the next...
Definition cp_linked_list_xc_deriv.F:394
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_unit_nr
recursive integer function, public cp_logger_get_default_unit_nr(logger, local, skip_not_ionode)
asks the default unit number of the given logger. try to use cp_logger_get_unit_nr
Definition cp_log_handling.F:567
cp_log_handling::cp_get_default_logger
type(cp_logger_type) function, pointer, public cp_get_default_logger()
returns the default logger
Definition cp_log_handling.F:234
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:948
input_section_types::section_get_ival
integer function, public section_get_ival(section_vals, keyword_name)
...
Definition input_section_types.F:980
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:731
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:1047
input_section_types::section_get_lval
logical function, public section_get_lval(section_vals, keyword_name)
...
Definition input_section_types.F:1012
kahan_sum
sums arrays of real/complex numbers with much reduced round-off as compared to a naive implementation...
Definition kahan_sum.F:29
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
kinds::default_path_length
integer, parameter, public default_path_length
Definition kinds.F:58
pw_grid_types
Definition pw_grid_types.F:13
pw_grid_types::pw_mode_distributed
integer, parameter, public pw_mode_distributed
Definition pw_grid_types.F:27
pw_methods
Definition pw_methods.F:25
pw_methods::pw_derive
subroutine, public pw_derive(pw, n)
Calculate the derivative of a plane wave vector.
Definition pw_methods.F:10256
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
xc_derivative_desc
Module with functions to handle derivative descriptors. derivative description are strings have the f...
Definition xc_derivative_desc.F:26
xc_derivative_desc::deriv_norm_drho
integer, parameter, public deriv_norm_drho
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_laplace_rhob
integer, parameter, public deriv_laplace_rhob
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_norm_drhoa
integer, parameter, public deriv_norm_drhoa
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_rhob
integer, parameter, public deriv_rhob
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_rhoa
integer, parameter, public deriv_rhoa
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_tau
integer, parameter, public deriv_tau
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_tau_b
integer, parameter, public deriv_tau_b
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_tau_a
integer, parameter, public deriv_tau_a
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_laplace_rhoa
integer, parameter, public deriv_laplace_rhoa
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_rho
integer, parameter, public deriv_rho
Definition xc_derivative_desc.F:35
xc_derivative_desc::deriv_norm_drhob
integer, parameter, public deriv_norm_drhob
Definition xc_derivative_desc.F:35
xc_derivative_desc::id_to_desc
character(len=max_label_length) function, public id_to_desc(id)
...
Definition xc_derivative_desc.F:105
xc_derivative_desc::deriv_laplace_rho
integer, parameter, public deriv_laplace_rho
Definition xc_derivative_desc.F:35
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:165
xc_derivative_set_types::xc_dset_recover_pw
subroutine, public xc_dset_recover_pw(deriv_set, description, pw, pw_grid, pw_pool)
Recovers a derivative on a pw_r3d_rs_type, the caller is responsible to release the grid later If the...
Definition xc_derivative_set_types.F:192
xc_derivative_set_types::xc_dset_get_derivative
type(xc_derivative_type) function, pointer, public xc_dset_get_derivative(derivative_set, description, allocate_deriv)
returns the requested xc_derivative
Definition xc_derivative_set_types.F:65
xc_derivative_set_types::xc_dset_release
subroutine, public xc_dset_release(derivative_set)
releases a derivative set
Definition xc_derivative_set_types.F:142
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_derivative_types
Provides types for the management of the xc-functionals and their derivatives.
Definition xc_derivative_types.F:12
xc_derivative_types::xc_derivative_get
subroutine, public xc_derivative_get(deriv, split_desc, order, deriv_data, accept_null_data)
returns various information on the given derivative
Definition xc_derivative_types.F:103
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:600
xc_derivatives::xc_functionals_eval
subroutine, public xc_functionals_eval(functionals, lsd, rho_set, deriv_set, deriv_order)
...
Definition xc_derivatives.F:565
xc_input_constants
input constants for xc
Definition xc_input_constants.F:10
xc_input_constants::xc_default_f_routine
integer, parameter, public xc_default_f_routine
Definition xc_input_constants.F:37
xc_input_constants::xc_test_lsd_f_routine
integer, parameter, public xc_test_lsd_f_routine
Definition xc_input_constants.F:37
xc_input_constants::xc_debug_new_routine
integer, parameter, public xc_debug_new_routine
Definition xc_input_constants.F:37
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_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)
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_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_recover_pw
subroutine, public xc_rho_set_recover_pw(rho_set, pw_grid, pw_pool, owns_data, 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, tau, tau_a, tau_b)
Shifts association of the requested array to a pw grid Requires that the corresponding component of r...
Definition xc_rho_set_types.F:421
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
xc_util
contains utility functions for the xc package
Definition xc_util.F:14
xc_util::xc_pw_divergence
subroutine, public xc_pw_divergence(xc_deriv_method_id, pw_to_deriv, tmp_g, vxc_g, vxc_r)
Calculates the divergence of pw_to_deriv.
Definition xc_util.F:253
xc_util::xc_pw_smooth
subroutine, public xc_pw_smooth(pw_in, pw_out, xc_smooth_id)
...
Definition xc_util.F:73
xc_util::xc_requires_tmp_g
elemental logical function, public xc_requires_tmp_g(xc_deriv_id)
...
Definition xc_util.F:58
xc
Exchange and Correlation functional calculations.
Definition xc.F:17
xc::divide_by_norm_drho
subroutine, public divide_by_norm_drho(deriv_set, rho_set, lsd)
divides derivatives from deriv_set by norm_drho
Definition xc.F:5421
xc::xc_calc_2nd_deriv
subroutine, public xc_calc_2nd_deriv(v_xc, v_xc_tau, deriv_set, rho_set, rho1_r, rho1_g, tau1_r, pw_pool, xc_section, gapw, vxg, do_excitations, do_triplet, compute_virial, virial_xc)
Caller routine to calculate the second order potential in the direction of rho1_r.
Definition xc.F:1528
xc::xc_vxc_pw_create
subroutine, public xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau, xc_section, pw_pool, compute_virial, virial_xc, exc_r)
Exchange and Correlation functional calculations.
Definition xc.F:1141
xc::xc_uses_norm_drho
logical function, public xc_uses_norm_drho(xc_fun_section, lsd)
...
Definition xc.F:111
xc::xc_exc_calc
real(kind=dp) function, public xc_exc_calc(rho_r, rho_g, tau, xc_section, pw_pool)
calculates just the exchange and correlation energy (no vxc)
Definition xc.F:1456
xc::xc_uses_kinetic_energy_density
logical function, public xc_uses_kinetic_energy_density(xc_fun_section, lsd)
...
Definition xc.F:91
xc::calc_xc_density
subroutine, public calc_xc_density(pot, rho, rho_cutoff)
Definition xc.F:1070
xc::xc_prep_2nd_deriv
subroutine, public xc_prep_2nd_deriv(deriv_set, rho_set, rho_r, pw_pool, xc_section, tau_r)
Prepare objects for the calculation of the 2nd derivatives of the density functional....
Definition xc.F:5373
xc::smooth_cutoff
subroutine, public smooth_cutoff(pot, rho, rhoa, rhob, rho_cutoff, rho_smooth_cutoff_range, e_0, e_0_scale_factor)
smooths the cutoff on rho with a function smoothderiv_rho that is 0 for rho<rho_cutoff and 1 for rho>...
Definition xc.F:910
xc::xc_calc_2nd_deriv_analytical
subroutine, public xc_calc_2nd_deriv_analytical(v_xc, v_xc_tau, deriv_set, rho_set, rho1_set, pw_pool, xc_section, gapw, vxg, tddfpt_fac, compute_virial, virial_xc)
Calculates the second derivative of E_xc at rho in the direction rho1 (if you see the second derivati...
Definition xc.F:2640
xc::xc_vxc_pw_create1
subroutine, public xc_vxc_pw_create1(vxc_rho, vxc_tau, rho_r, rho_g, tau, exc, xc_section, pw_pool, compute_virial, virial_xc, exc_r)
Exchange and Correlation functional calculations. depending on the selected functional_routine calls ...
Definition xc.F:150
xc::xc_calc_2nd_deriv_numerical
subroutine, public xc_calc_2nd_deriv_numerical(v_xc, v_tau, rho_set, rho1_r, rho1_g, tau1_r, pw_pool, xc_section, do_triplet, calc_virial, virial_xc, deriv_set)
calculates 2nd derivative numerically
Definition xc.F:1653
cp_array_utils::cp_3d_r_cp_type
represent a pointer to a contiguous 3d array
Definition cp_array_utils.F:149
cp_linked_list_xc_deriv::cp_sll_xc_deriv_type
represent a single linked list that stores pointers to the elements
Definition cp_linked_list_xc_deriv.F:136
cp_log_handling::cp_logger_type
type of a logger, at the moment it contains just a print level starting at which level it should be l...
Definition cp_log_handling.F:140
input_section_types::section_vals_type
stores the values of a section
Definition input_section_types.F:127
pw_grid_types::pw_grid_type
Definition pw_grid_types.F:52
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
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_derivative_types::xc_derivative_type
represent a derivative of a functional
Definition xc_derivative_types.F:32
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