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