(git:badb799)
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-2025 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \brief Exchange and Correlation functional calculations
10!> \par History
11!> (13-Feb-2001) JGH, based on earlier version of apsi
12!> 02.2003 Many many changes [fawzi]
13!> 03.2004 new xc interface [fawzi]
14!> 04.2004 kinetic functionals [fawzi]
15!> \author fawzi
16! **************************************************************************************************
17MODULE xc
33 USE kinds, ONLY: default_path_length, &
34 dp
37 USE pw_methods, ONLY: pw_axpy, &
38 pw_copy, &
39 pw_derive, &
40 pw_scale, &
43 USE pw_pool_types, ONLY: &
45 USE pw_types, ONLY: &
47 USE xc_derivative_desc, ONLY: &
60 USE xc_input_constants, ONLY: &
69#include "../base/base_uses.f90"
70
71 IMPLICIT NONE
72 PRIVATE
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)
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)
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)
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 ! Create deriv_set object
867 CALL xc_dset_create(deriv_set, pw_pool)
868
869 ! Create objects for density related stuff
870 CALL xc_rho_set_create(rho_set, &
871 rho_r(1)%pw_grid%bounds_local, &
872 rho_cutoff=section_get_rval(xc_section, "density_cutoff"), &
873 drho_cutoff=section_get_rval(xc_section, "gradient_cutoff"), &
874 tau_cutoff=section_get_rval(xc_section, "tau_cutoff"))
875
876 ! Calculate density stuff, for example the gradient of rho, according to the functional needs
877 CALL xc_rho_set_update(rho_set, rho_r, rho_g, tau, &
878 xc_functionals_get_needs(xc_fun_sections, lsd, calc_potential), &
879 section_get_ival(xc_section, "XC_GRID%XC_DERIV"), &
880 section_get_ival(xc_section, "XC_GRID%XC_SMOOTH_RHO"), &
881 pw_pool)
882
883 ! Calculate values of the functional on the grid
884 CALL xc_functionals_eval(xc_fun_sections, &
885 lsd=lsd, &
886 rho_set=rho_set, &
887 deriv_set=deriv_set, &
888 deriv_order=deriv_order)
889
890 CALL divide_by_norm_drho(deriv_set, rho_set, lsd)
891
892 CALL timestop(handle)
893
894 END SUBROUTINE xc_rho_set_and_dset_create
895
896! **************************************************************************************************
897!> \brief smooths the cutoff on rho with a function smoothderiv_rho that is 0
898!> for rho<rho_cutoff and 1 for rho>rho_cutoff*rho_smooth_cutoff_range:
899!> E= integral e_0*smoothderiv_rho => dE/d...= de/d... * smooth,
900!> dE/drho = de/drho * smooth + e_0 * dsmooth/drho
901!> \param pot the potential to smooth
902!> \param rho , rhoa,rhob: the value of the density (used to apply the cutoff)
903!> \param rhoa ...
904!> \param rhob ...
905!> \param rho_cutoff the value at whch the cutoff function must go to 0
906!> \param rho_smooth_cutoff_range range of the smoothing
907!> \param e_0 value of e_0, if given it is assumed that pot is the derivative
908!> wrt. to rho, and needs the dsmooth*e_0 contribution
909!> \param e_0_scale_factor ...
910!> \author Fawzi Mohamed
911! **************************************************************************************************
912 SUBROUTINE smooth_cutoff(pot, rho, rhoa, rhob, rho_cutoff, &
913 rho_smooth_cutoff_range, e_0, e_0_scale_factor)
914 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN), &
915 POINTER :: pot, rho, rhoa, rhob
916 REAL(kind=dp), INTENT(in) :: rho_cutoff, rho_smooth_cutoff_range
917 REAL(kind=dp), DIMENSION(:, :, :), OPTIONAL, &
918 POINTER :: e_0
919 REAL(kind=dp), INTENT(in), OPTIONAL :: e_0_scale_factor
920
921 INTEGER :: i, j, k
922 INTEGER, DIMENSION(2, 3) :: bo
923 REAL(kind=dp) :: my_e_0_scale_factor, my_rho, my_rho_n, my_rho_n2, rho_smooth_cutoff, &
924 rho_smooth_cutoff_2, rho_smooth_cutoff_range_2
925
926 cpassert(ASSOCIATED(pot))
927 bo(1, :) = lbound(pot)
928 bo(2, :) = ubound(pot)
929 my_e_0_scale_factor = 1.0_dp
930 IF (PRESENT(e_0_scale_factor)) my_e_0_scale_factor = e_0_scale_factor
931 rho_smooth_cutoff = rho_cutoff*rho_smooth_cutoff_range
932 rho_smooth_cutoff_2 = (rho_cutoff + rho_smooth_cutoff)/2
933 rho_smooth_cutoff_range_2 = rho_smooth_cutoff_2 - rho_cutoff
934
935 IF (rho_smooth_cutoff_range > 0.0_dp) THEN
936 IF (PRESENT(e_0)) THEN
937 cpassert(ASSOCIATED(e_0))
938 IF (ASSOCIATED(rho)) THEN
939!$OMP PARALLEL DO DEFAULT(NONE) &
940!$OMP SHARED(bo,e_0,pot,rho,rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2, &
941!$OMP rho_smooth_cutoff_range_2,my_e_0_scale_factor) &
942!$OMP PRIVATE(k,j,i,my_rho,my_rho_n,my_rho_n2) &
943!$OMP COLLAPSE(3)
944 DO k = bo(1, 3), bo(2, 3)
945 DO j = bo(1, 2), bo(2, 2)
946 DO i = bo(1, 1), bo(2, 1)
947 my_rho = rho(i, j, k)
948 IF (my_rho < rho_smooth_cutoff) THEN
949 IF (my_rho < rho_cutoff) THEN
950 pot(i, j, k) = 0.0_dp
951 ELSEIF (my_rho < rho_smooth_cutoff_2) THEN
952 my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
953 my_rho_n2 = my_rho_n*my_rho_n
954 pot(i, j, k) = pot(i, j, k)* &
955 my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2) + &
956 my_e_0_scale_factor*e_0(i, j, k)* &
957 my_rho_n2*(3.0_dp - 2.0_dp*my_rho_n) &
958 /rho_smooth_cutoff_range_2
959 ELSE
960 my_rho_n = 2.0_dp - (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
961 my_rho_n2 = my_rho_n*my_rho_n
962 pot(i, j, k) = pot(i, j, k)* &
963 (1.0_dp - my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2)) &
964 + my_e_0_scale_factor*e_0(i, j, k)* &
965 my_rho_n2*(3.0_dp - 2.0_dp*my_rho_n) &
966 /rho_smooth_cutoff_range_2
967 END IF
968 END IF
969 END DO
970 END DO
971 END DO
972!$OMP END PARALLEL DO
973 ELSE
974!$OMP PARALLEL DO DEFAULT(NONE) &
975!$OMP SHARED(bo,pot,e_0,rhoa,rhob,rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2, &
976!$OMP rho_smooth_cutoff_range_2,my_e_0_scale_factor) &
977!$OMP PRIVATE(k,j,i,my_rho,my_rho_n,my_rho_n2) &
978!$OMP COLLAPSE(3)
979 DO k = bo(1, 3), bo(2, 3)
980 DO j = bo(1, 2), bo(2, 2)
981 DO i = bo(1, 1), bo(2, 1)
982 my_rho = rhoa(i, j, k) + rhob(i, j, k)
983 IF (my_rho < rho_smooth_cutoff) THEN
984 IF (my_rho < rho_cutoff) THEN
985 pot(i, j, k) = 0.0_dp
986 ELSEIF (my_rho < rho_smooth_cutoff_2) THEN
987 my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
988 my_rho_n2 = my_rho_n*my_rho_n
989 pot(i, j, k) = pot(i, j, k)* &
990 my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2) + &
991 my_e_0_scale_factor*e_0(i, j, k)* &
992 my_rho_n2*(3.0_dp - 2.0_dp*my_rho_n) &
993 /rho_smooth_cutoff_range_2
994 ELSE
995 my_rho_n = 2.0_dp - (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
996 my_rho_n2 = my_rho_n*my_rho_n
997 pot(i, j, k) = pot(i, j, k)* &
998 (1.0_dp - my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2)) &
999 + my_e_0_scale_factor*e_0(i, j, k)* &
1000 my_rho_n2*(3.0_dp - 2.0_dp*my_rho_n) &
1001 /rho_smooth_cutoff_range_2
1002 END IF
1003 END IF
1004 END DO
1005 END DO
1006 END DO
1007!$OMP END PARALLEL DO
1008 END IF
1009 ELSE
1010 IF (ASSOCIATED(rho)) THEN
1011!$OMP PARALLEL DO DEFAULT(NONE) &
1012!$OMP SHARED(bo,pot,rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2, &
1013!$OMP rho_smooth_cutoff_range_2,rho) &
1014!$OMP PRIVATE(k,j,i,my_rho,my_rho_n,my_rho_n2) &
1015!$OMP COLLAPSE(3)
1016 DO k = bo(1, 3), bo(2, 3)
1017 DO j = bo(1, 2), bo(2, 2)
1018 DO i = bo(1, 1), bo(2, 1)
1019 my_rho = rho(i, j, k)
1020 IF (my_rho < rho_smooth_cutoff) THEN
1021 IF (my_rho < rho_cutoff) THEN
1022 pot(i, j, k) = 0.0_dp
1023 ELSEIF (my_rho < rho_smooth_cutoff_2) THEN
1024 my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
1025 my_rho_n2 = my_rho_n*my_rho_n
1026 pot(i, j, k) = pot(i, j, k)* &
1027 my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2)
1028 ELSE
1029 my_rho_n = 2.0_dp - (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
1030 my_rho_n2 = my_rho_n*my_rho_n
1031 pot(i, j, k) = pot(i, j, k)* &
1032 (1.0_dp - my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2))
1033 END IF
1034 END IF
1035 END DO
1036 END DO
1037 END DO
1038!$OMP END PARALLEL DO
1039 ELSE
1040!$OMP PARALLEL DO DEFAULT(NONE) &
1041!$OMP SHARED(bo,pot,rho_cutoff,rho_smooth_cutoff,rho_smooth_cutoff_2, &
1042!$OMP rho_smooth_cutoff_range_2,rhoa,rhob) &
1043!$OMP PRIVATE(k,j,i,my_rho,my_rho_n,my_rho_n2) &
1044!$OMP COLLAPSE(3)
1045 DO k = bo(1, 3), bo(2, 3)
1046 DO j = bo(1, 2), bo(2, 2)
1047 DO i = bo(1, 1), bo(2, 1)
1048 my_rho = rhoa(i, j, k) + rhob(i, j, k)
1049 IF (my_rho < rho_smooth_cutoff) THEN
1050 IF (my_rho < rho_cutoff) THEN
1051 pot(i, j, k) = 0.0_dp
1052 ELSEIF (my_rho < rho_smooth_cutoff_2) THEN
1053 my_rho_n = (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
1054 my_rho_n2 = my_rho_n*my_rho_n
1055 pot(i, j, k) = pot(i, j, k)* &
1056 my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2)
1057 ELSE
1058 my_rho_n = 2.0_dp - (my_rho - rho_cutoff)/rho_smooth_cutoff_range_2
1059 my_rho_n2 = my_rho_n*my_rho_n
1060 pot(i, j, k) = pot(i, j, k)* &
1061 (1.0_dp - my_rho_n2*(my_rho_n - 0.5_dp*my_rho_n2))
1062 END IF
1063 END IF
1064 END DO
1065 END DO
1066 END DO
1067!$OMP END PARALLEL DO
1068 END IF
1069 END IF
1070 END IF
1071 END SUBROUTINE smooth_cutoff
1072
1073 SUBROUTINE calc_xc_density(pot, rho, rho_cutoff)
1074 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pot
1075 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(INOUT) :: rho
1076 REAL(kind=dp), INTENT(in) :: rho_cutoff
1077
1078 INTEGER :: i, j, k, nspins
1079 INTEGER, DIMENSION(2, 3) :: bo
1080 REAL(kind=dp) :: eps1, eps2, my_rho, my_pot
1081
1082 bo(1, :) = lbound(pot%array)
1083 bo(2, :) = ubound(pot%array)
1084 nspins = SIZE(rho)
1085
1086 eps1 = rho_cutoff*1.e-4_dp
1087 eps2 = rho_cutoff
1088
1089 DO k = bo(1, 3), bo(2, 3)
1090 DO j = bo(1, 2), bo(2, 2)
1091 DO i = bo(1, 1), bo(2, 1)
1092 my_pot = pot%array(i, j, k)
1093 IF (nspins == 2) THEN
1094 my_rho = rho(1)%array(i, j, k) + rho(2)%array(i, j, k)
1095 ELSE
1096 my_rho = rho(1)%array(i, j, k)
1097 END IF
1098 IF (my_rho > eps1) THEN
1099 pot%array(i, j, k) = my_pot/my_rho
1100 ELSE IF (my_rho < eps2) THEN
1101 pot%array(i, j, k) = 0.0_dp
1102 ELSE
1103 pot%array(i, j, k) = min(my_pot/my_rho, my_rho**(1._dp/3._dp))
1104 END IF
1105 END DO
1106 END DO
1107 END DO
1108
1109 END SUBROUTINE calc_xc_density
1110
1111! **************************************************************************************************
1112!> \brief Exchange and Correlation functional calculations
1113!> \param vxc_rho will contain the v_xc part that depend on rho
1114!> (if one of the chosen xc functionals has it it is allocated and you
1115!> are responsible for it)
1116!> \param vxc_tau will contain the kinetic tau part of v_xc
1117!> (if one of the chosen xc functionals has it it is allocated and you
1118!> are responsible for it)
1119!> \param exc the xc energy
1120!> \param rho_r the value of the density in the real space
1121!> \param rho_g value of the density in the g space (needs to be associated
1122!> only for gradient corrections)
1123!> \param tau value of the kinetic density tau on the grid (can be null,
1124!> used only with meta functionals)
1125!> \param xc_section which functional to calculate, and how to do it
1126!> \param pw_pool the pool for the grids
1127!> \param compute_virial ...
1128!> \param virial_xc ...
1129!> \param exc_r the value of the xc functional in the real space
1130!> \par History
1131!> JGH (13-Jun-2002): adaptation to new functionals
1132!> Fawzi (11.2002): drho_g(1:3)->drho_g
1133!> Fawzi (1.2003). lsd version
1134!> Fawzi (11.2003): version using the new xc interface
1135!> Fawzi (03.2004): fft free for smoothed density and derivs, gga lsd
1136!> Fawzi (04.2004): metafunctionals
1137!> mguidon (12.2008) : laplace functionals
1138!> \author fawzi; based LDA version of JGH, based on earlier version of apsi
1139!> \note
1140!> Beware: some really dirty pointer handling!
1141!> energy should be kept consistent with xc_exc_calc
1142! **************************************************************************************************
1143 SUBROUTINE xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau, xc_section, &
1144 pw_pool, compute_virial, virial_xc, exc_r)
1145 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau
1146 REAL(kind=dp), INTENT(out) :: exc
1147 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau
1148 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
1149 TYPE(section_vals_type), POINTER :: xc_section
1150 TYPE(pw_pool_type), POINTER :: pw_pool
1151 LOGICAL :: compute_virial
1152 REAL(kind=dp), DIMENSION(3, 3), INTENT(OUT) :: virial_xc
1153 TYPE(pw_r3d_rs_type), INTENT(INOUT), OPTIONAL :: exc_r
1154
1155 CHARACTER(len=*), PARAMETER :: routinen = 'xc_vxc_pw_create'
1156 INTEGER, DIMENSION(2), PARAMETER :: norm_drho_spin_name = [deriv_norm_drhoa, deriv_norm_drhob]
1157
1158 INTEGER :: handle, idir, ispin, jdir, &
1159 npoints, nspins, &
1160 xc_deriv_method_id, xc_rho_smooth_id, deriv_id
1161 INTEGER, DIMENSION(2, 3) :: bo
1162 LOGICAL :: dealloc_pw_to_deriv, has_laplace, &
1163 has_tau, lsd, use_virial, has_gradient, &
1164 has_derivs, has_rho, dealloc_pw_to_deriv_rho
1165 REAL(kind=dp) :: density_smooth_cut_range, drho_cutoff, &
1166 rho_cutoff
1167 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data, norm_drho, norm_drho_spin, &
1168 rho, rhoa, rhob
1169 TYPE(cp_sll_xc_deriv_type), POINTER :: pos
1170 TYPE(pw_grid_type), POINTER :: pw_grid
1171 TYPE(pw_r3d_rs_type), DIMENSION(3) :: pw_to_deriv, pw_to_deriv_rho
1172 TYPE(pw_c1d_gs_type) :: tmp_g, vxc_g
1173 TYPE(pw_r3d_rs_type) :: v_drho_r, virial_pw
1174 TYPE(xc_derivative_set_type) :: deriv_set
1175 TYPE(xc_derivative_type), POINTER :: deriv_att
1176 TYPE(xc_rho_set_type) :: rho_set
1177
1178 CALL timeset(routinen, handle)
1179 NULLIFY (norm_drho_spin, norm_drho, pos)
1180
1181 pw_grid => rho_r(1)%pw_grid
1182
1183 cpassert(ASSOCIATED(xc_section))
1184 cpassert(ASSOCIATED(pw_pool))
1185 cpassert(.NOT. ASSOCIATED(vxc_rho))
1186 cpassert(.NOT. ASSOCIATED(vxc_tau))
1187 nspins = SIZE(rho_r)
1188 lsd = (nspins /= 1)
1189 IF (lsd) THEN
1190 cpassert(nspins == 2)
1191 END IF
1192
1193 use_virial = compute_virial
1194 virial_xc = 0.0_dp
1195
1196 bo = rho_r(1)%pw_grid%bounds_local
1197 npoints = (bo(2, 1) - bo(1, 1) + 1)*(bo(2, 2) - bo(1, 2) + 1)*(bo(2, 3) - bo(1, 3) + 1)
1198
1199 ! calculate the potential derivatives
1200 CALL xc_rho_set_and_dset_create(rho_set=rho_set, deriv_set=deriv_set, &
1201 deriv_order=1, rho_r=rho_r, rho_g=rho_g, tau=tau, &
1202 xc_section=xc_section, &
1203 pw_pool=pw_pool, &
1204 calc_potential=.true.)
1205
1206 CALL section_vals_val_get(xc_section, "XC_GRID%XC_DERIV", &
1207 i_val=xc_deriv_method_id)
1208 CALL section_vals_val_get(xc_section, "XC_GRID%XC_SMOOTH_RHO", &
1209 i_val=xc_rho_smooth_id)
1210 CALL section_vals_val_get(xc_section, "DENSITY_SMOOTH_CUTOFF_RANGE", &
1211 r_val=density_smooth_cut_range)
1212
1213 CALL xc_rho_set_get(rho_set, rho_cutoff=rho_cutoff, &
1214 drho_cutoff=drho_cutoff)
1215
1216 CALL check_for_derivatives(deriv_set, lsd, has_rho, has_gradient, has_tau, has_laplace)
1217 ! check for unknown derivatives
1218 has_derivs = has_rho .OR. has_gradient .OR. has_tau .OR. has_laplace
1219
1220 ALLOCATE (vxc_rho(nspins))
1221
1222 CALL xc_rho_set_get(rho_set, rho=rho, rhoa=rhoa, rhob=rhob, &
1223 can_return_null=.true.)
1224
1225 ! recover the vxc arrays
1226 IF (lsd) THEN
1227 CALL xc_dset_recover_pw(deriv_set, [deriv_rhoa], vxc_rho(1), pw_grid, pw_pool)
1228 CALL xc_dset_recover_pw(deriv_set, [deriv_rhob], vxc_rho(2), pw_grid, pw_pool)
1229
1230 ELSE
1231 CALL xc_dset_recover_pw(deriv_set, [deriv_rho], vxc_rho(1), pw_grid, pw_pool)
1232 END IF
1233
1234 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho])
1235 IF (ASSOCIATED(deriv_att)) THEN
1236 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
1237
1238 CALL xc_rho_set_get(rho_set, norm_drho=norm_drho, &
1239 rho_cutoff=rho_cutoff, &
1240 drho_cutoff=drho_cutoff, &
1241 can_return_null=.true.)
1242 CALL xc_rho_set_recover_pw(rho_set, pw_grid, pw_pool, dealloc_pw_to_deriv_rho, drho=pw_to_deriv_rho)
1243
1244 cpassert(ASSOCIATED(deriv_data))
1245 IF (use_virial) THEN
1246 CALL pw_pool%create_pw(virial_pw)
1247 CALL pw_zero(virial_pw)
1248 DO idir = 1, 3
1249!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(virial_pw,pw_to_deriv_rho,deriv_data,idir)
1250 virial_pw%array(:, :, :) = pw_to_deriv_rho(idir)%array(:, :, :)*deriv_data(:, :, :)
1251!$OMP END PARALLEL WORKSHARE
1252 DO jdir = 1, idir
1253 virial_xc(idir, jdir) = -pw_grid%dvol* &
1254 accurate_dot_product(virial_pw%array(:, :, :), &
1255 pw_to_deriv_rho(jdir)%array(:, :, :))
1256 virial_xc(jdir, idir) = virial_xc(idir, jdir)
1257 END DO
1258 END DO
1259 CALL pw_pool%give_back_pw(virial_pw)
1260 END IF ! use_virial
1261 DO idir = 1, 3
1262 cpassert(ASSOCIATED(pw_to_deriv_rho(idir)%array))
1263!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_data,pw_to_deriv_rho,idir)
1264 pw_to_deriv_rho(idir)%array(:, :, :) = pw_to_deriv_rho(idir)%array(:, :, :)*deriv_data(:, :, :)
1265!$OMP END PARALLEL WORKSHARE
1266 END DO
1267
1268 ! Deallocate pw to save memory
1269 CALL pw_pool%give_back_cr3d(deriv_att%deriv_data)
1270
1271 END IF
1272
1273 IF ((has_gradient .AND. xc_requires_tmp_g(xc_deriv_method_id)) .OR. pw_grid%spherical) THEN
1274 CALL pw_pool%create_pw(vxc_g)
1275 IF (.NOT. pw_grid%spherical) THEN
1276 CALL pw_pool%create_pw(tmp_g)
1277 END IF
1278 END IF
1279
1280 DO ispin = 1, nspins
1281
1282 IF (lsd) THEN
1283 IF (ispin == 1) THEN
1284 CALL xc_rho_set_get(rho_set, norm_drhoa=norm_drho_spin, &
1285 can_return_null=.true.)
1286 IF (ASSOCIATED(norm_drho_spin)) CALL xc_rho_set_recover_pw( &
1287 rho_set, pw_grid, pw_pool, dealloc_pw_to_deriv, drhoa=pw_to_deriv)
1288 ELSE
1289 CALL xc_rho_set_get(rho_set, norm_drhob=norm_drho_spin, &
1290 can_return_null=.true.)
1291 IF (ASSOCIATED(norm_drho_spin)) CALL xc_rho_set_recover_pw( &
1292 rho_set, pw_grid, pw_pool, dealloc_pw_to_deriv, drhob=pw_to_deriv)
1293 END IF
1294
1295 deriv_att => xc_dset_get_derivative(deriv_set, [norm_drho_spin_name(ispin)])
1296 IF (ASSOCIATED(deriv_att)) THEN
1297 cpassert(lsd)
1298 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
1299
1300 IF (use_virial) THEN
1301 CALL pw_pool%create_pw(virial_pw)
1302 CALL pw_zero(virial_pw)
1303 DO idir = 1, 3
1304!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_data,pw_to_deriv,virial_pw,idir)
1305 virial_pw%array(:, :, :) = pw_to_deriv(idir)%array(:, :, :)*deriv_data(:, :, :)
1306!$OMP END PARALLEL WORKSHARE
1307 DO jdir = 1, idir
1308 virial_xc(idir, jdir) = virial_xc(idir, jdir) - pw_grid%dvol* &
1309 accurate_dot_product(virial_pw%array(:, :, :), &
1310 pw_to_deriv(jdir)%array(:, :, :))
1311 virial_xc(jdir, idir) = virial_xc(idir, jdir)
1312 END DO
1313 END DO
1314 CALL pw_pool%give_back_pw(virial_pw)
1315 END IF ! use_virial
1316
1317 DO idir = 1, 3
1318!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_data,idir,pw_to_deriv)
1319 pw_to_deriv(idir)%array(:, :, :) = deriv_data(:, :, :)*pw_to_deriv(idir)%array(:, :, :)
1320!$OMP END PARALLEL WORKSHARE
1321 END DO
1322 END IF ! deriv_att
1323
1324 END IF ! LSD
1325
1326 IF (ASSOCIATED(pw_to_deriv_rho(1)%array)) THEN
1327 IF (.NOT. ASSOCIATED(pw_to_deriv(1)%array)) THEN
1328 pw_to_deriv = pw_to_deriv_rho
1329 dealloc_pw_to_deriv = ((.NOT. lsd) .OR. (ispin == 2))
1330 dealloc_pw_to_deriv = dealloc_pw_to_deriv .AND. dealloc_pw_to_deriv_rho
1331 ELSE
1332 ! This branch is called in case of open-shell systems
1333 ! Add the contributions from norm_drho and norm_drho_spin
1334 DO idir = 1, 3
1335 CALL pw_axpy(pw_to_deriv_rho(idir), pw_to_deriv(idir))
1336 IF (ispin == 2) THEN
1337 IF (dealloc_pw_to_deriv_rho) THEN
1338 CALL pw_pool%give_back_pw(pw_to_deriv_rho(idir))
1339 END IF
1340 END IF
1341 END DO
1342 END IF
1343 END IF
1344
1345 IF (ASSOCIATED(pw_to_deriv(1)%array)) THEN
1346 DO idir = 1, 3
1347 CALL pw_scale(pw_to_deriv(idir), -1.0_dp)
1348 END DO
1349
1350 CALL xc_pw_divergence(xc_deriv_method_id, pw_to_deriv, tmp_g, vxc_g, vxc_rho(ispin))
1351
1352 IF (dealloc_pw_to_deriv) THEN
1353 DO idir = 1, 3
1354 CALL pw_pool%give_back_pw(pw_to_deriv(idir))
1355 END DO
1356 END IF
1357 END IF
1358
1359 ! Add laplace part to vxc_rho
1360 IF (has_laplace) THEN
1361 IF (lsd) THEN
1362 IF (ispin == 1) THEN
1363 deriv_id = deriv_laplace_rhoa
1364 ELSE
1365 deriv_id = deriv_laplace_rhob
1366 END IF
1367 ELSE
1368 deriv_id = deriv_laplace_rho
1369 END IF
1370
1371 CALL xc_dset_recover_pw(deriv_set, [deriv_id], pw_to_deriv(1), pw_grid)
1372
1373 IF (use_virial) CALL virial_laplace(rho_r(ispin), pw_pool, virial_xc, pw_to_deriv(1)%array)
1374
1375 CALL xc_pw_laplace(pw_to_deriv(1), pw_pool, xc_deriv_method_id)
1376
1377 CALL pw_axpy(pw_to_deriv(1), vxc_rho(ispin))
1378
1379 CALL pw_pool%give_back_pw(pw_to_deriv(1))
1380 END IF
1381
1382 IF (pw_grid%spherical) THEN
1383 ! filter vxc
1384 CALL pw_transfer(vxc_rho(ispin), vxc_g)
1385 CALL pw_transfer(vxc_g, vxc_rho(ispin))
1386 END IF
1387 CALL smooth_cutoff(pot=vxc_rho(ispin)%array, rho=rho, rhoa=rhoa, rhob=rhob, &
1388 rho_cutoff=rho_cutoff*density_smooth_cut_range, &
1389 rho_smooth_cutoff_range=density_smooth_cut_range)
1390
1391 v_drho_r = vxc_rho(ispin)
1392 CALL pw_pool%create_pw(vxc_rho(ispin))
1393 CALL xc_pw_smooth(v_drho_r, vxc_rho(ispin), xc_rho_smooth_id)
1394 CALL pw_pool%give_back_pw(v_drho_r)
1395 END DO
1396
1397 CALL pw_pool%give_back_pw(vxc_g)
1398 CALL pw_pool%give_back_pw(tmp_g)
1399
1400 ! 0-deriv -> value of exc
1401 ! this has to be kept consistent with xc_exc_calc
1402 IF (has_derivs) THEN
1403 CALL xc_dset_recover_pw(deriv_set, [INTEGER::], v_drho_r, pw_grid)
1404
1405 CALL smooth_cutoff(pot=v_drho_r%array, rho=rho, rhoa=rhoa, rhob=rhob, &
1406 rho_cutoff=rho_cutoff, &
1407 rho_smooth_cutoff_range=density_smooth_cut_range)
1408
1409 exc = pw_integrate_function(v_drho_r)
1410 !
1411 ! return the xc functional value at the grid points
1412 !
1413 IF (PRESENT(exc_r)) THEN
1414 exc_r = v_drho_r
1415 ELSE
1416 CALL v_drho_r%release()
1417 END IF
1418 ELSE
1419 exc = 0.0_dp
1420 END IF
1421
1422 CALL xc_rho_set_release(rho_set, pw_pool=pw_pool)
1423
1424 ! tau part
1425 IF (has_tau) THEN
1426 ALLOCATE (vxc_tau(nspins))
1427 IF (lsd) THEN
1428 CALL xc_dset_recover_pw(deriv_set, [deriv_tau_a], vxc_tau(1), pw_grid)
1429 CALL xc_dset_recover_pw(deriv_set, [deriv_tau_b], vxc_tau(2), pw_grid)
1430 ELSE
1431 CALL xc_dset_recover_pw(deriv_set, [deriv_tau], vxc_tau(1), pw_grid)
1432 END IF
1433 DO ispin = 1, nspins
1434 cpassert(ASSOCIATED(vxc_tau(ispin)%array))
1435 END DO
1436 END IF
1437 CALL xc_dset_release(deriv_set)
1438
1439 CALL timestop(handle)
1440
1441 END SUBROUTINE xc_vxc_pw_create
1442
1443! **************************************************************************************************
1444!> \brief calculates just the exchange and correlation energy
1445!> (no vxc)
1446!> \param rho_r realspace density on the grid
1447!> \param rho_g g-space density on the grid
1448!> \param tau kinetic energy density on the grid
1449!> \param xc_section XC parameters
1450!> \param pw_pool pool of plain-wave grids
1451!> \return the XC energy
1452!> \par History
1453!> 11.2003 created [fawzi]
1454!> \author fawzi
1455!> \note
1456!> has to be kept consistent with xc_vxc_pw_create
1457! **************************************************************************************************
1458 FUNCTION xc_exc_calc(rho_r, rho_g, tau, xc_section, pw_pool) &
1459 result(exc)
1460 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau
1461 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
1462 TYPE(section_vals_type), POINTER :: xc_section
1463 TYPE(pw_pool_type), POINTER :: pw_pool
1464 REAL(kind=dp) :: exc
1465
1466 CHARACTER(len=*), PARAMETER :: routinen = 'xc_exc_calc'
1467
1468 INTEGER :: handle
1469 REAL(dp) :: density_smooth_cut_range, rho_cutoff
1470 REAL(dp), DIMENSION(:, :, :), POINTER :: e_0
1471 TYPE(xc_derivative_set_type) :: deriv_set
1472 TYPE(xc_derivative_type), POINTER :: deriv
1473 TYPE(xc_rho_set_type) :: rho_set
1474
1475 CALL timeset(routinen, handle)
1476 NULLIFY (deriv, e_0)
1477 exc = 0.0_dp
1478
1479 ! this has to be consistent with what is done in xc_vxc_pw_create
1480 CALL xc_rho_set_and_dset_create(rho_set=rho_set, &
1481 deriv_set=deriv_set, deriv_order=0, &
1482 rho_r=rho_r, rho_g=rho_g, tau=tau, xc_section=xc_section, &
1483 pw_pool=pw_pool, &
1484 calc_potential=.false.)
1485 deriv => xc_dset_get_derivative(deriv_set, [INTEGER::])
1486
1487 IF (ASSOCIATED(deriv)) THEN
1488 CALL xc_derivative_get(deriv, deriv_data=e_0)
1489
1490 CALL section_vals_val_get(xc_section, "DENSITY_CUTOFF", &
1491 r_val=rho_cutoff)
1492 CALL section_vals_val_get(xc_section, "DENSITY_SMOOTH_CUTOFF_RANGE", &
1493 r_val=density_smooth_cut_range)
1494 CALL smooth_cutoff(pot=e_0, rho=rho_set%rho, &
1495 rhoa=rho_set%rhoa, rhob=rho_set%rhob, &
1496 rho_cutoff=rho_cutoff, &
1497 rho_smooth_cutoff_range=density_smooth_cut_range)
1498
1499 exc = accurate_sum(e_0)*rho_r(1)%pw_grid%dvol
1500 IF (rho_r(1)%pw_grid%para%mode == pw_mode_distributed) THEN
1501 CALL rho_r(1)%pw_grid%para%group%sum(exc)
1502 END IF
1503
1504 CALL xc_rho_set_release(rho_set, pw_pool=pw_pool)
1505 CALL xc_dset_release(deriv_set)
1506 END IF
1507 CALL timestop(handle)
1508 END FUNCTION xc_exc_calc
1509
1510! **************************************************************************************************
1511!> \brief Caller routine to calculate the second order potential in the direction of rho1_r
1512!> \param v_xc XC potential, will be allocated, to be integrated with the KS density
1513!> \param v_xc_tau ...
1514!> \param deriv_set XC derivatives from xc_prep_2nd_deriv
1515!> \param rho_set XC rho set from KS rho from xc_prep_2nd_deriv
1516!> \param rho1_r first-order density in r space
1517!> \param rho1_g first-order density in g space
1518!> \param tau1_r ...
1519!> \param pw_pool pw pool to create new grids
1520!> \param xc_section XC section to calculate the derivatives from
1521!> \param gapw whether to carry out GAPW (not possible with numerical derivatives)
1522!> \param vxg GAPW potential
1523!> \param do_excitations ...
1524!> \param do_triplet ...
1525!> \param compute_virial ...
1526!> \param virial_xc virial terms will be collected here
1527! **************************************************************************************************
1528 SUBROUTINE xc_calc_2nd_deriv(v_xc, v_xc_tau, deriv_set, rho_set, rho1_r, rho1_g, tau1_r, &
1529 pw_pool, xc_section, gapw, vxg, &
1530 do_excitations, do_sf, do_triplet, &
1531 compute_virial, virial_xc)
1532
1533 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: v_xc, v_xc_tau
1534 TYPE(xc_derivative_set_type) :: deriv_set
1535 TYPE(xc_rho_set_type) :: rho_set
1536 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho1_r, tau1_r
1537 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho1_g
1538 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
1539 TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section
1540 LOGICAL, INTENT(IN) :: gapw
1541 REAL(kind=dp), DIMENSION(:, :, :, :), OPTIONAL, &
1542 POINTER :: vxg
1543 LOGICAL, INTENT(IN), OPTIONAL :: do_excitations, do_sf, &
1544 do_triplet, compute_virial
1545 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT), &
1546 OPTIONAL :: virial_xc
1547
1548 CHARACTER(len=*), PARAMETER :: routinen = 'xc_calc_2nd_deriv'
1549
1550 INTEGER :: handle, ispin, nspins
1551 INTEGER, DIMENSION(2, 3) :: bo
1552 LOGICAL :: lsd, my_compute_virial, &
1553 my_do_excitations, my_do_sf, &
1554 my_do_triplet
1555 REAL(kind=dp) :: fac
1556 TYPE(section_vals_type), POINTER :: xc_fun_section
1557 TYPE(xc_rho_cflags_type) :: needs
1558 TYPE(xc_rho_set_type) :: rho1_set
1559
1560 CALL timeset(routinen, handle)
1561
1562 my_compute_virial = .false.
1563 IF (PRESENT(compute_virial)) my_compute_virial = compute_virial
1564
1565 my_do_sf = .false.
1566 IF (PRESENT(do_sf)) my_do_sf = do_sf
1567
1568 my_do_excitations = .false.
1569 IF (PRESENT(do_excitations)) my_do_excitations = do_excitations
1570
1571 my_do_triplet = .false.
1572 IF (PRESENT(do_triplet)) my_do_triplet = do_triplet
1573
1574 nspins = SIZE(rho1_r)
1575 lsd = (nspins == 2)
1576 IF (nspins == 1 .AND. my_do_excitations .AND. my_do_triplet) THEN
1577 nspins = 2
1578 lsd = .true.
1579 ELSE IF (my_do_sf) THEN
1580 nspins = 1
1581 lsd = .true.
1582 END IF
1583
1584 NULLIFY (v_xc, v_xc_tau)
1585 ALLOCATE (v_xc(nspins))
1586 DO ispin = 1, nspins
1587 CALL pw_pool%create_pw(v_xc(ispin))
1588 CALL pw_zero(v_xc(ispin))
1589 END DO
1590
1591 xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
1592 needs = xc_functionals_get_needs(xc_fun_section, lsd, .true.)
1593
1594 IF (needs%tau .OR. needs%tau_spin) THEN
1595 IF (.NOT. ASSOCIATED(tau1_r)) &
1596 cpabort("Tau-dependent functionals requires allocated kinetic energy density grid")
1597 ALLOCATE (v_xc_tau(nspins))
1598 DO ispin = 1, nspins
1599 CALL pw_pool%create_pw(v_xc_tau(ispin))
1600 CALL pw_zero(v_xc_tau(ispin))
1601 END DO
1602 END IF
1603
1604 IF (section_get_lval(xc_section, "2ND_DERIV_ANALYTICAL")) THEN
1605 !------!
1606 ! rho1 !
1607 !------!
1608 bo = rho1_r(1)%pw_grid%bounds_local
1609 ! create the place where to store the argument for the functionals
1610 CALL xc_rho_set_create(rho1_set, bo, &
1611 rho_cutoff=section_get_rval(xc_section, "DENSITY_CUTOFF"), &
1612 drho_cutoff=section_get_rval(xc_section, "GRADIENT_CUTOFF"), &
1613 tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF"))
1614
1615 ! calculate the arguments needed by the functionals
1616 CALL xc_rho_set_update(rho1_set, rho1_r, rho1_g, tau1_r, needs, &
1617 section_get_ival(xc_section, "XC_GRID%XC_DERIV"), &
1618 section_get_ival(xc_section, "XC_GRID%XC_SMOOTH_RHO"), &
1619 pw_pool, spinflip=my_do_sf)
1620
1621 fac = 0._dp
1622 IF (nspins == 1 .AND. my_do_excitations) THEN
1623 IF (my_do_triplet) fac = -1.0_dp
1624 END IF
1625
1626 CALL xc_calc_2nd_deriv_analytical(v_xc, v_xc_tau, deriv_set, rho_set, &
1627 rho1_set, pw_pool, xc_section, gapw, vxg=vxg, spinflip=my_do_sf, &
1628 tddfpt_fac=fac, compute_virial=compute_virial, virial_xc=virial_xc)
1629
1630 CALL xc_rho_set_release(rho1_set)
1631
1632 ELSE
1633 IF (gapw) cpabort("Numerical 2nd derivatives not implemented with GAPW")
1634
1635 CALL xc_calc_2nd_deriv_numerical(v_xc, v_xc_tau, rho_set, rho1_r, rho1_g, tau1_r, &
1636 pw_pool, xc_section, &
1637 my_do_excitations .AND. my_do_triplet, &
1638 compute_virial, virial_xc, deriv_set)
1639 END IF
1640
1641 CALL timestop(handle)
1642
1643 END SUBROUTINE xc_calc_2nd_deriv
1644
1645! **************************************************************************************************
1646!> \brief calculates 2nd derivative numerically
1647!> \param v_xc potential to be calculated (has to be allocated already)
1648!> \param v_tau tau-part of the potential to be calculated (has to be allocated already)
1649!> \param rho_set KS density from xc_prep_2nd_deriv
1650!> \param rho1_r first-order density in r-space
1651!> \param rho1_g first-order density in g-space
1652!> \param tau1_r first-order kinetic-energy density in r-space
1653!> \param pw_pool pw pool for new grids
1654!> \param xc_section XC section to calculate the derivatives from
1655!> \param do_triplet ...
1656!> \param calc_virial whether to calculate virial terms
1657!> \param virial_xc collects stress tensor components (no metaGGAs!)
1658!> \param deriv_set deriv set from xc_prep_2nd_deriv (only for virials)
1659! **************************************************************************************************
1660 SUBROUTINE xc_calc_2nd_deriv_numerical(v_xc, v_tau, rho_set, rho1_r, rho1_g, tau1_r, &
1661 pw_pool, xc_section, &
1662 do_triplet, calc_virial, virial_xc, deriv_set)
1663
1664 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(IN), POINTER :: v_xc, v_tau
1665 TYPE(xc_rho_set_type), INTENT(IN) :: rho_set
1666 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(IN), POINTER :: rho1_r, tau1_r
1667 TYPE(pw_c1d_gs_type), DIMENSION(:), INTENT(IN), POINTER :: rho1_g
1668 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
1669 TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section
1670 LOGICAL, INTENT(IN) :: do_triplet
1671 LOGICAL, INTENT(IN), OPTIONAL :: calc_virial
1672 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT), &
1673 OPTIONAL :: virial_xc
1674 TYPE(xc_derivative_set_type), OPTIONAL :: deriv_set
1675
1676 CHARACTER(len=*), PARAMETER :: routinen = 'xc_calc_2nd_deriv_numerical'
1677 REAL(kind=dp), DIMENSION(-4:4, 4), PARAMETER :: &
1678 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, &
1679 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, &
1680 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, &
1681 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])
1682
1683 INTEGER :: handle, idir, ispin, nspins, istep, nsteps
1684 INTEGER, DIMENSION(2, 3) :: bo
1685 LOGICAL :: gradient_f, lsd, my_calc_virial, tau_f, laplace_f, rho_f
1686 REAL(kind=dp) :: exc, gradient_cut, h, weight, step, rho_cutoff
1687 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :) :: dr1dr, dra1dra, drb1drb
1688 REAL(kind=dp), DIMENSION(3, 3) :: virial_dummy
1689 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: norm_drho, norm_drho2, norm_drho2a, &
1690 norm_drho2b, norm_drhoa, norm_drhob, &
1691 rho, rho1, rho1a, rho1b, rhoa, rhob, &
1692 tau_a, tau_b, tau, tau1, tau1a, tau1b, laplace, laplace1, &
1693 laplacea, laplaceb, laplace1a, laplace1b, &
1694 laplace2, laplace2a, laplace2b, deriv_data
1695 TYPE(cp_3d_r_cp_type), DIMENSION(3) :: drho, drho1, drho1a, drho1b, drhoa, drhob
1696 TYPE(pw_r3d_rs_type) :: v_drho, v_drhoa, v_drhob
1697 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: vxc_rho, vxc_tau
1698 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
1699 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r, tau_r
1700 TYPE(pw_r3d_rs_type) :: virial_pw, v_laplace, v_laplacea, v_laplaceb
1701 TYPE(section_vals_type), POINTER :: xc_fun_section
1702 TYPE(xc_derivative_set_type) :: deriv_set1
1703 TYPE(xc_rho_cflags_type) :: needs
1704 TYPE(xc_rho_set_type) :: rho1_set, rho2_set
1705
1706 CALL timeset(routinen, handle)
1707
1708 my_calc_virial = .false.
1709 IF (PRESENT(calc_virial) .AND. PRESENT(virial_xc)) my_calc_virial = calc_virial
1710
1711 nspins = SIZE(v_xc)
1712
1713 NULLIFY (tau, tau_r, tau_a, tau_b)
1714
1715 h = section_get_rval(xc_section, "STEP_SIZE")
1716 nsteps = section_get_ival(xc_section, "NSTEPS")
1717 IF (nsteps < lbound(weights, 2) .OR. nspins > ubound(weights, 2)) THEN
1718 cpabort("The number of steps must be a value from 1 to 4.")
1719 END IF
1720
1721 IF (nspins == 2) THEN
1722 NULLIFY (vxc_rho, rho_g, vxc_tau)
1723 ALLOCATE (rho_r(2))
1724 DO ispin = 1, nspins
1725 CALL pw_pool%create_pw(rho_r(ispin))
1726 END DO
1727 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(v_tau)) THEN
1728 ALLOCATE (tau_r(2))
1729 DO ispin = 1, nspins
1730 CALL pw_pool%create_pw(tau_r(ispin))
1731 END DO
1732 END IF
1733 CALL xc_rho_set_get(rho_set, can_return_null=.true., rhoa=rhoa, rhob=rhob, tau_a=tau_a, tau_b=tau_b)
1734 DO istep = -nsteps, nsteps
1735 IF (istep == 0) cycle
1736 weight = weights(istep, nsteps)/h
1737 step = real(istep, dp)*h
1738 CALL calc_resp_potential_numer_ab(rho_r, rho_g, rho1_r, rhoa, rhob, vxc_rho, &
1739 tau_r, tau1_r, tau_a, tau_b, vxc_tau, xc_section, pw_pool, step)
1740 DO ispin = 1, nspins
1741 CALL pw_axpy(vxc_rho(ispin), v_xc(ispin), weight)
1742 IF (ASSOCIATED(vxc_tau) .AND. ASSOCIATED(v_tau)) THEN
1743 CALL pw_axpy(vxc_tau(ispin), v_tau(ispin), weight)
1744 END IF
1745 END DO
1746 DO ispin = 1, nspins
1747 CALL vxc_rho(ispin)%release()
1748 END DO
1749 DEALLOCATE (vxc_rho)
1750 IF (ASSOCIATED(vxc_tau)) THEN
1751 DO ispin = 1, nspins
1752 CALL vxc_tau(ispin)%release()
1753 END DO
1754 DEALLOCATE (vxc_tau)
1755 END IF
1756 END DO
1757 ELSE IF (nspins == 1 .AND. do_triplet) THEN
1758 NULLIFY (vxc_rho, vxc_tau, rho_g)
1759 ALLOCATE (rho_r(2))
1760 DO ispin = 1, 2
1761 CALL pw_pool%create_pw(rho_r(ispin))
1762 END DO
1763 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(v_tau)) THEN
1764 ALLOCATE (tau_r(2))
1765 DO ispin = 1, nspins
1766 CALL pw_pool%create_pw(tau_r(ispin))
1767 END DO
1768 END IF
1769 CALL xc_rho_set_get(rho_set, can_return_null=.true., rhoa=rhoa, rhob=rhob, tau_a=tau_a, tau_b=tau_b)
1770 DO istep = -nsteps, nsteps
1771 IF (istep == 0) cycle
1772 weight = weights(istep, nsteps)/h
1773 step = real(istep, dp)*h
1774 ! K(alpha,alpha)
1775!$OMP PARALLEL DEFAULT(NONE) SHARED(rho_r,rhoa,rhob,step,rho1_r,tau_r,tau_a,tau_b,tau1_r)
1776!$OMP WORKSHARE
1777 rho_r(1)%array(:, :, :) = rhoa(:, :, :) + step*rho1_r(1)%array(:, :, :)
1778!$OMP END WORKSHARE NOWAIT
1779!$OMP WORKSHARE
1780 rho_r(2)%array(:, :, :) = rhob(:, :, :)
1781!$OMP END WORKSHARE NOWAIT
1782 IF (ASSOCIATED(tau1_r)) THEN
1783!$OMP WORKSHARE
1784 tau_r(1)%array(:, :, :) = tau_a(:, :, :) + step*tau1_r(1)%array(:, :, :)
1785!$OMP END WORKSHARE NOWAIT
1786!$OMP WORKSHARE
1787 tau_r(2)%array(:, :, :) = tau_b(:, :, :)
1788!$OMP END WORKSHARE NOWAIT
1789 END IF
1790!$OMP END PARALLEL
1791 CALL xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau_r, xc_section, &
1792 pw_pool, .false., virial_dummy)
1793 CALL pw_axpy(vxc_rho(1), v_xc(1), weight)
1794 IF (ASSOCIATED(vxc_tau) .AND. ASSOCIATED(v_tau)) THEN
1795 CALL pw_axpy(vxc_tau(1), v_tau(1), weight)
1796 END IF
1797 DO ispin = 1, 2
1798 CALL vxc_rho(ispin)%release()
1799 END DO
1800 DEALLOCATE (vxc_rho)
1801 IF (ASSOCIATED(vxc_tau)) THEN
1802 DO ispin = 1, 2
1803 CALL vxc_tau(ispin)%release()
1804 END DO
1805 DEALLOCATE (vxc_tau)
1806 END IF
1807!$OMP PARALLEL DEFAULT(NONE) SHARED(rho_r,rhoa,rhob,step,rho1_r,tau_r,tau_a,tau_b,tau1_r)
1808!$OMP WORKSHARE
1809 ! K(alpha,beta)
1810 rho_r(1)%array(:, :, :) = rhoa(:, :, :)
1811!$OMP END WORKSHARE NOWAIT
1812!$OMP WORKSHARE
1813 rho_r(2)%array(:, :, :) = rhob(:, :, :) + step*rho1_r(1)%array(:, :, :)
1814!$OMP END WORKSHARE NOWAIT
1815 IF (ASSOCIATED(tau1_r)) THEN
1816!$OMP WORKSHARE
1817 tau_r(1)%array(:, :, :) = tau_a(:, :, :)
1818!$OMP END WORKSHARE NOWAIT
1819!$OMP WORKSHARE
1820 tau_r(2)%array(:, :, :) = tau_b(:, :, :) + step*tau1_r(1)%array(:, :, :)
1821!$OMP END WORKSHARE NOWAIT
1822 END IF
1823!$OMP END PARALLEL
1824 CALL xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau_r, xc_section, &
1825 pw_pool, .false., virial_dummy)
1826 CALL pw_axpy(vxc_rho(1), v_xc(1), weight)
1827 IF (ASSOCIATED(vxc_tau) .AND. ASSOCIATED(v_tau)) THEN
1828 CALL pw_axpy(vxc_tau(1), v_tau(1), weight)
1829 END IF
1830 DO ispin = 1, 2
1831 CALL vxc_rho(ispin)%release()
1832 END DO
1833 DEALLOCATE (vxc_rho)
1834 IF (ASSOCIATED(vxc_tau)) THEN
1835 DO ispin = 1, 2
1836 CALL vxc_tau(ispin)%release()
1837 END DO
1838 DEALLOCATE (vxc_tau)
1839 END IF
1840 END DO
1841 ELSE
1842 NULLIFY (vxc_rho, rho_r, rho_g, vxc_tau, tau_r, tau)
1843 ALLOCATE (rho_r(1))
1844 CALL pw_pool%create_pw(rho_r(1))
1845 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(v_tau)) THEN
1846 ALLOCATE (tau_r(1))
1847 CALL pw_pool%create_pw(tau_r(1))
1848 END IF
1849 CALL xc_rho_set_get(rho_set, can_return_null=.true., rho=rho, tau=tau)
1850 DO istep = -nsteps, nsteps
1851 IF (istep == 0) cycle
1852 weight = weights(istep, nsteps)/h
1853 step = real(istep, dp)*h
1854!$OMP PARALLEL DEFAULT(NONE) SHARED(rho_r,rho,step,rho1_r,tau1_r,tau,tau_r)
1855!$OMP WORKSHARE
1856 rho_r(1)%array(:, :, :) = rho(:, :, :) + step*rho1_r(1)%array(:, :, :)
1857!$OMP END WORKSHARE NOWAIT
1858 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(tau) .AND. ASSOCIATED(tau1_r)) THEN
1859!$OMP WORKSHARE
1860 tau_r(1)%array(:, :, :) = tau(:, :, :) + step*tau1_r(1)%array(:, :, :)
1861!$OMP END WORKSHARE NOWAIT
1862 END IF
1863!$OMP END PARALLEL
1864 CALL xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau_r, xc_section, &
1865 pw_pool, .false., virial_dummy)
1866 CALL pw_axpy(vxc_rho(1), v_xc(1), weight)
1867 IF (ASSOCIATED(vxc_tau) .AND. ASSOCIATED(v_tau)) THEN
1868 CALL pw_axpy(vxc_tau(1), v_tau(1), weight)
1869 END IF
1870 CALL vxc_rho(1)%release()
1871 DEALLOCATE (vxc_rho)
1872 IF (ASSOCIATED(vxc_tau)) THEN
1873 CALL vxc_tau(1)%release()
1874 DEALLOCATE (vxc_tau)
1875 END IF
1876 END DO
1877 END IF
1878
1879 IF (my_calc_virial) THEN
1880 lsd = (nspins == 2)
1881 IF (nspins == 1 .AND. do_triplet) THEN
1882 lsd = .true.
1883 END IF
1884
1885 CALL check_for_derivatives(deriv_set, (nspins == 2), rho_f, gradient_f, tau_f, laplace_f)
1886
1887 ! Calculate the virial terms
1888 ! Those arising from the first derivatives are treated like in xc_calc_2nd_deriv_analytical
1889 ! Those arising from the second derivatives are calculated numerically
1890 ! We assume that all metaGGA functionals require the gradient
1891 IF (gradient_f) THEN
1892 bo = rho_set%local_bounds
1893
1894 ! Create the work grid for the virial terms
1895 CALL allocate_pw(virial_pw, pw_pool, bo)
1896
1897 gradient_cut = section_get_rval(xc_section, "GRADIENT_CUTOFF")
1898
1899 ! create the container to store the argument of the functionals
1900 CALL xc_rho_set_create(rho1_set, bo, &
1901 rho_cutoff=section_get_rval(xc_section, "DENSITY_CUTOFF"), &
1902 drho_cutoff=gradient_cut, &
1903 tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF"))
1904
1905 xc_fun_section => section_vals_get_subs_vals(xc_section, "XC_FUNCTIONAL")
1906 needs = xc_functionals_get_needs(xc_fun_section, lsd, .true.)
1907
1908 ! calculate the arguments needed by the functionals
1909 CALL xc_rho_set_update(rho1_set, rho1_r, rho1_g, tau1_r, needs, &
1910 section_get_ival(xc_section, "XC_GRID%XC_DERIV"), &
1911 section_get_ival(xc_section, "XC_GRID%XC_SMOOTH_RHO"), &
1912 pw_pool)
1913
1914 IF (lsd) THEN
1915 CALL xc_rho_set_get(rho_set, drhoa=drhoa, drhob=drhob, norm_drho=norm_drho, &
1916 norm_drhoa=norm_drhoa, norm_drhob=norm_drhob, tau_a=tau_a, tau_b=tau_b, &
1917 laplace_rhoa=laplacea, laplace_rhob=laplaceb, can_return_null=.true.)
1918 CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b, drhoa=drho1a, drhob=drho1b, laplace_rhoa=laplace1a, &
1919 laplace_rhob=laplace1b, can_return_null=.true.)
1920
1921 CALL calc_drho_from_ab(drho, drhoa, drhob)
1922 CALL calc_drho_from_ab(drho1, drho1a, drho1b)
1923 ELSE
1924 CALL xc_rho_set_get(rho_set, drho=drho, norm_drho=norm_drho, tau=tau, laplace_rho=laplace, can_return_null=.true.)
1925 CALL xc_rho_set_get(rho1_set, rho=rho1, drho=drho1, laplace_rho=laplace1, can_return_null=.true.)
1926 END IF
1927
1928 CALL prepare_dr1dr(dr1dr, drho, drho1)
1929
1930 IF (lsd) THEN
1931 CALL prepare_dr1dr(dra1dra, drhoa, drho1a)
1932 CALL prepare_dr1dr(drb1drb, drhob, drho1b)
1933
1934 CALL allocate_pw(v_drho, pw_pool, bo)
1935 CALL allocate_pw(v_drhoa, pw_pool, bo)
1936 CALL allocate_pw(v_drhob, pw_pool, bo)
1937
1938 IF (ASSOCIATED(norm_drhoa)) CALL apply_drho(deriv_set, [deriv_norm_drhoa], virial_pw, drhoa, drho1a, virial_xc, &
1939 norm_drhoa, gradient_cut, dra1dra, v_drhoa%array)
1940 IF (ASSOCIATED(norm_drhob)) CALL apply_drho(deriv_set, [deriv_norm_drhob], virial_pw, drhob, drho1b, virial_xc, &
1941 norm_drhob, gradient_cut, drb1drb, v_drhob%array)
1942 IF (ASSOCIATED(norm_drho)) CALL apply_drho(deriv_set, [deriv_norm_drho], virial_pw, drho, drho1, virial_xc, &
1943 norm_drho, gradient_cut, dr1dr, v_drho%array)
1944 IF (laplace_f) THEN
1945 CALL xc_derivative_get(xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa]), deriv_data=deriv_data)
1946 cpassert(ASSOCIATED(deriv_data))
1947 virial_pw%array(:, :, :) = -rho1a(:, :, :)
1948 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
1949
1950 CALL allocate_pw(v_laplacea, pw_pool, bo)
1951
1952 CALL xc_derivative_get(xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob]), deriv_data=deriv_data)
1953 cpassert(ASSOCIATED(deriv_data))
1954 virial_pw%array(:, :, :) = -rho1b(:, :, :)
1955 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
1956
1957 CALL allocate_pw(v_laplaceb, pw_pool, bo)
1958 END IF
1959
1960 ELSE
1961
1962 ! Create the work grid for the potential of the gradient part
1963 CALL allocate_pw(v_drho, pw_pool, bo)
1964
1965 CALL apply_drho(deriv_set, [deriv_norm_drho], virial_pw, drho, drho1, virial_xc, &
1966 norm_drho, gradient_cut, dr1dr, v_drho%array)
1967 IF (laplace_f) THEN
1968 CALL xc_derivative_get(xc_dset_get_derivative(deriv_set, [deriv_laplace_rho]), deriv_data=deriv_data)
1969 cpassert(ASSOCIATED(deriv_data))
1970 virial_pw%array(:, :, :) = -rho1(:, :, :)
1971 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
1972
1973 CALL allocate_pw(v_laplace, pw_pool, bo)
1974 END IF
1975
1976 END IF
1977
1978 IF (lsd) THEN
1979 rho_r(1)%array = rhoa
1980 rho_r(2)%array = rhob
1981 ELSE
1982 rho_r(1)%array = rho
1983 END IF
1984 IF (ASSOCIATED(tau1_r)) THEN
1985 IF (lsd) THEN
1986 tau_r(1)%array = tau_a
1987 tau_r(2)%array = tau_b
1988 ELSE
1989 tau_r(1)%array = tau
1990 END IF
1991 END IF
1992
1993 ! Create deriv sets with same densities but different gradients
1994 CALL xc_dset_create(deriv_set1, pw_pool)
1995
1996 rho_cutoff = section_get_rval(xc_section, "DENSITY_CUTOFF")
1997
1998 ! create the place where to store the argument for the functionals
1999 CALL xc_rho_set_create(rho2_set, bo, &
2000 rho_cutoff=rho_cutoff, &
2001 drho_cutoff=section_get_rval(xc_section, "GRADIENT_CUTOFF"), &
2002 tau_cutoff=section_get_rval(xc_section, "TAU_CUTOFF"))
2003
2004 ! calculate the arguments needed by the functionals
2005 CALL xc_rho_set_update(rho2_set, rho_r, rho_g, tau_r, needs, &
2006 section_get_ival(xc_section, "XC_GRID%XC_DERIV"), &
2007 section_get_ival(xc_section, "XC_GRID%XC_SMOOTH_RHO"), &
2008 pw_pool)
2009
2010 IF (lsd) THEN
2011 CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b, tau_a=tau1a, tau_b=tau1b, &
2012 laplace_rhoa=laplace1a, laplace_rhob=laplace1b, can_return_null=.true.)
2013 CALL xc_rho_set_get(rho2_set, norm_drhoa=norm_drho2a, norm_drhob=norm_drho2b, &
2014 norm_drho=norm_drho2, laplace_rhoa=laplace2a, laplace_rhob=laplace2b, can_return_null=.true.)
2015
2016 DO istep = -nsteps, nsteps
2017 IF (istep == 0) cycle
2018 weight = weights(istep, nsteps)/h
2019 step = real(istep, dp)*h
2020 IF (ASSOCIATED(norm_drhoa)) THEN
2021 CALL get_derivs_rho(norm_drho2a, norm_drhoa, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2022 CALL update_deriv_rho(deriv_set1, [deriv_rhoa], bo, &
2023 norm_drhoa, gradient_cut, weight, rho1a, v_drhoa%array)
2024 CALL update_deriv_rho(deriv_set1, [deriv_rhob], bo, &
2025 norm_drhoa, gradient_cut, weight, rho1b, v_drhoa%array)
2026 CALL update_deriv_rho(deriv_set1, [deriv_norm_drhoa], bo, &
2027 norm_drhoa, gradient_cut, weight, dra1dra, v_drhoa%array)
2028 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drhob], bo, &
2029 norm_drhoa, gradient_cut, weight, dra1dra, drb1drb, v_drhoa%array, v_drhob%array)
2030 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drho], bo, &
2031 norm_drhoa, gradient_cut, weight, dra1dra, dr1dr, v_drhoa%array, v_drho%array)
2032 IF (tau_f) THEN
2033 CALL update_deriv_rho(deriv_set1, [deriv_tau_a], bo, &
2034 norm_drhoa, gradient_cut, weight, tau1a, v_drhoa%array)
2035 CALL update_deriv_rho(deriv_set1, [deriv_tau_b], bo, &
2036 norm_drhoa, gradient_cut, weight, tau1b, v_drhoa%array)
2037 END IF
2038 IF (laplace_f) THEN
2039 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhoa], bo, &
2040 norm_drhoa, gradient_cut, weight, laplace1a, v_drhoa%array)
2041 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhob], bo, &
2042 norm_drhoa, gradient_cut, weight, laplace1b, v_drhoa%array)
2043 END IF
2044 END IF
2045
2046 IF (ASSOCIATED(norm_drhob)) THEN
2047 CALL get_derivs_rho(norm_drho2b, norm_drhob, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2048 CALL update_deriv_rho(deriv_set1, [deriv_rhoa], bo, &
2049 norm_drhob, gradient_cut, weight, rho1a, v_drhob%array)
2050 CALL update_deriv_rho(deriv_set1, [deriv_rhob], bo, &
2051 norm_drhob, gradient_cut, weight, rho1b, v_drhob%array)
2052 CALL update_deriv_rho(deriv_set1, [deriv_norm_drhob], bo, &
2053 norm_drhob, gradient_cut, weight, drb1drb, v_drhob%array)
2054 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drhoa], bo, &
2055 norm_drhob, gradient_cut, weight, drb1drb, dra1dra, v_drhob%array, v_drhoa%array)
2056 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drho], bo, &
2057 norm_drhob, gradient_cut, weight, drb1drb, dr1dr, v_drhob%array, v_drho%array)
2058 IF (tau_f) THEN
2059 CALL update_deriv_rho(deriv_set1, [deriv_tau_a], bo, &
2060 norm_drhob, gradient_cut, weight, tau1a, v_drhob%array)
2061 CALL update_deriv_rho(deriv_set1, [deriv_tau_b], bo, &
2062 norm_drhob, gradient_cut, weight, tau1b, v_drhob%array)
2063 END IF
2064 IF (laplace_f) THEN
2065 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhoa], bo, &
2066 norm_drhob, gradient_cut, weight, laplace1a, v_drhob%array)
2067 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhob], bo, &
2068 norm_drhob, gradient_cut, weight, laplace1b, v_drhob%array)
2069 END IF
2070 END IF
2071
2072 IF (ASSOCIATED(norm_drho)) THEN
2073 CALL get_derivs_rho(norm_drho2, norm_drho, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2074 CALL update_deriv_rho(deriv_set1, [deriv_rhoa], bo, &
2075 norm_drho, gradient_cut, weight, rho1a, v_drho%array)
2076 CALL update_deriv_rho(deriv_set1, [deriv_rhob], bo, &
2077 norm_drho, gradient_cut, weight, rho1b, v_drho%array)
2078 CALL update_deriv_rho(deriv_set1, [deriv_norm_drho], bo, &
2079 norm_drho, gradient_cut, weight, dr1dr, v_drho%array)
2080 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drhoa], bo, &
2081 norm_drho, gradient_cut, weight, dr1dr, dra1dra, v_drho%array, v_drhoa%array)
2082 CALL update_deriv_drho_ab(deriv_set1, [deriv_norm_drhob], bo, &
2083 norm_drho, gradient_cut, weight, dr1dr, drb1drb, v_drho%array, v_drhob%array)
2084 IF (tau_f) THEN
2085 CALL update_deriv_rho(deriv_set1, [deriv_tau_a], bo, &
2086 norm_drho, gradient_cut, weight, tau1a, v_drho%array)
2087 CALL update_deriv_rho(deriv_set1, [deriv_tau_b], bo, &
2088 norm_drho, gradient_cut, weight, tau1b, v_drho%array)
2089 END IF
2090 IF (laplace_f) THEN
2091 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhoa], bo, &
2092 norm_drho, gradient_cut, weight, laplace1a, v_drho%array)
2093 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rhob], bo, &
2094 norm_drho, gradient_cut, weight, laplace1b, v_drho%array)
2095 END IF
2096 END IF
2097
2098 IF (laplace_f) THEN
2099
2100 CALL get_derivs_rho(laplace2a, laplacea, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2101
2102 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2103 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_rhoa], bo, &
2104 weight, rho1a, v_laplacea%array)
2105 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_rhob], bo, &
2106 weight, rho1b, v_laplacea%array)
2107 IF (ASSOCIATED(norm_drho)) THEN
2108 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_norm_drho], bo, &
2109 weight, dr1dr, v_laplacea%array)
2110 END IF
2111 IF (ASSOCIATED(norm_drhoa)) THEN
2112 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_norm_drhoa], bo, &
2113 weight, dra1dra, v_laplacea%array)
2114 END IF
2115 IF (ASSOCIATED(norm_drhob)) THEN
2116 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_norm_drhob], bo, &
2117 weight, drb1drb, v_laplacea%array)
2118 END IF
2119
2120 IF (ASSOCIATED(tau1a)) THEN
2121 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_tau_a], bo, &
2122 weight, tau1a, v_laplacea%array)
2123 END IF
2124 IF (ASSOCIATED(tau1b)) THEN
2125 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_tau_b], bo, &
2126 weight, tau1b, v_laplacea%array)
2127 END IF
2128
2129 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_laplace_rhoa], bo, &
2130 weight, laplace1a, v_laplacea%array)
2131
2132 CALL update_deriv(deriv_set1, laplacea, rho_cutoff, [deriv_laplace_rhob], bo, &
2133 weight, laplace1b, v_laplacea%array)
2134
2135 ! The same for the beta spin
2136 CALL get_derivs_rho(laplace2b, laplaceb, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2137
2138 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2139 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_rhoa], bo, &
2140 weight, rho1a, v_laplaceb%array)
2141 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_rhob], bo, &
2142 weight, rho1b, v_laplaceb%array)
2143 IF (ASSOCIATED(norm_drho)) THEN
2144 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_norm_drho], bo, &
2145 weight, dr1dr, v_laplaceb%array)
2146 END IF
2147 IF (ASSOCIATED(norm_drhoa)) THEN
2148 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_norm_drhoa], bo, &
2149 weight, dra1dra, v_laplaceb%array)
2150 END IF
2151 IF (ASSOCIATED(norm_drhob)) THEN
2152 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_norm_drhob], bo, &
2153 weight, drb1drb, v_laplaceb%array)
2154 END IF
2155
2156 IF (tau_f) THEN
2157 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_tau_a], bo, &
2158 weight, tau1a, v_laplaceb%array)
2159 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_tau_b], bo, &
2160 weight, tau1b, v_laplaceb%array)
2161 END IF
2162
2163 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_laplace_rhoa], bo, &
2164 weight, laplace1a, v_laplaceb%array)
2165
2166 CALL update_deriv(deriv_set1, laplaceb, rho_cutoff, [deriv_laplace_rhob], bo, &
2167 weight, laplace1b, v_laplaceb%array)
2168 END IF
2169 END DO
2170
2171 CALL virial_drho_drho(virial_pw, drhoa, v_drhoa, virial_xc)
2172 CALL virial_drho_drho(virial_pw, drhob, v_drhob, virial_xc)
2173 CALL virial_drho_drho(virial_pw, drho, v_drho, virial_xc)
2174
2175 CALL deallocate_pw(v_drho, pw_pool)
2176 CALL deallocate_pw(v_drhoa, pw_pool)
2177 CALL deallocate_pw(v_drhob, pw_pool)
2178
2179 IF (laplace_f) THEN
2180 virial_pw%array(:, :, :) = -rhoa(:, :, :)
2181 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplacea%array)
2182 CALL deallocate_pw(v_laplacea, pw_pool)
2183
2184 virial_pw%array(:, :, :) = -rhob(:, :, :)
2185 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplaceb%array)
2186 CALL deallocate_pw(v_laplaceb, pw_pool)
2187 END IF
2188
2189 CALL deallocate_pw(virial_pw, pw_pool)
2190
2191 DO idir = 1, 3
2192 DEALLOCATE (drho(idir)%array)
2193 DEALLOCATE (drho1(idir)%array)
2194 END DO
2195 DEALLOCATE (dra1dra, drb1drb)
2196
2197 ELSE
2198 CALL xc_rho_set_get(rho1_set, rho=rho1, tau=tau1, laplace_rho=laplace1, can_return_null=.true.)
2199 CALL xc_rho_set_get(rho2_set, norm_drho=norm_drho2, laplace_rho=laplace2, can_return_null=.true.)
2200
2201 DO istep = -nsteps, nsteps
2202 IF (istep == 0) cycle
2203 weight = weights(istep, nsteps)/h
2204 step = real(istep, dp)*h
2205 CALL get_derivs_rho(norm_drho2, norm_drho, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2206
2207 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2208 CALL update_deriv_rho(deriv_set1, [deriv_rho], bo, &
2209 norm_drho, gradient_cut, weight, rho1, v_drho%array)
2210 CALL update_deriv_rho(deriv_set1, [deriv_norm_drho], bo, &
2211 norm_drho, gradient_cut, weight, dr1dr, v_drho%array)
2212
2213 IF (tau_f) THEN
2214 CALL update_deriv_rho(deriv_set1, [deriv_tau], bo, &
2215 norm_drho, gradient_cut, weight, tau1, v_drho%array)
2216 END IF
2217 IF (laplace_f) THEN
2218 CALL update_deriv_rho(deriv_set1, [deriv_laplace_rho], bo, &
2219 norm_drho, gradient_cut, weight, laplace1, v_drho%array)
2220
2221 CALL get_derivs_rho(laplace2, laplace, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2222
2223 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2224 CALL update_deriv(deriv_set1, laplace, rho_cutoff, [deriv_rho], bo, &
2225 weight, rho1, v_laplace%array)
2226 CALL update_deriv(deriv_set1, laplace, rho_cutoff, [deriv_norm_drho], bo, &
2227 weight, dr1dr, v_laplace%array)
2228
2229 IF (tau_f) THEN
2230 CALL update_deriv(deriv_set1, laplace, rho_cutoff, [deriv_tau], bo, &
2231 weight, tau1, v_laplace%array)
2232 END IF
2233
2234 CALL update_deriv(deriv_set1, laplace, rho_cutoff, [deriv_laplace_rho], bo, &
2235 weight, laplace1, v_laplace%array)
2236 END IF
2237 END DO
2238
2239 ! Calculate the virial contribution from the potential
2240 CALL virial_drho_drho(virial_pw, drho, v_drho, virial_xc)
2241
2242 CALL deallocate_pw(v_drho, pw_pool)
2243
2244 IF (laplace_f) THEN
2245 virial_pw%array(:, :, :) = -rho(:, :, :)
2246 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplace%array)
2247 CALL deallocate_pw(v_laplace, pw_pool)
2248 END IF
2249
2250 CALL deallocate_pw(virial_pw, pw_pool)
2251 END IF
2252
2253 END IF
2254
2255 CALL xc_dset_release(deriv_set1)
2256
2257 DEALLOCATE (dr1dr)
2258
2259 CALL xc_rho_set_release(rho1_set)
2260 CALL xc_rho_set_release(rho2_set)
2261 END IF
2262
2263 DO ispin = 1, SIZE(rho_r)
2264 CALL pw_pool%give_back_pw(rho_r(ispin))
2265 END DO
2266 DEALLOCATE (rho_r)
2267
2268 IF (ASSOCIATED(tau_r)) THEN
2269 DO ispin = 1, SIZE(tau_r)
2270 CALL pw_pool%give_back_pw(tau_r(ispin))
2271 END DO
2272 DEALLOCATE (tau_r)
2273 END IF
2274
2275 CALL timestop(handle)
2276
2277 END SUBROUTINE xc_calc_2nd_deriv_numerical
2278
2279! **************************************************************************************************
2280!> \brief ...
2281!> \param rho_r ...
2282!> \param rho_g ...
2283!> \param rho1_r ...
2284!> \param rhoa ...
2285!> \param rhob ...
2286!> \param vxc_rho ...
2287!> \param tau_r ...
2288!> \param tau1_r ...
2289!> \param tau_a ...
2290!> \param tau_b ...
2291!> \param vxc_tau ...
2292!> \param xc_section ...
2293!> \param pw_pool ...
2294!> \param step ...
2295! **************************************************************************************************
2296 SUBROUTINE calc_resp_potential_numer_ab(rho_r, rho_g, rho1_r, rhoa, rhob, vxc_rho, &
2297 tau_r, tau1_r, tau_a, tau_b, vxc_tau, &
2298 xc_section, pw_pool, step)
2299
2300 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER, INTENT(IN) :: vxc_rho, vxc_tau
2301 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(IN) :: rho1_r
2302 TYPE(pw_r3d_rs_type), DIMENSION(:), INTENT(IN), POINTER :: tau1_r
2303 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
2304 TYPE(section_vals_type), INTENT(IN), POINTER :: xc_section
2305 REAL(kind=dp), INTENT(IN) :: step
2306 REAL(kind=dp), DIMENSION(:, :, :), POINTER, INTENT(IN) :: rhoa, rhob, tau_a, tau_b
2307 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER, INTENT(IN) :: rho_r
2308 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
2309 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: tau_r
2310
2311 CHARACTER(len=*), PARAMETER :: routinen = 'calc_resp_potential_numer_ab'
2312
2313 INTEGER :: handle
2314 REAL(kind=dp) :: exc
2315 REAL(kind=dp), DIMENSION(3, 3) :: virial_dummy
2316
2317 CALL timeset(routinen, handle)
2318
2319!$OMP PARALLEL DEFAULT(NONE) SHARED(rho_r,rhoa,rhob,step,rho1_r,tau_r,tau_a,tau_b,tau1_r)
2320!$OMP WORKSHARE
2321 rho_r(1)%array(:, :, :) = rhoa(:, :, :) + step*rho1_r(1)%array(:, :, :)
2322!$OMP END WORKSHARE NOWAIT
2323!$OMP WORKSHARE
2324 rho_r(2)%array(:, :, :) = rhob(:, :, :) + step*rho1_r(2)%array(:, :, :)
2325!$OMP END WORKSHARE NOWAIT
2326 IF (ASSOCIATED(tau1_r) .AND. ASSOCIATED(tau_r) .AND. ASSOCIATED(tau_a) .AND. ASSOCIATED(tau_b)) THEN
2327!$OMP WORKSHARE
2328 tau_r(1)%array(:, :, :) = tau_a(:, :, :) + step*tau1_r(1)%array(:, :, :)
2329!$OMP END WORKSHARE NOWAIT
2330!$OMP WORKSHARE
2331 tau_r(2)%array(:, :, :) = tau_b(:, :, :) + step*tau1_r(2)%array(:, :, :)
2332!$OMP END WORKSHARE NOWAIT
2333 END IF
2334!$OMP END PARALLEL
2335 CALL xc_vxc_pw_create(vxc_rho, vxc_tau, exc, rho_r, rho_g, tau_r, xc_section, &
2336 pw_pool, .false., virial_dummy)
2337
2338 CALL timestop(handle)
2339
2340 END SUBROUTINE calc_resp_potential_numer_ab
2341
2342! **************************************************************************************************
2343!> \brief calculates stress tensor and potential contributions from the first derivative
2344!> \param deriv_set ...
2345!> \param description ...
2346!> \param virial_pw ...
2347!> \param drho ...
2348!> \param drho1 ...
2349!> \param virial_xc ...
2350!> \param norm_drho ...
2351!> \param gradient_cut ...
2352!> \param dr1dr ...
2353!> \param v_drho ...
2354! **************************************************************************************************
2355 SUBROUTINE apply_drho(deriv_set, description, virial_pw, drho, drho1, virial_xc, norm_drho, gradient_cut, dr1dr, v_drho)
2356
2357 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set
2358 INTEGER, DIMENSION(:), INTENT(in) :: description
2359 TYPE(pw_r3d_rs_type), INTENT(IN) :: virial_pw
2360 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drho, drho1
2361 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT) :: virial_xc
2362 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: norm_drho
2363 REAL(kind=dp), INTENT(IN) :: gradient_cut
2364 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: dr1dr
2365 REAL(kind=dp), DIMENSION(:, :, :), INTENT(INOUT) :: v_drho
2366
2367 CHARACTER(len=*), PARAMETER :: routinen = 'apply_drho'
2368
2369 INTEGER :: handle
2370 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data
2371 TYPE(xc_derivative_type), POINTER :: deriv_att
2372
2373 CALL timeset(routinen, handle)
2374
2375 deriv_att => xc_dset_get_derivative(deriv_set, description)
2376 IF (ASSOCIATED(deriv_att)) THEN
2377 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2378 CALL virial_drho_drho1(virial_pw, drho, drho1, deriv_data, virial_xc)
2379
2380!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,gradient_cut,norm_drho,v_drho,deriv_data)
2381 v_drho(:, :, :) = v_drho(:, :, :) + &
2382 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
2383!$OMP END PARALLEL WORKSHARE
2384 END IF
2385
2386 CALL timestop(handle)
2387
2388 END SUBROUTINE apply_drho
2389
2390! **************************************************************************************************
2391!> \brief adds potential contributions from derivatives of rho or diagonal terms of norm_drho
2392!> \param deriv_set1 ...
2393!> \param description ...
2394!> \param bo ...
2395!> \param norm_drho norm_drho of which derivative is calculated
2396!> \param gradient_cut ...
2397!> \param h ...
2398!> \param rho1 function to contract the derivative with (rho1 for rho, dr1dr for norm_drho)
2399!> \param v_drho ...
2400! **************************************************************************************************
2401 SUBROUTINE update_deriv_rho(deriv_set1, description, bo, norm_drho, gradient_cut, weight, rho1, v_drho)
2402
2403 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set1
2404 INTEGER, DIMENSION(:), INTENT(in) :: description
2405 INTEGER, DIMENSION(2, 3), INTENT(IN) :: bo
2406 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
2407 REAL(kind=dp), INTENT(IN) :: gradient_cut, weight
2408 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
2409 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
2410
2411 CHARACTER(len=*), PARAMETER :: routinen = 'update_deriv_rho'
2412
2413 INTEGER :: handle, i, j, k
2414 REAL(kind=dp) :: de
2415 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data1
2416 TYPE(xc_derivative_type), POINTER :: deriv_att1
2417
2418 CALL timeset(routinen, handle)
2419
2420 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2421 deriv_att1 => xc_dset_get_derivative(deriv_set1, description)
2422 IF (ASSOCIATED(deriv_att1)) THEN
2423 CALL xc_derivative_get(deriv_att1, deriv_data=deriv_data1)
2424!$OMP PARALLEL DO DEFAULT(NONE) &
2425!$OMP SHARED(bo,deriv_data1,weight,norm_drho,v_drho,rho1,gradient_cut) &
2426!$OMP PRIVATE(i,j,k,de) &
2427!$OMP COLLAPSE(3)
2428 DO k = bo(1, 3), bo(2, 3)
2429 DO j = bo(1, 2), bo(2, 2)
2430 DO i = bo(1, 1), bo(2, 1)
2431 de = weight*deriv_data1(i, j, k)/max(gradient_cut, norm_drho(i, j, k))**2
2432 v_drho(i, j, k) = v_drho(i, j, k) - de*rho1(i, j, k)
2433 END DO
2434 END DO
2435 END DO
2436!$OMP END PARALLEL DO
2437 END IF
2438
2439 CALL timestop(handle)
2440
2441 END SUBROUTINE update_deriv_rho
2442
2443! **************************************************************************************************
2444!> \brief adds potential contributions from derivatives of a component with positive and negative values
2445!> \param deriv_set1 ...
2446!> \param description ...
2447!> \param bo ...
2448!> \param h ...
2449!> \param rho1 function to contract the derivative with (rho1 for rho, dr1dr for norm_drho)
2450!> \param v ...
2451! **************************************************************************************************
2452 SUBROUTINE update_deriv(deriv_set1, rho, rho_cutoff, description, bo, weight, rho1, v)
2453
2454 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set1
2455 INTEGER, DIMENSION(:), INTENT(in) :: description
2456 INTEGER, DIMENSION(2, 3), INTENT(IN) :: bo
2457 REAL(kind=dp), INTENT(IN) :: weight, rho_cutoff
2458 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
2459 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
2460
2461 CHARACTER(len=*), PARAMETER :: routinen = 'update_deriv'
2462
2463 INTEGER :: handle, i, j, k
2464 REAL(kind=dp) :: de
2465 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data1
2466 TYPE(xc_derivative_type), POINTER :: deriv_att1
2467
2468 CALL timeset(routinen, handle)
2469
2470 ! Obtain the numerical 2nd derivatives w.r.t. to drho and collect the potential
2471 deriv_att1 => xc_dset_get_derivative(deriv_set1, description)
2472 IF (ASSOCIATED(deriv_att1)) THEN
2473 CALL xc_derivative_get(deriv_att1, deriv_data=deriv_data1)
2474!$OMP PARALLEL DO DEFAULT(NONE) &
2475!$OMP SHARED(bo,deriv_data1,weight,v,rho1,rho, rho_cutoff) &
2476!$OMP PRIVATE(i,j,k,de) &
2477!$OMP COLLAPSE(3)
2478 DO k = bo(1, 3), bo(2, 3)
2479 DO j = bo(1, 2), bo(2, 2)
2480 DO i = bo(1, 1), bo(2, 1)
2481 ! We have to consider that the given density (mostly the Laplacian) may have positive and negative values
2482 de = weight*deriv_data1(i, j, k)/sign(max(abs(rho(i, j, k)), rho_cutoff), rho(i, j, k))
2483 v(i, j, k) = v(i, j, k) + de*rho1(i, j, k)
2484 END DO
2485 END DO
2486 END DO
2487!$OMP END PARALLEL DO
2488 END IF
2489
2490 CALL timestop(handle)
2491
2492 END SUBROUTINE update_deriv
2493
2494! **************************************************************************************************
2495!> \brief adds mixed derivatives of norm_drho
2496!> \param deriv_set1 ...
2497!> \param description ...
2498!> \param bo ...
2499!> \param norm_drhoa norm_drho of which derivatives is calculated
2500!> \param gradient_cut ...
2501!> \param h ...
2502!> \param dra1dra dr1dr corresponding to norm_drho
2503!> \param drb1drb ...
2504!> \param v_drhoa potential corresponding to norm_drho
2505!> \param v_drhob ...
2506! **************************************************************************************************
2507 SUBROUTINE update_deriv_drho_ab(deriv_set1, description, bo, &
2508 norm_drhoa, gradient_cut, weight, dra1dra, drb1drb, v_drhoa, v_drhob)
2509
2510 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set1
2511 INTEGER, DIMENSION(:), INTENT(in) :: description
2512 INTEGER, DIMENSION(2, 3), INTENT(IN) :: bo
2513 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
2514 REAL(kind=dp), INTENT(IN) :: gradient_cut, weight
2515 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
2516 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
2517
2518 CHARACTER(len=*), PARAMETER :: routinen = 'update_deriv_drho_ab'
2519
2520 INTEGER :: handle, i, j, k
2521 REAL(kind=dp) :: de
2522 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data1
2523 TYPE(xc_derivative_type), POINTER :: deriv_att1
2524
2525 CALL timeset(routinen, handle)
2526
2527 deriv_att1 => xc_dset_get_derivative(deriv_set1, description)
2528 IF (ASSOCIATED(deriv_att1)) THEN
2529 CALL xc_derivative_get(deriv_att1, deriv_data=deriv_data1)
2530!$OMP PARALLEL DO DEFAULT(NONE) &
2531!$OMP PRIVATE(k,j,i,de) &
2532!$OMP SHARED(bo,drb1drb,dra1dra,deriv_data1,weight,gradient_cut,norm_drhoa,v_drhoa,v_drhob) &
2533!$OMP COLLAPSE(3)
2534 DO k = bo(1, 3), bo(2, 3)
2535 DO j = bo(1, 2), bo(2, 2)
2536 DO i = bo(1, 1), bo(2, 1)
2537 ! We introduce a factor of two because we will average between both numerical derivatives
2538 de = 0.5_dp*weight*deriv_data1(i, j, k)/max(gradient_cut, norm_drhoa(i, j, k))**2
2539 v_drhoa(i, j, k) = v_drhoa(i, j, k) - de*drb1drb(i, j, k)
2540 v_drhob(i, j, k) = v_drhob(i, j, k) - de*dra1dra(i, j, k)
2541 END DO
2542 END DO
2543 END DO
2544!$OMP END PARALLEL DO
2545 END IF
2546
2547 CALL timestop(handle)
2548
2549 END SUBROUTINE update_deriv_drho_ab
2550
2551! **************************************************************************************************
2552!> \brief calculate derivative sets for helper points
2553!> \param norm_drho2 norm_drho of new points
2554!> \param norm_drho norm_drho of KS density
2555!> \param h ...
2556!> \param xc_fun_section ...
2557!> \param lsd ...
2558!> \param rho2_set rho_set for new points
2559!> \param deriv_set1 will contain derivatives of the perturbed density
2560! **************************************************************************************************
2561 SUBROUTINE get_derivs_rho(norm_drho2, norm_drho, step, xc_fun_section, lsd, rho2_set, deriv_set1)
2562 REAL(kind=dp), DIMENSION(:, :, :), INTENT(OUT) :: norm_drho2
2563 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: norm_drho
2564 REAL(kind=dp), INTENT(IN) :: step
2565 TYPE(section_vals_type), INTENT(IN), POINTER :: xc_fun_section
2566 LOGICAL, INTENT(IN) :: lsd
2567 TYPE(xc_rho_set_type), INTENT(INOUT) :: rho2_set
2568 TYPE(xc_derivative_set_type) :: deriv_set1
2569
2570 CHARACTER(len=*), PARAMETER :: routinen = 'get_derivs_rho'
2571
2572 INTEGER :: handle
2573
2574 CALL timeset(routinen, handle)
2575
2576 ! Copy the densities, do one step into the direction of drho
2577!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(norm_drho,norm_drho2,step)
2578 norm_drho2 = norm_drho*(1.0_dp + step)
2579!$OMP END PARALLEL WORKSHARE
2580
2581 CALL xc_dset_zero_all(deriv_set1)
2582
2583 ! Calculate the derivatives of the functional
2584 CALL xc_functionals_eval(xc_fun_section, &
2585 lsd=lsd, &
2586 rho_set=rho2_set, &
2587 deriv_set=deriv_set1, &
2588 deriv_order=1)
2589
2590 ! Return to the original values
2591!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(norm_drho,norm_drho2)
2592 norm_drho2 = norm_drho
2593!$OMP END PARALLEL WORKSHARE
2594
2595 CALL divide_by_norm_drho(deriv_set1, rho2_set, lsd)
2596
2597 CALL timestop(handle)
2598
2599 END SUBROUTINE get_derivs_rho
2600
2601! **************************************************************************************************
2602!> \brief Calculates the second derivative of E_xc at rho in the direction
2603!> rho1 (if you see the second derivative as bilinear form)
2604!> partial_rho|_(rho=rho) partial_rho|_(rho=rho) E_xc drho(rho1)drho
2605!> The other direction is still undetermined, thus it returns
2606!> a potential (partial integration is performed to reduce it to
2607!> function of rho, removing the dependence from its partial derivs)
2608!> Has to be called after the setup by xc_prep_2nd_deriv.
2609!> \param v_xc exchange-correlation potential
2610!> \param v_xc_tau ...
2611!> \param deriv_set derivatives of the exchange-correlation potential
2612!> \param rho_set object containing the density at which the derivatives were calculated
2613!> \param rho1_set object containing the density with which to fold
2614!> \param pw_pool the pool for the grids
2615!> \param xc_section XC parameters
2616!> \param gapw Gaussian and augmented plane waves calculation
2617!> \param vxg ...
2618!> \param tddfpt_fac factor that multiplies the crossterms (tddfpt triplets
2619!> on a closed shell system it should be -1, defaults to 1)
2620!> \param compute_virial ...
2621!> \param virial_xc ...
2622!> \note
2623!> The old version of this routine was smarter: it handled split_desc(1)
2624!> and split_desc(2) separately, thus the code automatically handled all
2625!> possible cross terms (you only had to check if it was diagonal to avoid
2626!> double counting). I think that is the way to go if you want to add more
2627!> terms (tau,rho in LSD,...). The problem with the old code was that it
2628!> because of the old functional structure it sometime guessed wrongly
2629!> which derivative was where. There were probably still bugs with gradient
2630!> corrected functionals (never tested), and it didn't contain first
2631!> derivatives with respect to drho (that contribute also to the second
2632!> derivative wrt. rho).
2633!> The code was a little complex because it really tried to handle any
2634!> functional derivative in the most efficient way with the given contents of
2635!> rho_set.
2636!> Anyway I strongly encourage whoever wants to modify this code to give a
2637!> look to the old version. [fawzi]
2638! **************************************************************************************************
2639 SUBROUTINE xc_calc_2nd_deriv_analytical(v_xc, v_xc_tau, deriv_set, rho_set, rho1_set, &
2640 pw_pool, xc_section, gapw, vxg, tddfpt_fac, &
2641 compute_virial, virial_xc, spinflip)
2642
2643 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: v_xc, v_xc_tau
2644 TYPE(xc_derivative_set_type) :: deriv_set
2645 TYPE(xc_rho_set_type), INTENT(IN) :: rho_set, rho1_set
2646 TYPE(pw_pool_type), POINTER :: pw_pool
2647 TYPE(section_vals_type), POINTER :: xc_section
2648 LOGICAL, INTENT(IN), OPTIONAL :: gapw
2649 REAL(kind=dp), DIMENSION(:, :, :, :), OPTIONAL, &
2650 POINTER :: vxg
2651 REAL(kind=dp), INTENT(in), OPTIONAL :: tddfpt_fac
2652 LOGICAL, INTENT(IN), OPTIONAL :: compute_virial
2653 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT), &
2654 OPTIONAL :: virial_xc
2655 LOGICAL, INTENT(in), OPTIONAL :: spinflip
2656
2657 CHARACTER(len=*), PARAMETER :: routinen = 'xc_calc_2nd_deriv_analytical'
2658
2659 INTEGER :: handle, i, ia, idir, ir, ispin, j, jdir, &
2660 k, nspins, xc_deriv_method_id
2661 INTEGER, DIMENSION(2, 3) :: bo
2662 LOGICAL :: gradient_f, lsd, my_compute_virial, alda0, &
2663 my_gapw, tau_f, laplace_f, rho_f, do_spinflip
2664 REAL(kind=dp) :: fac, gradient_cut, tmp, factor2, s, s_thresh
2665 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :) :: dr1dr, dra1dra, drb1drb
2666 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data, deriv_data2, &
2667 e_drhoa, e_drhob, e_drho, norm_drho, norm_drhoa, &
2668 norm_drhob, rho1, rho1a, rho1b, &
2669 tau1, tau1a, tau1b, laplace1, laplace1a, laplace1b, &
2670 rho, rhoa, rhob
2671 TYPE(cp_3d_r_cp_type), DIMENSION(3) :: drho, drho1, drho1a, drho1b, drhoa, drhob
2672 TYPE(pw_r3d_rs_type), DIMENSION(:), ALLOCATABLE :: v_drhoa, v_drhob, v_drho, v_laplace
2673 TYPE(pw_r3d_rs_type), DIMENSION(:, :), ALLOCATABLE :: v_drho_r
2674 TYPE(pw_r3d_rs_type) :: virial_pw
2675 TYPE(pw_c1d_gs_type) :: tmp_g, vxc_g
2676 TYPE(xc_derivative_type), POINTER :: deriv_att
2677
2678 CALL timeset(routinen, handle)
2679
2680 NULLIFY (e_drhoa, e_drhob, e_drho)
2681
2682 my_gapw = .false.
2683 IF (PRESENT(gapw)) my_gapw = gapw
2684
2685 my_compute_virial = .false.
2686 IF (PRESENT(compute_virial)) my_compute_virial = compute_virial
2687
2688 cpassert(ASSOCIATED(v_xc))
2689 cpassert(ASSOCIATED(xc_section))
2690 IF (my_gapw) THEN
2691 cpassert(PRESENT(vxg))
2692 END IF
2693 IF (my_compute_virial) THEN
2694 cpassert(PRESENT(virial_xc))
2695 END IF
2696
2697 CALL section_vals_val_get(xc_section, "XC_GRID%XC_DERIV", &
2698 i_val=xc_deriv_method_id)
2699 CALL xc_rho_set_get(rho_set, drho_cutoff=gradient_cut)
2700 nspins = SIZE(v_xc)
2701 lsd = ASSOCIATED(rho_set%rhoa)
2702 fac = 0.0_dp
2703 factor2 = 1.0_dp
2704 IF (PRESENT(tddfpt_fac)) fac = tddfpt_fac
2705 IF (PRESENT(tddfpt_fac)) factor2 = tddfpt_fac
2706 do_spinflip = .false.
2707 IF (PRESENT(spinflip)) do_spinflip = spinflip
2708
2709 bo = rho_set%local_bounds
2710
2711 CALL check_for_derivatives(deriv_set, lsd, rho_f, gradient_f, tau_f, laplace_f)
2712
2713 alda0 = .false.
2714 IF (gradient_f) THEN
2715 s_thresh = 1.0e-04
2716 ELSE
2717 s_thresh = 1.0e-10
2718 END IF
2719
2720 IF (tau_f) THEN
2721 cpassert(ASSOCIATED(v_xc_tau))
2722 END IF
2723
2724 IF (gradient_f) THEN
2725 ALLOCATE (v_drho_r(3, nspins), v_drho(nspins))
2726 DO ispin = 1, nspins
2727 DO idir = 1, 3
2728 CALL allocate_pw(v_drho_r(idir, ispin), pw_pool, bo)
2729 END DO
2730 CALL allocate_pw(v_drho(ispin), pw_pool, bo)
2731 END DO
2732
2733 IF (xc_requires_tmp_g(xc_deriv_method_id) .AND. .NOT. my_gapw) THEN
2734 IF (ASSOCIATED(pw_pool)) THEN
2735 CALL pw_pool%create_pw(tmp_g)
2736 CALL pw_pool%create_pw(vxc_g)
2737 ELSE
2738 ! remember to refix for gapw
2739 cpabort("XC_DERIV method is not implemented in GAPW")
2740 END IF
2741 END IF
2742 END IF
2743
2744 DO ispin = 1, nspins
2745 v_xc(ispin)%array = 0.0_dp
2746 END DO
2747
2748 IF (tau_f) THEN
2749 DO ispin = 1, nspins
2750 v_xc_tau(ispin)%array = 0.0_dp
2751 END DO
2752 END IF
2753
2754 IF (laplace_f .AND. my_gapw) &
2755 cpabort("Laplace-dependent functional not implemented with GAPW!")
2756
2757 IF (my_compute_virial .AND. (gradient_f .OR. laplace_f)) CALL allocate_pw(virial_pw, pw_pool, bo)
2758
2759 IF (lsd) THEN
2760
2761 !-------------------!
2762 ! UNrestricted case !
2763 !-------------------!
2764
2765 IF (do_spinflip) THEN
2766 CALL xc_rho_set_get(rho1_set, rhoa=rho1a)
2767 CALL xc_rho_set_get(rho_set, rhoa=rhoa, rhob=rhob)
2768 ELSE
2769 CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b)
2770 END IF
2771
2772 IF (gradient_f) THEN
2773 CALL xc_rho_set_get(rho_set, drhoa=drhoa, drhob=drhob, &
2774 norm_drho=norm_drho, norm_drhoa=norm_drhoa, norm_drhob=norm_drhob)
2775 IF (do_spinflip) THEN
2776 CALL xc_rho_set_get(rho1_set, drhoa=drho1a)
2777 CALL calc_drho_from_a(drho1, drho1a)
2778 ELSE
2779 CALL xc_rho_set_get(rho1_set, drhoa=drho1a, drhob=drho1b)
2780 CALL calc_drho_from_ab(drho1, drho1a, drho1b)
2781 END IF
2782
2783 CALL calc_drho_from_ab(drho, drhoa, drhob)
2784
2785 CALL prepare_dr1dr(dra1dra, drhoa, drho1a)
2786 IF (do_spinflip) THEN
2787 CALL prepare_dr1dr(drb1drb, drhob, drho1a)
2788 CALL prepare_dr1dr(dr1dr, drho, drho1a)
2789 ELSE IF (nspins /= 1) THEN
2790 CALL prepare_dr1dr(drb1drb, drhob, drho1b)
2791 CALL prepare_dr1dr(dr1dr, drho, drho1)
2792 ELSE
2793 CALL prepare_dr1dr(drb1drb, drhob, drho1b)
2794 CALL prepare_dr1dr_ab(dr1dr, drhoa, drhob, drho1a, drho1b, fac)
2795 END IF
2796
2797 ALLOCATE (v_drhoa(nspins), v_drhob(nspins))
2798 DO ispin = 1, nspins
2799 CALL allocate_pw(v_drhoa(ispin), pw_pool, bo)
2800 CALL allocate_pw(v_drhob(ispin), pw_pool, bo)
2801 END DO
2802
2803 END IF
2804
2805 IF (laplace_f) THEN
2806 CALL xc_rho_set_get(rho1_set, laplace_rhoa=laplace1a, laplace_rhob=laplace1b)
2807
2808 ALLOCATE (v_laplace(nspins))
2809 DO ispin = 1, nspins
2810 CALL allocate_pw(v_laplace(ispin), pw_pool, bo)
2811 END DO
2812
2813 IF (my_compute_virial) CALL xc_rho_set_get(rho_set, rhoa=rhoa, rhob=rhob)
2814 END IF
2815
2816 IF (tau_f) THEN
2817 CALL xc_rho_set_get(rho1_set, tau_a=tau1a, tau_b=tau1b)
2818 END IF
2819
2820 IF (do_spinflip) THEN
2821
2822 ! vxc contributions
2823 ! vxc = (vxc^{\alpha}-vxc^{\beta})*rho1/(rhoa-rhob)
2824 ! Alpha LDA contribution
2825 ! | d e_xc d e_xc | rho1a
2826 ! vxca = |-------- - --------|*-------------
2827 ! | drhoa drhob | |rhoa - rhob|
2828 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa])
2829 IF (ASSOCIATED(deriv_att)) THEN
2830 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2831 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob])
2832 IF (ASSOCIATED(deriv_att)) THEN
2833 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
2834!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
2835!$OMP SHARED(bo,v_xc,deriv_data,deriv_data2,rho1a,rhoa,rhob,S_THRESH) COLLAPSE(3)
2836 DO k = bo(1, 3), bo(2, 3)
2837 DO j = bo(1, 2), bo(2, 2)
2838 DO i = bo(1, 1), bo(2, 1)
2839 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
2840 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2841 (deriv_data(i, j, k) - deriv_data2(i, j, k))*rho1a(i, j, k)/s
2842 END DO
2843 END DO
2844 END DO
2845!$OMP END PARALLEL DO
2846 END IF
2847 END IF
2848 ! GGA contributions to the spin-flip xcKernel
2849 ! GGA contribution
2850 ! | d e_xc d e_xc | 1
2851 ! vxca += |----------* dra1dra - ----------*drb1drb|*-------------
2852 ! | d|drhoa| d|drhob| | |rhoa - rhob|
2853 IF (.NOT. alda0) THEN
2854 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa])
2855 IF (ASSOCIATED(deriv_att)) THEN
2856 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2857 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob])
2858 IF (ASSOCIATED(deriv_att)) THEN
2859 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
2860!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
2861!$OMP SHARED(bo,deriv_data,deriv_data2,dra1dra,drb1drb,v_xc,rhoa,rhob,S_THRESH) COLLAPSE(3)
2862 DO k = bo(1, 3), bo(2, 3)
2863 DO j = bo(1, 2), bo(2, 2)
2864 DO i = bo(1, 1), bo(2, 1)
2865 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
2866 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2867 (deriv_data(i, j, k)*dra1dra(i, j, k) - &
2868 deriv_data2(i, j, k)*drb1drb(i, j, k))/s
2869 END DO
2870 END DO
2871 END DO
2872!$OMP END PARALLEL DO
2873 END IF
2874 END IF
2875 END IF
2876
2877 ELSE IF (nspins /= 1) THEN
2878
2879 ! Compute \sum_{\tau}fxc^{\sigma\tau}*\rho^{\tau}(1) over the grid points
2880 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhoa])
2881 IF (ASSOCIATED(deriv_att)) THEN
2882 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2883!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2884!$OMP SHARED(bo,v_xc,deriv_data,rho1a,fac) COLLAPSE(3)
2885 DO k = bo(1, 3), bo(2, 3)
2886 DO j = bo(1, 2), bo(2, 2)
2887 DO i = bo(1, 1), bo(2, 1)
2888 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2889 deriv_data(i, j, k)*rho1a(i, j, k)
2890 END DO
2891 END DO
2892 END DO
2893 END IF
2894 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhob])
2895 IF (ASSOCIATED(deriv_att)) THEN
2896 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2897!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2898!$OMP SHARED(bo,v_xc,deriv_data,rho1b,fac) COLLAPSE(3)
2899 DO k = bo(1, 3), bo(2, 3)
2900 DO j = bo(1, 2), bo(2, 2)
2901 DO i = bo(1, 1), bo(2, 1)
2902 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2903 deriv_data(i, j, k)*rho1b(i, j, k)
2904 END DO
2905 END DO
2906 END DO
2907 END IF
2908 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drho])
2909 IF (ASSOCIATED(deriv_att)) THEN
2910 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2911!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2912!$OMP SHARED(bo,v_xc,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
2913 DO k = bo(1, 3), bo(2, 3)
2914 DO j = bo(1, 2), bo(2, 2)
2915 DO i = bo(1, 1), bo(2, 1)
2916 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2917 deriv_data(i, j, k)*dr1dr(i, j, k)
2918 END DO
2919 END DO
2920 END DO
2921 END IF
2922 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhoa])
2923 IF (ASSOCIATED(deriv_att)) THEN
2924 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2925!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2926!$OMP SHARED(bo,v_xc,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
2927 DO k = bo(1, 3), bo(2, 3)
2928 DO j = bo(1, 2), bo(2, 2)
2929 DO i = bo(1, 1), bo(2, 1)
2930 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2931 deriv_data(i, j, k)*dra1dra(i, j, k)
2932 END DO
2933 END DO
2934 END DO
2935 END IF
2936 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhob])
2937 IF (ASSOCIATED(deriv_att)) THEN
2938 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2939!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2940!$OMP SHARED(bo,v_xc,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
2941 DO k = bo(1, 3), bo(2, 3)
2942 DO j = bo(1, 2), bo(2, 2)
2943 DO i = bo(1, 1), bo(2, 1)
2944 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2945 deriv_data(i, j, k)*drb1drb(i, j, k)
2946 END DO
2947 END DO
2948 END DO
2949 END IF
2950 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_tau_a])
2951 IF (ASSOCIATED(deriv_att)) THEN
2952 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2953!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2954!$OMP SHARED(bo,v_xc,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
2955 DO k = bo(1, 3), bo(2, 3)
2956 DO j = bo(1, 2), bo(2, 2)
2957 DO i = bo(1, 1), bo(2, 1)
2958 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2959 deriv_data(i, j, k)*tau1a(i, j, k)
2960 END DO
2961 END DO
2962 END DO
2963 END IF
2964 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_tau_b])
2965 IF (ASSOCIATED(deriv_att)) THEN
2966 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2967!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2968!$OMP SHARED(bo,v_xc,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
2969 DO k = bo(1, 3), bo(2, 3)
2970 DO j = bo(1, 2), bo(2, 2)
2971 DO i = bo(1, 1), bo(2, 1)
2972 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2973 deriv_data(i, j, k)*tau1b(i, j, k)
2974 END DO
2975 END DO
2976 END DO
2977 END IF
2978 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_laplace_rhoa])
2979 IF (ASSOCIATED(deriv_att)) THEN
2980 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2981!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2982!$OMP SHARED(bo,v_xc,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
2983 DO k = bo(1, 3), bo(2, 3)
2984 DO j = bo(1, 2), bo(2, 2)
2985 DO i = bo(1, 1), bo(2, 1)
2986 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
2987 deriv_data(i, j, k)*laplace1a(i, j, k)
2988 END DO
2989 END DO
2990 END DO
2991 END IF
2992 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_laplace_rhob])
2993 IF (ASSOCIATED(deriv_att)) THEN
2994 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
2995!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
2996!$OMP SHARED(bo,v_xc,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
2997 DO k = bo(1, 3), bo(2, 3)
2998 DO j = bo(1, 2), bo(2, 2)
2999 DO i = bo(1, 1), bo(2, 1)
3000 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
3001 deriv_data(i, j, k)*laplace1b(i, j, k)
3002 END DO
3003 END DO
3004 END DO
3005 END IF
3006
3007
3008 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_rhoa])
3009 IF (ASSOCIATED(deriv_att)) THEN
3010 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3011!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3012!$OMP SHARED(bo,v_xc,deriv_data,rho1a,fac) COLLAPSE(3)
3013 DO k = bo(1, 3), bo(2, 3)
3014 DO j = bo(1, 2), bo(2, 2)
3015 DO i = bo(1, 1), bo(2, 1)
3016 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3017 deriv_data(i, j, k)*rho1a(i, j, k)
3018 END DO
3019 END DO
3020 END DO
3021 END IF
3022 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_rhob])
3023 IF (ASSOCIATED(deriv_att)) THEN
3024 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3025!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3026!$OMP SHARED(bo,v_xc,deriv_data,rho1b,fac) COLLAPSE(3)
3027 DO k = bo(1, 3), bo(2, 3)
3028 DO j = bo(1, 2), bo(2, 2)
3029 DO i = bo(1, 1), bo(2, 1)
3030 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3031 deriv_data(i, j, k)*rho1b(i, j, k)
3032 END DO
3033 END DO
3034 END DO
3035 END IF
3036 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_norm_drho])
3037 IF (ASSOCIATED(deriv_att)) THEN
3038 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3039!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3040!$OMP SHARED(bo,v_xc,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3041 DO k = bo(1, 3), bo(2, 3)
3042 DO j = bo(1, 2), bo(2, 2)
3043 DO i = bo(1, 1), bo(2, 1)
3044 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3045 deriv_data(i, j, k)*dr1dr(i, j, k)
3046 END DO
3047 END DO
3048 END DO
3049 END IF
3050 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_norm_drhoa])
3051 IF (ASSOCIATED(deriv_att)) THEN
3052 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3053!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3054!$OMP SHARED(bo,v_xc,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3055 DO k = bo(1, 3), bo(2, 3)
3056 DO j = bo(1, 2), bo(2, 2)
3057 DO i = bo(1, 1), bo(2, 1)
3058 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3059 deriv_data(i, j, k)*dra1dra(i, j, k)
3060 END DO
3061 END DO
3062 END DO
3063 END IF
3064 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_norm_drhob])
3065 IF (ASSOCIATED(deriv_att)) THEN
3066 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3067!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3068!$OMP SHARED(bo,v_xc,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3069 DO k = bo(1, 3), bo(2, 3)
3070 DO j = bo(1, 2), bo(2, 2)
3071 DO i = bo(1, 1), bo(2, 1)
3072 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3073 deriv_data(i, j, k)*drb1drb(i, j, k)
3074 END DO
3075 END DO
3076 END DO
3077 END IF
3078 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_tau_a])
3079 IF (ASSOCIATED(deriv_att)) THEN
3080 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3081!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3082!$OMP SHARED(bo,v_xc,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3083 DO k = bo(1, 3), bo(2, 3)
3084 DO j = bo(1, 2), bo(2, 2)
3085 DO i = bo(1, 1), bo(2, 1)
3086 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3087 deriv_data(i, j, k)*tau1a(i, j, k)
3088 END DO
3089 END DO
3090 END DO
3091 END IF
3092 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_tau_b])
3093 IF (ASSOCIATED(deriv_att)) THEN
3094 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3095!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3096!$OMP SHARED(bo,v_xc,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3097 DO k = bo(1, 3), bo(2, 3)
3098 DO j = bo(1, 2), bo(2, 2)
3099 DO i = bo(1, 1), bo(2, 1)
3100 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3101 deriv_data(i, j, k)*tau1b(i, j, k)
3102 END DO
3103 END DO
3104 END DO
3105 END IF
3106 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_laplace_rhoa])
3107 IF (ASSOCIATED(deriv_att)) THEN
3108 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3109!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3110!$OMP SHARED(bo,v_xc,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3111 DO k = bo(1, 3), bo(2, 3)
3112 DO j = bo(1, 2), bo(2, 2)
3113 DO i = bo(1, 1), bo(2, 1)
3114 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3115 deriv_data(i, j, k)*laplace1a(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_rhob, deriv_laplace_rhob])
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_xc,deriv_data,laplace1b,v_laplace,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_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
3129 deriv_data(i, j, k)*laplace1b(i, j, k)
3130 END DO
3131 END DO
3132 END DO
3133 END IF
3134
3135
3136 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rhoa])
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,rho1a,v_xc,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)*rho1a(i, j, k)
3146 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3147 deriv_data(i, j, k)*rho1a(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_rhob])
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,rho1b,v_xc,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)*rho1b(i, j, k)
3162 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3163 deriv_data(i, j, k)*rho1b(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_norm_drho])
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,dr1dr,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)*dr1dr(i, j, k)
3178 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3179 deriv_data(i, j, k)*dr1dr(i, j, k)
3180 END DO
3181 END DO
3182 END DO
3183 END IF
3184 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhoa])
3185 IF (ASSOCIATED(deriv_att)) THEN
3186 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3187!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3188!$OMP SHARED(bo,v_drho,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3189 DO k = bo(1, 3), bo(2, 3)
3190 DO j = bo(1, 2), bo(2, 2)
3191 DO i = bo(1, 1), bo(2, 1)
3192 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3193 deriv_data(i, j, k)*dra1dra(i, j, k)
3194 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3195 deriv_data(i, j, k)*dra1dra(i, j, k)
3196 END DO
3197 END DO
3198 END DO
3199 END IF
3200 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhob])
3201 IF (ASSOCIATED(deriv_att)) THEN
3202 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3203!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3204!$OMP SHARED(bo,v_drho,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3205 DO k = bo(1, 3), bo(2, 3)
3206 DO j = bo(1, 2), bo(2, 2)
3207 DO i = bo(1, 1), bo(2, 1)
3208 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3209 deriv_data(i, j, k)*drb1drb(i, j, k)
3210 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3211 deriv_data(i, j, k)*drb1drb(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_drho, deriv_tau_a])
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_drho,deriv_data,tau1a,v_xc_tau,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_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3225 deriv_data(i, j, k)*tau1a(i, j, k)
3226 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3227 deriv_data(i, j, k)*tau1a(i, j, k)
3228 END DO
3229 END DO
3230 END DO
3231 END IF
3232 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_tau_b])
3233 IF (ASSOCIATED(deriv_att)) THEN
3234 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3235!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3236!$OMP SHARED(bo,v_drho,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3237 DO k = bo(1, 3), bo(2, 3)
3238 DO j = bo(1, 2), bo(2, 2)
3239 DO i = bo(1, 1), bo(2, 1)
3240 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3241 deriv_data(i, j, k)*tau1b(i, j, k)
3242 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3243 deriv_data(i, j, k)*tau1b(i, j, k)
3244 END DO
3245 END DO
3246 END DO
3247 END IF
3249 IF (ASSOCIATED(deriv_att)) THEN
3250 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3251!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3252!$OMP SHARED(bo,v_drho,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3253 DO k = bo(1, 3), bo(2, 3)
3254 DO j = bo(1, 2), bo(2, 2)
3255 DO i = bo(1, 1), bo(2, 1)
3256 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3257 deriv_data(i, j, k)*laplace1a(i, j, k)
3258 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3259 deriv_data(i, j, k)*laplace1a(i, j, k)
3260 END DO
3261 END DO
3262 END DO
3263 END IF
3265 IF (ASSOCIATED(deriv_att)) THEN
3266 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3267!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3268!$OMP SHARED(bo,v_drho,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3269 DO k = bo(1, 3), bo(2, 3)
3270 DO j = bo(1, 2), bo(2, 2)
3271 DO i = bo(1, 1), bo(2, 1)
3272 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
3273 deriv_data(i, j, k)*laplace1b(i, j, k)
3274 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
3275 deriv_data(i, j, k)*laplace1b(i, j, k)
3276 END DO
3277 END DO
3278 END DO
3279 END IF
3280
3281 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho])
3282 IF (ASSOCIATED(deriv_att)) THEN
3283 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3284 CALL xc_derivative_get(deriv_att, deriv_data=e_drho)
3285
3286 IF (my_compute_virial) THEN
3287 CALL virial_drho_drho1(virial_pw, drho, drho1, deriv_data, virial_xc)
3288 END IF ! my_compute_virial
3289
3290!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,gradient_cut,norm_drho,v_drho,deriv_data)
3291 v_drho(1)%array(:, :, :) = v_drho(1)%array(:, :, :) + &
3292 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
3293 v_drho(2)%array(:, :, :) = v_drho(2)%array(:, :, :) + &
3294 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
3295!$OMP END PARALLEL WORKSHARE
3296 END IF
3297
3298 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhoa])
3299 IF (ASSOCIATED(deriv_att)) THEN
3300 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3301!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3302!$OMP SHARED(bo,v_drhoa,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3303 DO k = bo(1, 3), bo(2, 3)
3304 DO j = bo(1, 2), bo(2, 2)
3305 DO i = bo(1, 1), bo(2, 1)
3306 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3307 deriv_data(i, j, k)*rho1a(i, j, k)
3308 END DO
3309 END DO
3310 END DO
3311 END IF
3312 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhob])
3313 IF (ASSOCIATED(deriv_att)) THEN
3314 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3315!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3316!$OMP SHARED(bo,v_drhoa,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3317 DO k = bo(1, 3), bo(2, 3)
3318 DO j = bo(1, 2), bo(2, 2)
3319 DO i = bo(1, 1), bo(2, 1)
3320 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3321 deriv_data(i, j, k)*rho1b(i, j, k)
3322 END DO
3323 END DO
3324 END DO
3325 END IF
3326 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drho])
3327 IF (ASSOCIATED(deriv_att)) THEN
3328 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3329!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3330!$OMP SHARED(bo,v_drhoa,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3331 DO k = bo(1, 3), bo(2, 3)
3332 DO j = bo(1, 2), bo(2, 2)
3333 DO i = bo(1, 1), bo(2, 1)
3334 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3335 deriv_data(i, j, k)*dr1dr(i, j, k)
3336 END DO
3337 END DO
3338 END DO
3339 END IF
3340 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhoa])
3341 IF (ASSOCIATED(deriv_att)) THEN
3342 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3343!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3344!$OMP SHARED(bo,v_drhoa,deriv_data,dra1dra,fac) COLLAPSE(3)
3345 DO k = bo(1, 3), bo(2, 3)
3346 DO j = bo(1, 2), bo(2, 2)
3347 DO i = bo(1, 1), bo(2, 1)
3348 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3349 deriv_data(i, j, k)*dra1dra(i, j, k)
3350 END DO
3351 END DO
3352 END DO
3353 END IF
3354 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhob])
3355 IF (ASSOCIATED(deriv_att)) THEN
3356 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3357!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3358!$OMP SHARED(bo,v_drhoa,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3359 DO k = bo(1, 3), bo(2, 3)
3360 DO j = bo(1, 2), bo(2, 2)
3361 DO i = bo(1, 1), bo(2, 1)
3362 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3363 deriv_data(i, j, k)*drb1drb(i, j, k)
3364 END DO
3365 END DO
3366 END DO
3367 END IF
3368 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_tau_a])
3369 IF (ASSOCIATED(deriv_att)) THEN
3370 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3371!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3372!$OMP SHARED(bo,v_drhoa,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3373 DO k = bo(1, 3), bo(2, 3)
3374 DO j = bo(1, 2), bo(2, 2)
3375 DO i = bo(1, 1), bo(2, 1)
3376 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3377 deriv_data(i, j, k)*tau1a(i, j, k)
3378 END DO
3379 END DO
3380 END DO
3381 END IF
3382 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_tau_b])
3383 IF (ASSOCIATED(deriv_att)) THEN
3384 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3385!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3386!$OMP SHARED(bo,v_drhoa,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3387 DO k = bo(1, 3), bo(2, 3)
3388 DO j = bo(1, 2), bo(2, 2)
3389 DO i = bo(1, 1), bo(2, 1)
3390 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3391 deriv_data(i, j, k)*tau1b(i, j, k)
3392 END DO
3393 END DO
3394 END DO
3395 END IF
3397 IF (ASSOCIATED(deriv_att)) THEN
3398 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3399!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3400!$OMP SHARED(bo,v_drhoa,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3401 DO k = bo(1, 3), bo(2, 3)
3402 DO j = bo(1, 2), bo(2, 2)
3403 DO i = bo(1, 1), bo(2, 1)
3404 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3405 deriv_data(i, j, k)*laplace1a(i, j, k)
3406 END DO
3407 END DO
3408 END DO
3409 END IF
3411 IF (ASSOCIATED(deriv_att)) THEN
3412 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3413!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3414!$OMP SHARED(bo,v_drhoa,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3415 DO k = bo(1, 3), bo(2, 3)
3416 DO j = bo(1, 2), bo(2, 2)
3417 DO i = bo(1, 1), bo(2, 1)
3418 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
3419 deriv_data(i, j, k)*laplace1b(i, j, k)
3420 END DO
3421 END DO
3422 END DO
3423 END IF
3424
3425 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa])
3426 IF (ASSOCIATED(deriv_att)) THEN
3427 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3428 CALL xc_derivative_get(deriv_att, deriv_data=e_drhoa)
3429
3430 IF (my_compute_virial) THEN
3431 CALL virial_drho_drho1(virial_pw, drhoa, drho1a, deriv_data, virial_xc)
3432 END IF ! my_compute_virial
3433
3434!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dra1dra,gradient_cut,norm_drhoa,v_drhoa,deriv_data)
3435 v_drhoa(1)%array(:, :, :) = v_drhoa(1)%array(:, :, :) + &
3436 deriv_data(:, :, :)*dra1dra(:, :, :)/max(gradient_cut, norm_drhoa(:, :, :))**2
3437!$OMP END PARALLEL WORKSHARE
3438 END IF
3439
3440 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_rhoa])
3441 IF (ASSOCIATED(deriv_att)) THEN
3442 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3443!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3444!$OMP SHARED(bo,v_drhob,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3445 DO k = bo(1, 3), bo(2, 3)
3446 DO j = bo(1, 2), bo(2, 2)
3447 DO i = bo(1, 1), bo(2, 1)
3448 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3449 deriv_data(i, j, k)*rho1a(i, j, k)
3450 END DO
3451 END DO
3452 END DO
3453 END IF
3454 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_rhob])
3455 IF (ASSOCIATED(deriv_att)) THEN
3456 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3457!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3458!$OMP SHARED(bo,v_drhob,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3459 DO k = bo(1, 3), bo(2, 3)
3460 DO j = bo(1, 2), bo(2, 2)
3461 DO i = bo(1, 1), bo(2, 1)
3462 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3463 deriv_data(i, j, k)*rho1b(i, j, k)
3464 END DO
3465 END DO
3466 END DO
3467 END IF
3468 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_norm_drho])
3469 IF (ASSOCIATED(deriv_att)) THEN
3470 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3471!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3472!$OMP SHARED(bo,v_drhob,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3473 DO k = bo(1, 3), bo(2, 3)
3474 DO j = bo(1, 2), bo(2, 2)
3475 DO i = bo(1, 1), bo(2, 1)
3476 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3477 deriv_data(i, j, k)*dr1dr(i, j, k)
3478 END DO
3479 END DO
3480 END DO
3481 END IF
3482 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_norm_drhoa])
3483 IF (ASSOCIATED(deriv_att)) THEN
3484 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3485!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3486!$OMP SHARED(bo,v_drhob,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3487 DO k = bo(1, 3), bo(2, 3)
3488 DO j = bo(1, 2), bo(2, 2)
3489 DO i = bo(1, 1), bo(2, 1)
3490 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3491 deriv_data(i, j, k)*dra1dra(i, j, k)
3492 END DO
3493 END DO
3494 END DO
3495 END IF
3496 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_norm_drhob])
3497 IF (ASSOCIATED(deriv_att)) THEN
3498 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3499!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3500!$OMP SHARED(bo,v_drhob,deriv_data,drb1drb,fac) COLLAPSE(3)
3501 DO k = bo(1, 3), bo(2, 3)
3502 DO j = bo(1, 2), bo(2, 2)
3503 DO i = bo(1, 1), bo(2, 1)
3504 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3505 deriv_data(i, j, k)*drb1drb(i, j, k)
3506 END DO
3507 END DO
3508 END DO
3509 END IF
3510 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_tau_a])
3511 IF (ASSOCIATED(deriv_att)) THEN
3512 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3513!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3514!$OMP SHARED(bo,v_drhob,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3515 DO k = bo(1, 3), bo(2, 3)
3516 DO j = bo(1, 2), bo(2, 2)
3517 DO i = bo(1, 1), bo(2, 1)
3518 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3519 deriv_data(i, j, k)*tau1a(i, j, k)
3520 END DO
3521 END DO
3522 END DO
3523 END IF
3524 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_tau_b])
3525 IF (ASSOCIATED(deriv_att)) THEN
3526 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3527!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3528!$OMP SHARED(bo,v_drhob,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3529 DO k = bo(1, 3), bo(2, 3)
3530 DO j = bo(1, 2), bo(2, 2)
3531 DO i = bo(1, 1), bo(2, 1)
3532 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3533 deriv_data(i, j, k)*tau1b(i, j, k)
3534 END DO
3535 END DO
3536 END DO
3537 END IF
3539 IF (ASSOCIATED(deriv_att)) THEN
3540 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3541!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3542!$OMP SHARED(bo,v_drhob,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3543 DO k = bo(1, 3), bo(2, 3)
3544 DO j = bo(1, 2), bo(2, 2)
3545 DO i = bo(1, 1), bo(2, 1)
3546 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3547 deriv_data(i, j, k)*laplace1a(i, j, k)
3548 END DO
3549 END DO
3550 END DO
3551 END IF
3553 IF (ASSOCIATED(deriv_att)) THEN
3554 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3555!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3556!$OMP SHARED(bo,v_drhob,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3557 DO k = bo(1, 3), bo(2, 3)
3558 DO j = bo(1, 2), bo(2, 2)
3559 DO i = bo(1, 1), bo(2, 1)
3560 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
3561 deriv_data(i, j, k)*laplace1b(i, j, k)
3562 END DO
3563 END DO
3564 END DO
3565 END IF
3566
3567 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob])
3568 IF (ASSOCIATED(deriv_att)) THEN
3569 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3570 CALL xc_derivative_get(deriv_att, deriv_data=e_drhob)
3571
3572 IF (my_compute_virial) THEN
3573 CALL virial_drho_drho1(virial_pw, drhob, drho1b, deriv_data, virial_xc)
3574 END IF ! my_compute_virial
3575
3576!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drb1drb,gradient_cut,norm_drhob,v_drhob,deriv_data)
3577 v_drhob(2)%array(:, :, :) = v_drhob(2)%array(:, :, :) + &
3578 deriv_data(:, :, :)*drb1drb(:, :, :)/max(gradient_cut, norm_drhob(:, :, :))**2
3579!$OMP END PARALLEL WORKSHARE
3580 END IF
3581
3582 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_rhoa])
3583 IF (ASSOCIATED(deriv_att)) THEN
3584 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3585!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3586!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3587 DO k = bo(1, 3), bo(2, 3)
3588 DO j = bo(1, 2), bo(2, 2)
3589 DO i = bo(1, 1), bo(2, 1)
3590 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3591 deriv_data(i, j, k)*rho1a(i, j, k)
3592 END DO
3593 END DO
3594 END DO
3595 END IF
3596 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_rhob])
3597 IF (ASSOCIATED(deriv_att)) THEN
3598 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3599!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3600!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3601 DO k = bo(1, 3), bo(2, 3)
3602 DO j = bo(1, 2), bo(2, 2)
3603 DO i = bo(1, 1), bo(2, 1)
3604 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3605 deriv_data(i, j, k)*rho1b(i, j, k)
3606 END DO
3607 END DO
3608 END DO
3609 END IF
3610 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drho])
3611 IF (ASSOCIATED(deriv_att)) THEN
3612 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3613!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3614!$OMP SHARED(bo,v_xc_tau,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3615 DO k = bo(1, 3), bo(2, 3)
3616 DO j = bo(1, 2), bo(2, 2)
3617 DO i = bo(1, 1), bo(2, 1)
3618 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3619 deriv_data(i, j, k)*dr1dr(i, j, k)
3620 END DO
3621 END DO
3622 END DO
3623 END IF
3624 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drhoa])
3625 IF (ASSOCIATED(deriv_att)) THEN
3626 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3627!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3628!$OMP SHARED(bo,v_xc_tau,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3629 DO k = bo(1, 3), bo(2, 3)
3630 DO j = bo(1, 2), bo(2, 2)
3631 DO i = bo(1, 1), bo(2, 1)
3632 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3633 deriv_data(i, j, k)*dra1dra(i, j, k)
3634 END DO
3635 END DO
3636 END DO
3637 END IF
3638 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drhob])
3639 IF (ASSOCIATED(deriv_att)) THEN
3640 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3641!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3642!$OMP SHARED(bo,v_xc_tau,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3643 DO k = bo(1, 3), bo(2, 3)
3644 DO j = bo(1, 2), bo(2, 2)
3645 DO i = bo(1, 1), bo(2, 1)
3646 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3647 deriv_data(i, j, k)*drb1drb(i, j, k)
3648 END DO
3649 END DO
3650 END DO
3651 END IF
3652 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_tau_a])
3653 IF (ASSOCIATED(deriv_att)) THEN
3654 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3655!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3656!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1a,fac) COLLAPSE(3)
3657 DO k = bo(1, 3), bo(2, 3)
3658 DO j = bo(1, 2), bo(2, 2)
3659 DO i = bo(1, 1), bo(2, 1)
3660 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3661 deriv_data(i, j, k)*tau1a(i, j, k)
3662 END DO
3663 END DO
3664 END DO
3665 END IF
3666 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_tau_b])
3667 IF (ASSOCIATED(deriv_att)) THEN
3668 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3669!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3670!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1b,fac) COLLAPSE(3)
3671 DO k = bo(1, 3), bo(2, 3)
3672 DO j = bo(1, 2), bo(2, 2)
3673 DO i = bo(1, 1), bo(2, 1)
3674 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3675 deriv_data(i, j, k)*tau1b(i, j, k)
3676 END DO
3677 END DO
3678 END DO
3679 END IF
3680 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_laplace_rhoa])
3681 IF (ASSOCIATED(deriv_att)) THEN
3682 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3683!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3684!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3685 DO k = bo(1, 3), bo(2, 3)
3686 DO j = bo(1, 2), bo(2, 2)
3687 DO i = bo(1, 1), bo(2, 1)
3688 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3689 deriv_data(i, j, k)*laplace1a(i, j, k)
3690 END DO
3691 END DO
3692 END DO
3693 END IF
3694 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_laplace_rhob])
3695 IF (ASSOCIATED(deriv_att)) THEN
3696 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3697!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3698!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3699 DO k = bo(1, 3), bo(2, 3)
3700 DO j = bo(1, 2), bo(2, 2)
3701 DO i = bo(1, 1), bo(2, 1)
3702 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
3703 deriv_data(i, j, k)*laplace1b(i, j, k)
3704 END DO
3705 END DO
3706 END DO
3707 END IF
3708
3709
3710 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_rhoa])
3711 IF (ASSOCIATED(deriv_att)) THEN
3712 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3713!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3714!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3715 DO k = bo(1, 3), bo(2, 3)
3716 DO j = bo(1, 2), bo(2, 2)
3717 DO i = bo(1, 1), bo(2, 1)
3718 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3719 deriv_data(i, j, k)*rho1a(i, j, k)
3720 END DO
3721 END DO
3722 END DO
3723 END IF
3724 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_rhob])
3725 IF (ASSOCIATED(deriv_att)) THEN
3726 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3727!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3728!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3729 DO k = bo(1, 3), bo(2, 3)
3730 DO j = bo(1, 2), bo(2, 2)
3731 DO i = bo(1, 1), bo(2, 1)
3732 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3733 deriv_data(i, j, k)*rho1b(i, j, k)
3734 END DO
3735 END DO
3736 END DO
3737 END IF
3738 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_norm_drho])
3739 IF (ASSOCIATED(deriv_att)) THEN
3740 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3741!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3742!$OMP SHARED(bo,v_xc_tau,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3743 DO k = bo(1, 3), bo(2, 3)
3744 DO j = bo(1, 2), bo(2, 2)
3745 DO i = bo(1, 1), bo(2, 1)
3746 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3747 deriv_data(i, j, k)*dr1dr(i, j, k)
3748 END DO
3749 END DO
3750 END DO
3751 END IF
3752 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_norm_drhoa])
3753 IF (ASSOCIATED(deriv_att)) THEN
3754 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3755!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3756!$OMP SHARED(bo,v_xc_tau,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3757 DO k = bo(1, 3), bo(2, 3)
3758 DO j = bo(1, 2), bo(2, 2)
3759 DO i = bo(1, 1), bo(2, 1)
3760 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3761 deriv_data(i, j, k)*dra1dra(i, j, k)
3762 END DO
3763 END DO
3764 END DO
3765 END IF
3766 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_norm_drhob])
3767 IF (ASSOCIATED(deriv_att)) THEN
3768 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3769!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3770!$OMP SHARED(bo,v_xc_tau,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3771 DO k = bo(1, 3), bo(2, 3)
3772 DO j = bo(1, 2), bo(2, 2)
3773 DO i = bo(1, 1), bo(2, 1)
3774 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3775 deriv_data(i, j, k)*drb1drb(i, j, k)
3776 END DO
3777 END DO
3778 END DO
3779 END IF
3780 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_tau_a])
3781 IF (ASSOCIATED(deriv_att)) THEN
3782 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3783!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3784!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1a,fac) COLLAPSE(3)
3785 DO k = bo(1, 3), bo(2, 3)
3786 DO j = bo(1, 2), bo(2, 2)
3787 DO i = bo(1, 1), bo(2, 1)
3788 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3789 deriv_data(i, j, k)*tau1a(i, j, k)
3790 END DO
3791 END DO
3792 END DO
3793 END IF
3794 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_tau_b])
3795 IF (ASSOCIATED(deriv_att)) THEN
3796 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3797!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3798!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1b,fac) COLLAPSE(3)
3799 DO k = bo(1, 3), bo(2, 3)
3800 DO j = bo(1, 2), bo(2, 2)
3801 DO i = bo(1, 1), bo(2, 1)
3802 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3803 deriv_data(i, j, k)*tau1b(i, j, k)
3804 END DO
3805 END DO
3806 END DO
3807 END IF
3808 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_laplace_rhoa])
3809 IF (ASSOCIATED(deriv_att)) THEN
3810 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3811!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3812!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
3813 DO k = bo(1, 3), bo(2, 3)
3814 DO j = bo(1, 2), bo(2, 2)
3815 DO i = bo(1, 1), bo(2, 1)
3816 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3817 deriv_data(i, j, k)*laplace1a(i, j, k)
3818 END DO
3819 END DO
3820 END DO
3821 END IF
3822 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_b, deriv_laplace_rhob])
3823 IF (ASSOCIATED(deriv_att)) THEN
3824 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3825!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3826!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
3827 DO k = bo(1, 3), bo(2, 3)
3828 DO j = bo(1, 2), bo(2, 2)
3829 DO i = bo(1, 1), bo(2, 1)
3830 v_xc_tau(2)%array(i, j, k) = v_xc_tau(2)%array(i, j, k) + &
3831 deriv_data(i, j, k)*laplace1b(i, j, k)
3832 END DO
3833 END DO
3834 END DO
3835 END IF
3836
3837
3838 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_rhoa])
3839 IF (ASSOCIATED(deriv_att)) THEN
3840 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3841!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3842!$OMP SHARED(bo,v_laplace,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3843 DO k = bo(1, 3), bo(2, 3)
3844 DO j = bo(1, 2), bo(2, 2)
3845 DO i = bo(1, 1), bo(2, 1)
3846 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3847 deriv_data(i, j, k)*rho1a(i, j, k)
3848 END DO
3849 END DO
3850 END DO
3851 END IF
3852 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_rhob])
3853 IF (ASSOCIATED(deriv_att)) THEN
3854 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3855!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3856!$OMP SHARED(bo,v_laplace,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3857 DO k = bo(1, 3), bo(2, 3)
3858 DO j = bo(1, 2), bo(2, 2)
3859 DO i = bo(1, 1), bo(2, 1)
3860 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3861 deriv_data(i, j, k)*rho1b(i, j, k)
3862 END DO
3863 END DO
3864 END DO
3865 END IF
3867 IF (ASSOCIATED(deriv_att)) THEN
3868 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3869!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3870!$OMP SHARED(bo,v_laplace,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
3871 DO k = bo(1, 3), bo(2, 3)
3872 DO j = bo(1, 2), bo(2, 2)
3873 DO i = bo(1, 1), bo(2, 1)
3874 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3875 deriv_data(i, j, k)*dr1dr(i, j, k)
3876 END DO
3877 END DO
3878 END DO
3879 END IF
3881 IF (ASSOCIATED(deriv_att)) THEN
3882 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3883!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3884!$OMP SHARED(bo,v_laplace,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
3885 DO k = bo(1, 3), bo(2, 3)
3886 DO j = bo(1, 2), bo(2, 2)
3887 DO i = bo(1, 1), bo(2, 1)
3888 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3889 deriv_data(i, j, k)*dra1dra(i, j, k)
3890 END DO
3891 END DO
3892 END DO
3893 END IF
3895 IF (ASSOCIATED(deriv_att)) THEN
3896 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3897!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3898!$OMP SHARED(bo,v_laplace,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
3899 DO k = bo(1, 3), bo(2, 3)
3900 DO j = bo(1, 2), bo(2, 2)
3901 DO i = bo(1, 1), bo(2, 1)
3902 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3903 deriv_data(i, j, k)*drb1drb(i, j, k)
3904 END DO
3905 END DO
3906 END DO
3907 END IF
3908 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_tau_a])
3909 IF (ASSOCIATED(deriv_att)) THEN
3910 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3911!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3912!$OMP SHARED(bo,v_laplace,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
3913 DO k = bo(1, 3), bo(2, 3)
3914 DO j = bo(1, 2), bo(2, 2)
3915 DO i = bo(1, 1), bo(2, 1)
3916 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3917 deriv_data(i, j, k)*tau1a(i, j, k)
3918 END DO
3919 END DO
3920 END DO
3921 END IF
3922 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_tau_b])
3923 IF (ASSOCIATED(deriv_att)) THEN
3924 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3925!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3926!$OMP SHARED(bo,v_laplace,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
3927 DO k = bo(1, 3), bo(2, 3)
3928 DO j = bo(1, 2), bo(2, 2)
3929 DO i = bo(1, 1), bo(2, 1)
3930 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3931 deriv_data(i, j, k)*tau1b(i, j, k)
3932 END DO
3933 END DO
3934 END DO
3935 END IF
3937 IF (ASSOCIATED(deriv_att)) THEN
3938 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3939!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3940!$OMP SHARED(bo,v_laplace,deriv_data,laplace1a,fac) COLLAPSE(3)
3941 DO k = bo(1, 3), bo(2, 3)
3942 DO j = bo(1, 2), bo(2, 2)
3943 DO i = bo(1, 1), bo(2, 1)
3944 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3945 deriv_data(i, j, k)*laplace1a(i, j, k)
3946 END DO
3947 END DO
3948 END DO
3949 END IF
3951 IF (ASSOCIATED(deriv_att)) THEN
3952 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3953!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3954!$OMP SHARED(bo,v_laplace,deriv_data,laplace1b,fac) COLLAPSE(3)
3955 DO k = bo(1, 3), bo(2, 3)
3956 DO j = bo(1, 2), bo(2, 2)
3957 DO i = bo(1, 1), bo(2, 1)
3958 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
3959 deriv_data(i, j, k)*laplace1b(i, j, k)
3960 END DO
3961 END DO
3962 END DO
3963 END IF
3964
3965
3966 IF (my_compute_virial) THEN
3967 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa])
3968 IF (ASSOCIATED(deriv_att)) THEN
3969 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3970
3971 virial_pw%array(:, :, :) = -rho1a(:, :, :)
3972 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
3973 END IF
3974 END IF ! my_compute_virial
3975 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_rhoa])
3976 IF (ASSOCIATED(deriv_att)) THEN
3977 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3978!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3979!$OMP SHARED(bo,v_laplace,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
3980 DO k = bo(1, 3), bo(2, 3)
3981 DO j = bo(1, 2), bo(2, 2)
3982 DO i = bo(1, 1), bo(2, 1)
3983 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3984 deriv_data(i, j, k)*rho1a(i, j, k)
3985 END DO
3986 END DO
3987 END DO
3988 END IF
3989 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_rhob])
3990 IF (ASSOCIATED(deriv_att)) THEN
3991 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
3992!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
3993!$OMP SHARED(bo,v_laplace,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
3994 DO k = bo(1, 3), bo(2, 3)
3995 DO j = bo(1, 2), bo(2, 2)
3996 DO i = bo(1, 1), bo(2, 1)
3997 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
3998 deriv_data(i, j, k)*rho1b(i, j, k)
3999 END DO
4000 END DO
4001 END DO
4002 END IF
4004 IF (ASSOCIATED(deriv_att)) THEN
4005 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4006!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4007!$OMP SHARED(bo,v_laplace,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4008 DO k = bo(1, 3), bo(2, 3)
4009 DO j = bo(1, 2), bo(2, 2)
4010 DO i = bo(1, 1), bo(2, 1)
4011 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4012 deriv_data(i, j, k)*dr1dr(i, j, k)
4013 END DO
4014 END DO
4015 END DO
4016 END IF
4018 IF (ASSOCIATED(deriv_att)) THEN
4019 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4020!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4021!$OMP SHARED(bo,v_laplace,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4022 DO k = bo(1, 3), bo(2, 3)
4023 DO j = bo(1, 2), bo(2, 2)
4024 DO i = bo(1, 1), bo(2, 1)
4025 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4026 deriv_data(i, j, k)*dra1dra(i, j, k)
4027 END DO
4028 END DO
4029 END DO
4030 END IF
4032 IF (ASSOCIATED(deriv_att)) THEN
4033 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4034!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4035!$OMP SHARED(bo,v_laplace,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4036 DO k = bo(1, 3), bo(2, 3)
4037 DO j = bo(1, 2), bo(2, 2)
4038 DO i = bo(1, 1), bo(2, 1)
4039 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4040 deriv_data(i, j, k)*drb1drb(i, j, k)
4041 END DO
4042 END DO
4043 END DO
4044 END IF
4045 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_tau_a])
4046 IF (ASSOCIATED(deriv_att)) THEN
4047 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4048!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4049!$OMP SHARED(bo,v_laplace,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
4050 DO k = bo(1, 3), bo(2, 3)
4051 DO j = bo(1, 2), bo(2, 2)
4052 DO i = bo(1, 1), bo(2, 1)
4053 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4054 deriv_data(i, j, k)*tau1a(i, j, k)
4055 END DO
4056 END DO
4057 END DO
4058 END IF
4059 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob, deriv_tau_b])
4060 IF (ASSOCIATED(deriv_att)) THEN
4061 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4062!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4063!$OMP SHARED(bo,v_laplace,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
4064 DO k = bo(1, 3), bo(2, 3)
4065 DO j = bo(1, 2), bo(2, 2)
4066 DO i = bo(1, 1), bo(2, 1)
4067 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4068 deriv_data(i, j, k)*tau1b(i, j, k)
4069 END DO
4070 END DO
4071 END DO
4072 END IF
4074 IF (ASSOCIATED(deriv_att)) THEN
4075 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4076!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4077!$OMP SHARED(bo,v_laplace,deriv_data,laplace1a,fac) COLLAPSE(3)
4078 DO k = bo(1, 3), bo(2, 3)
4079 DO j = bo(1, 2), bo(2, 2)
4080 DO i = bo(1, 1), bo(2, 1)
4081 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4082 deriv_data(i, j, k)*laplace1a(i, j, k)
4083 END DO
4084 END DO
4085 END DO
4086 END IF
4088 IF (ASSOCIATED(deriv_att)) THEN
4089 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4090!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4091!$OMP SHARED(bo,v_laplace,deriv_data,laplace1b,fac) COLLAPSE(3)
4092 DO k = bo(1, 3), bo(2, 3)
4093 DO j = bo(1, 2), bo(2, 2)
4094 DO i = bo(1, 1), bo(2, 1)
4095 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4096 deriv_data(i, j, k)*laplace1b(i, j, k)
4097 END DO
4098 END DO
4099 END DO
4100 END IF
4101
4102
4103 IF (my_compute_virial) THEN
4104 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhob])
4105 IF (ASSOCIATED(deriv_att)) THEN
4106 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4107
4108 virial_pw%array(:, :, :) = -rho1b(:, :, :)
4109 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
4110 END IF
4111 END IF ! my_compute_virial
4112
4113
4114 ELSE
4115
4116 ! Compute (fxc^{\alpha\alpha}+-fxc^{\beta\beta})*\rho(1) over the grid points
4117 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhoa])
4118 IF (ASSOCIATED(deriv_att)) THEN
4119 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4120!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4121!$OMP SHARED(bo,v_xc,deriv_data,rho1a,fac) COLLAPSE(3)
4122 DO k = bo(1, 3), bo(2, 3)
4123 DO j = bo(1, 2), bo(2, 2)
4124 DO i = bo(1, 1), bo(2, 1)
4125 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4126 deriv_data(i, j, k)*rho1a(i, j, k)
4127 END DO
4128 END DO
4129 END DO
4130 END IF
4131 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drho])
4132 IF (ASSOCIATED(deriv_att)) THEN
4133 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4134!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4135!$OMP SHARED(bo,v_xc,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4136 DO k = bo(1, 3), bo(2, 3)
4137 DO j = bo(1, 2), bo(2, 2)
4138 DO i = bo(1, 1), bo(2, 1)
4139 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4140 deriv_data(i, j, k)*dr1dr(i, j, k)
4141 END DO
4142 END DO
4143 END DO
4144 END IF
4145 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhoa])
4146 IF (ASSOCIATED(deriv_att)) THEN
4147 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4148!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4149!$OMP SHARED(bo,v_xc,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4150 DO k = bo(1, 3), bo(2, 3)
4151 DO j = bo(1, 2), bo(2, 2)
4152 DO i = bo(1, 1), bo(2, 1)
4153 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4154 deriv_data(i, j, k)*dra1dra(i, j, k)
4155 END DO
4156 END DO
4157 END DO
4158 END IF
4159 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_tau_a])
4160 IF (ASSOCIATED(deriv_att)) THEN
4161 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4162!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4163!$OMP SHARED(bo,v_xc,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
4164 DO k = bo(1, 3), bo(2, 3)
4165 DO j = bo(1, 2), bo(2, 2)
4166 DO i = bo(1, 1), bo(2, 1)
4167 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4168 deriv_data(i, j, k)*tau1a(i, j, k)
4169 END DO
4170 END DO
4171 END DO
4172 END IF
4173 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_laplace_rhoa])
4174 IF (ASSOCIATED(deriv_att)) THEN
4175 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4176!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4177!$OMP SHARED(bo,v_xc,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
4178 DO k = bo(1, 3), bo(2, 3)
4179 DO j = bo(1, 2), bo(2, 2)
4180 DO i = bo(1, 1), bo(2, 1)
4181 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4182 deriv_data(i, j, k)*laplace1a(i, j, k)
4183 END DO
4184 END DO
4185 END DO
4186 END IF
4187 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhob])
4188 IF (ASSOCIATED(deriv_att)) THEN
4189 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4190!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4191!$OMP SHARED(bo,v_xc,deriv_data,rho1b,fac) COLLAPSE(3)
4192 DO k = bo(1, 3), bo(2, 3)
4193 DO j = bo(1, 2), bo(2, 2)
4194 DO i = bo(1, 1), bo(2, 1)
4195 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4196 fac*deriv_data(i, j, k)*rho1b(i, j, k)
4197 END DO
4198 END DO
4199 END DO
4200 END IF
4201 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhob])
4202 IF (ASSOCIATED(deriv_att)) THEN
4203 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4204!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4205!$OMP SHARED(bo,v_xc,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4206 DO k = bo(1, 3), bo(2, 3)
4207 DO j = bo(1, 2), bo(2, 2)
4208 DO i = bo(1, 1), bo(2, 1)
4209 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4210 fac*deriv_data(i, j, k)*drb1drb(i, j, k)
4211 END DO
4212 END DO
4213 END DO
4214 END IF
4215 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_tau_b])
4216 IF (ASSOCIATED(deriv_att)) THEN
4217 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4218!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4219!$OMP SHARED(bo,v_xc,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
4220 DO k = bo(1, 3), bo(2, 3)
4221 DO j = bo(1, 2), bo(2, 2)
4222 DO i = bo(1, 1), bo(2, 1)
4223 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4224 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4225 END DO
4226 END DO
4227 END DO
4228 END IF
4229 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_laplace_rhob])
4230 IF (ASSOCIATED(deriv_att)) THEN
4231 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4232!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4233!$OMP SHARED(bo,v_xc,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
4234 DO k = bo(1, 3), bo(2, 3)
4235 DO j = bo(1, 2), bo(2, 2)
4236 DO i = bo(1, 1), bo(2, 1)
4237 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4238 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4239 END DO
4240 END DO
4241 END DO
4242 END IF
4243
4244
4245 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rhoa])
4246 IF (ASSOCIATED(deriv_att)) THEN
4247 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4248!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4249!$OMP SHARED(bo,v_drho,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
4250 DO k = bo(1, 3), bo(2, 3)
4251 DO j = bo(1, 2), bo(2, 2)
4252 DO i = bo(1, 1), bo(2, 1)
4253 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4254 deriv_data(i, j, k)*rho1a(i, j, k)
4255 END DO
4256 END DO
4257 END DO
4258 END IF
4259 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drho])
4260 IF (ASSOCIATED(deriv_att)) THEN
4261 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4262!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4263!$OMP SHARED(bo,v_drho,deriv_data,dr1dr,fac) COLLAPSE(3)
4264 DO k = bo(1, 3), bo(2, 3)
4265 DO j = bo(1, 2), bo(2, 2)
4266 DO i = bo(1, 1), bo(2, 1)
4267 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4268 deriv_data(i, j, k)*dr1dr(i, j, k)
4269 END DO
4270 END DO
4271 END DO
4272 END IF
4273 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhoa])
4274 IF (ASSOCIATED(deriv_att)) THEN
4275 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4276!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4277!$OMP SHARED(bo,v_drho,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4278 DO k = bo(1, 3), bo(2, 3)
4279 DO j = bo(1, 2), bo(2, 2)
4280 DO i = bo(1, 1), bo(2, 1)
4281 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4282 deriv_data(i, j, k)*dra1dra(i, j, k)
4283 END DO
4284 END DO
4285 END DO
4286 END IF
4287 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_tau_a])
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_drho,deriv_data,tau1a,v_xc_tau,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_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4296 deriv_data(i, j, k)*tau1a(i, j, k)
4297 END DO
4298 END DO
4299 END DO
4300 END IF
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_drho,deriv_data,laplace1a,v_laplace,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_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4310 deriv_data(i, j, k)*laplace1a(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_drho, deriv_rhob])
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_drho,deriv_data,rho1b,v_xc,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_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4324 fac*deriv_data(i, j, k)*rho1b(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_drho, deriv_norm_drhob])
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_drho,deriv_data,drb1drb,v_drhob,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_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4338 fac*deriv_data(i, j, k)*drb1drb(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_drho, deriv_tau_b])
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_drho,deriv_data,tau1b,v_xc_tau,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_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4352 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4353 END DO
4354 END DO
4355 END DO
4356 END IF
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_drho,deriv_data,laplace1b,v_laplace,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_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
4366 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4367 END DO
4368 END DO
4369 END DO
4370 END IF
4371
4372 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho])
4373 IF (ASSOCIATED(deriv_att)) THEN
4374 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4375 CALL xc_derivative_get(deriv_att, deriv_data=e_drho)
4376
4377
4378!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,gradient_cut,norm_drho,v_drho,deriv_data)
4379 v_drho(1)%array(:, :, :) = v_drho(1)%array(:, :, :) + &
4380 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
4381!$OMP END PARALLEL WORKSHARE
4382 END IF
4383
4384 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhoa])
4385 IF (ASSOCIATED(deriv_att)) THEN
4386 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4387!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4388!$OMP SHARED(bo,v_drhoa,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
4389 DO k = bo(1, 3), bo(2, 3)
4390 DO j = bo(1, 2), bo(2, 2)
4391 DO i = bo(1, 1), bo(2, 1)
4392 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4393 deriv_data(i, j, k)*rho1a(i, j, k)
4394 END DO
4395 END DO
4396 END DO
4397 END IF
4398 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drho])
4399 IF (ASSOCIATED(deriv_att)) THEN
4400 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4401!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4402!$OMP SHARED(bo,v_drhoa,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4403 DO k = bo(1, 3), bo(2, 3)
4404 DO j = bo(1, 2), bo(2, 2)
4405 DO i = bo(1, 1), bo(2, 1)
4406 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4407 deriv_data(i, j, k)*dr1dr(i, j, k)
4408 END DO
4409 END DO
4410 END DO
4411 END IF
4412 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhoa])
4413 IF (ASSOCIATED(deriv_att)) THEN
4414 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4415!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4416!$OMP SHARED(bo,v_drhoa,deriv_data,dra1dra,fac) COLLAPSE(3)
4417 DO k = bo(1, 3), bo(2, 3)
4418 DO j = bo(1, 2), bo(2, 2)
4419 DO i = bo(1, 1), bo(2, 1)
4420 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4421 deriv_data(i, j, k)*dra1dra(i, j, k)
4422 END DO
4423 END DO
4424 END DO
4425 END IF
4426 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_tau_a])
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_drhoa,deriv_data,tau1a,v_xc_tau,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_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4435 deriv_data(i, j, k)*tau1a(i, j, k)
4436 END DO
4437 END DO
4438 END DO
4439 END IF
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_drhoa,deriv_data,laplace1a,v_laplace,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_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4449 deriv_data(i, j, k)*laplace1a(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_norm_drhoa, deriv_rhob])
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_drhoa,deriv_data,rho1b,v_xc,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_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4463 fac*deriv_data(i, j, k)*rho1b(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_norm_drhoa, deriv_norm_drhob])
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_drhoa,deriv_data,drb1drb,v_drhob,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_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4477 fac*deriv_data(i, j, k)*drb1drb(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_norm_drhoa, deriv_tau_b])
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_drhoa,deriv_data,tau1b,v_xc_tau,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_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4491 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4492 END DO
4493 END DO
4494 END DO
4495 END IF
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_drhoa,deriv_data,laplace1b,v_laplace,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_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
4505 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4506 END DO
4507 END DO
4508 END DO
4509 END IF
4510
4511 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa])
4512 IF (ASSOCIATED(deriv_att)) THEN
4513 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4514 CALL xc_derivative_get(deriv_att, deriv_data=e_drhoa)
4515
4516
4517!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dra1dra,gradient_cut,norm_drhoa,v_drhoa,deriv_data)
4518 v_drhoa(1)%array(:, :, :) = v_drhoa(1)%array(:, :, :) + &
4519 deriv_data(:, :, :)*dra1dra(:, :, :)/max(gradient_cut, norm_drhoa(:, :, :))**2
4520!$OMP END PARALLEL WORKSHARE
4521 END IF
4522
4523 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_rhoa])
4524 IF (ASSOCIATED(deriv_att)) THEN
4525 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4526!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4527!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
4528 DO k = bo(1, 3), bo(2, 3)
4529 DO j = bo(1, 2), bo(2, 2)
4530 DO i = bo(1, 1), bo(2, 1)
4531 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4532 deriv_data(i, j, k)*rho1a(i, j, k)
4533 END DO
4534 END DO
4535 END DO
4536 END IF
4537 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drho])
4538 IF (ASSOCIATED(deriv_att)) THEN
4539 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4540!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4541!$OMP SHARED(bo,v_xc_tau,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4542 DO k = bo(1, 3), bo(2, 3)
4543 DO j = bo(1, 2), bo(2, 2)
4544 DO i = bo(1, 1), bo(2, 1)
4545 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4546 deriv_data(i, j, k)*dr1dr(i, j, k)
4547 END DO
4548 END DO
4549 END DO
4550 END IF
4551 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drhoa])
4552 IF (ASSOCIATED(deriv_att)) THEN
4553 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4554!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4555!$OMP SHARED(bo,v_xc_tau,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4556 DO k = bo(1, 3), bo(2, 3)
4557 DO j = bo(1, 2), bo(2, 2)
4558 DO i = bo(1, 1), bo(2, 1)
4559 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4560 deriv_data(i, j, k)*dra1dra(i, j, k)
4561 END DO
4562 END DO
4563 END DO
4564 END IF
4565 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_tau_a])
4566 IF (ASSOCIATED(deriv_att)) THEN
4567 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4568!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4569!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1a,fac) COLLAPSE(3)
4570 DO k = bo(1, 3), bo(2, 3)
4571 DO j = bo(1, 2), bo(2, 2)
4572 DO i = bo(1, 1), bo(2, 1)
4573 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4574 deriv_data(i, j, k)*tau1a(i, j, k)
4575 END DO
4576 END DO
4577 END DO
4578 END IF
4579 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_laplace_rhoa])
4580 IF (ASSOCIATED(deriv_att)) THEN
4581 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4582!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4583!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1a,v_laplace,fac) COLLAPSE(3)
4584 DO k = bo(1, 3), bo(2, 3)
4585 DO j = bo(1, 2), bo(2, 2)
4586 DO i = bo(1, 1), bo(2, 1)
4587 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4588 deriv_data(i, j, k)*laplace1a(i, j, k)
4589 END DO
4590 END DO
4591 END DO
4592 END IF
4593 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_rhob])
4594 IF (ASSOCIATED(deriv_att)) THEN
4595 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4596!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4597!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
4598 DO k = bo(1, 3), bo(2, 3)
4599 DO j = bo(1, 2), bo(2, 2)
4600 DO i = bo(1, 1), bo(2, 1)
4601 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4602 fac*deriv_data(i, j, k)*rho1b(i, j, k)
4603 END DO
4604 END DO
4605 END DO
4606 END IF
4607 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_norm_drhob])
4608 IF (ASSOCIATED(deriv_att)) THEN
4609 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4610!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4611!$OMP SHARED(bo,v_xc_tau,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4612 DO k = bo(1, 3), bo(2, 3)
4613 DO j = bo(1, 2), bo(2, 2)
4614 DO i = bo(1, 1), bo(2, 1)
4615 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4616 fac*deriv_data(i, j, k)*drb1drb(i, j, k)
4617 END DO
4618 END DO
4619 END DO
4620 END IF
4621 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_tau_b])
4622 IF (ASSOCIATED(deriv_att)) THEN
4623 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4624!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4625!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1b,fac) COLLAPSE(3)
4626 DO k = bo(1, 3), bo(2, 3)
4627 DO j = bo(1, 2), bo(2, 2)
4628 DO i = bo(1, 1), bo(2, 1)
4629 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4630 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4631 END DO
4632 END DO
4633 END DO
4634 END IF
4635 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau_a, deriv_laplace_rhob])
4636 IF (ASSOCIATED(deriv_att)) THEN
4637 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4638!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4639!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1b,v_laplace,fac) COLLAPSE(3)
4640 DO k = bo(1, 3), bo(2, 3)
4641 DO j = bo(1, 2), bo(2, 2)
4642 DO i = bo(1, 1), bo(2, 1)
4643 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
4644 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4645 END DO
4646 END DO
4647 END DO
4648 END IF
4649
4650
4651 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_rhoa])
4652 IF (ASSOCIATED(deriv_att)) THEN
4653 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4654!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4655!$OMP SHARED(bo,v_laplace,deriv_data,rho1a,v_xc,fac) COLLAPSE(3)
4656 DO k = bo(1, 3), bo(2, 3)
4657 DO j = bo(1, 2), bo(2, 2)
4658 DO i = bo(1, 1), bo(2, 1)
4659 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4660 deriv_data(i, j, k)*rho1a(i, j, k)
4661 END DO
4662 END DO
4663 END DO
4664 END IF
4666 IF (ASSOCIATED(deriv_att)) THEN
4667 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4668!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4669!$OMP SHARED(bo,v_laplace,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4670 DO k = bo(1, 3), bo(2, 3)
4671 DO j = bo(1, 2), bo(2, 2)
4672 DO i = bo(1, 1), bo(2, 1)
4673 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4674 deriv_data(i, j, k)*dr1dr(i, j, k)
4675 END DO
4676 END DO
4677 END DO
4678 END IF
4680 IF (ASSOCIATED(deriv_att)) THEN
4681 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4682!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4683!$OMP SHARED(bo,v_laplace,deriv_data,dra1dra,v_drhoa,fac) COLLAPSE(3)
4684 DO k = bo(1, 3), bo(2, 3)
4685 DO j = bo(1, 2), bo(2, 2)
4686 DO i = bo(1, 1), bo(2, 1)
4687 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4688 deriv_data(i, j, k)*dra1dra(i, j, k)
4689 END DO
4690 END DO
4691 END DO
4692 END IF
4693 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_tau_a])
4694 IF (ASSOCIATED(deriv_att)) THEN
4695 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4696!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4697!$OMP SHARED(bo,v_laplace,deriv_data,tau1a,v_xc_tau,fac) COLLAPSE(3)
4698 DO k = bo(1, 3), bo(2, 3)
4699 DO j = bo(1, 2), bo(2, 2)
4700 DO i = bo(1, 1), bo(2, 1)
4701 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4702 deriv_data(i, j, k)*tau1a(i, j, k)
4703 END DO
4704 END DO
4705 END DO
4706 END IF
4708 IF (ASSOCIATED(deriv_att)) THEN
4709 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4710!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4711!$OMP SHARED(bo,v_laplace,deriv_data,laplace1a,fac) COLLAPSE(3)
4712 DO k = bo(1, 3), bo(2, 3)
4713 DO j = bo(1, 2), bo(2, 2)
4714 DO i = bo(1, 1), bo(2, 1)
4715 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4716 deriv_data(i, j, k)*laplace1a(i, j, k)
4717 END DO
4718 END DO
4719 END DO
4720 END IF
4721 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_rhob])
4722 IF (ASSOCIATED(deriv_att)) THEN
4723 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4724!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4725!$OMP SHARED(bo,v_laplace,deriv_data,rho1b,v_xc,fac) COLLAPSE(3)
4726 DO k = bo(1, 3), bo(2, 3)
4727 DO j = bo(1, 2), bo(2, 2)
4728 DO i = bo(1, 1), bo(2, 1)
4729 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4730 fac*deriv_data(i, j, k)*rho1b(i, j, k)
4731 END DO
4732 END DO
4733 END DO
4734 END IF
4736 IF (ASSOCIATED(deriv_att)) THEN
4737 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4738!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4739!$OMP SHARED(bo,v_laplace,deriv_data,drb1drb,v_drhob,fac) COLLAPSE(3)
4740 DO k = bo(1, 3), bo(2, 3)
4741 DO j = bo(1, 2), bo(2, 2)
4742 DO i = bo(1, 1), bo(2, 1)
4743 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4744 fac*deriv_data(i, j, k)*drb1drb(i, j, k)
4745 END DO
4746 END DO
4747 END DO
4748 END IF
4749 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rhoa, deriv_tau_b])
4750 IF (ASSOCIATED(deriv_att)) THEN
4751 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4752!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4753!$OMP SHARED(bo,v_laplace,deriv_data,tau1b,v_xc_tau,fac) COLLAPSE(3)
4754 DO k = bo(1, 3), bo(2, 3)
4755 DO j = bo(1, 2), bo(2, 2)
4756 DO i = bo(1, 1), bo(2, 1)
4757 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4758 fac*deriv_data(i, j, k)*tau1b(i, j, k)
4759 END DO
4760 END DO
4761 END DO
4762 END IF
4764 IF (ASSOCIATED(deriv_att)) THEN
4765 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4766!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4767!$OMP SHARED(bo,v_laplace,deriv_data,laplace1b,fac) COLLAPSE(3)
4768 DO k = bo(1, 3), bo(2, 3)
4769 DO j = bo(1, 2), bo(2, 2)
4770 DO i = bo(1, 1), bo(2, 1)
4771 v_laplace(2)%array(i, j, k) = v_laplace(2)%array(i, j, k) + &
4772 fac*deriv_data(i, j, k)*laplace1b(i, j, k)
4773 END DO
4774 END DO
4775 END DO
4776 END IF
4777
4778
4779
4780
4781 END IF
4782
4783 IF (gradient_f) THEN
4784 IF (.NOT. do_spinflip) THEN
4785
4786 IF (my_compute_virial) THEN
4787 CALL virial_drho_drho(virial_pw, drhoa, v_drhoa(1), virial_xc)
4788 CALL virial_drho_drho(virial_pw, drhob, v_drhob(2), virial_xc)
4789 DO idir = 1, 3
4790!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,idir,v_drho,virial_pw)
4791 virial_pw%array(:, :, :) = drho(idir)%array(:, :, :)*(v_drho(1)%array(:, :, :) + v_drho(2)%array(:, :, :))
4792!$OMP END PARALLEL WORKSHARE
4793 DO jdir = 1, idir
4794 tmp = -0.5_dp*virial_pw%pw_grid%dvol*accurate_dot_product(virial_pw%array(:, :, :), &
4795 drho(jdir)%array(:, :, :))
4796 virial_xc(jdir, idir) = virial_xc(jdir, idir) + tmp
4797 virial_xc(idir, jdir) = virial_xc(jdir, idir)
4798 END DO
4799 END DO
4800 END IF ! my_compute_virial
4801
4802 IF (my_gapw) THEN
4803!$OMP PARALLEL DO DEFAULT(NONE) &
4804!$OMP PRIVATE(ia,idir,ispin,ir) &
4805!$OMP SHARED(bo,nspins,vxg,drhoa,drhob,v_drhoa,v_drhob,v_drho, &
4806!$OMP e_drhoa,e_drhob,e_drho,drho1a,drho1b,fac,drho,drho1) COLLAPSE(3)
4807 DO ir = bo(1, 2), bo(2, 2)
4808 DO ia = bo(1, 1), bo(2, 1)
4809 DO idir = 1, 3
4810 DO ispin = 1, nspins
4811 vxg(idir, ia, ir, ispin) = &
4812 -(v_drhoa(ispin)%array(ia, ir, 1)*drhoa(idir)%array(ia, ir, 1) + &
4813 v_drhob(ispin)%array(ia, ir, 1)*drhob(idir)%array(ia, ir, 1) + &
4814 v_drho(ispin)%array(ia, ir, 1)*drho(idir)%array(ia, ir, 1))
4815 END DO
4816 IF (ASSOCIATED(e_drhoa)) THEN
4817 vxg(idir, ia, ir, 1) = vxg(idir, ia, ir, 1) + &
4818 e_drhoa(ia, ir, 1)*drho1a(idir)%array(ia, ir, 1)
4819 END IF
4820 IF (nspins /= 1 .AND. ASSOCIATED(e_drhob)) THEN
4821 vxg(idir, ia, ir, 2) = vxg(idir, ia, ir, 2) + &
4822 e_drhob(ia, ir, 1)*drho1b(idir)%array(ia, ir, 1)
4823 END IF
4824 IF (ASSOCIATED(e_drho)) THEN
4825 IF (nspins /= 1) THEN
4826 vxg(idir, ia, ir, 1) = vxg(idir, ia, ir, 1) + &
4827 e_drho(ia, ir, 1)*drho1(idir)%array(ia, ir, 1)
4828 vxg(idir, ia, ir, 2) = vxg(idir, ia, ir, 2) + &
4829 e_drho(ia, ir, 1)*drho1(idir)%array(ia, ir, 1)
4830 ELSE
4831 vxg(idir, ia, ir, 1) = vxg(idir, ia, ir, 1) + &
4832 e_drho(ia, ir, 1)*(drho1a(idir)%array(ia, ir, 1) + &
4833 fac*drho1b(idir)%array(ia, ir, 1))
4834 END IF
4835 END IF
4836 END DO
4837 END DO
4838 END DO
4839!$OMP END PARALLEL DO
4840 ELSE
4841
4842 ! partial integration
4843 DO idir = 1, 3
4844
4845 DO ispin = 1, nspins
4846!$OMP PARALLEL WORKSHARE DEFAULT(NONE) &
4847!$OMP SHARED(v_drho_r,v_drhoa,v_drhob,v_drho,drhoa,drhob,drho,ispin,idir)
4848 v_drho_r(idir, ispin)%array(:, :, :) = &
4849 v_drhoa(ispin)%array(:, :, :)*drhoa(idir)%array(:, :, :) + &
4850 v_drhob(ispin)%array(:, :, :)*drhob(idir)%array(:, :, :) + &
4851 v_drho(ispin)%array(:, :, :)*drho(idir)%array(:, :, :)
4852!$OMP END PARALLEL WORKSHARE
4853 END DO
4854 IF (ASSOCIATED(e_drhoa)) THEN
4855!$OMP PARALLEL WORKSHARE DEFAULT(NONE) &
4856!$OMP SHARED(v_drho_r,e_drhoa,drho1a,idir)
4857 v_drho_r(idir, 1)%array(:, :, :) = v_drho_r(idir, 1)%array(:, :, :) - &
4858 e_drhoa(:, :, :)*drho1a(idir)%array(:, :, :)
4859!$OMP END PARALLEL WORKSHARE
4860 END IF
4861 IF (nspins /= 1 .AND. ASSOCIATED(e_drhob)) THEN
4862!$OMP PARALLEL WORKSHARE DEFAULT(NONE)&
4863!$OMP SHARED(v_drho_r,e_drhob,drho1b,idir)
4864 v_drho_r(idir, 2)%array(:, :, :) = v_drho_r(idir, 2)%array(:, :, :) - &
4865 e_drhob(:, :, :)*drho1b(idir)%array(:, :, :)
4866!$OMP END PARALLEL WORKSHARE
4867 END IF
4868 IF (ASSOCIATED(e_drho)) THEN
4869!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4870!$OMP SHARED(bo,v_drho_r,e_drho,drho1a,drho1b,drho1,fac,idir,nspins) COLLAPSE(3)
4871 DO k = bo(1, 3), bo(2, 3)
4872 DO j = bo(1, 2), bo(2, 2)
4873 DO i = bo(1, 1), bo(2, 1)
4874 IF (nspins /= 1) THEN
4875 v_drho_r(idir, 1)%array(i, j, k) = v_drho_r(idir, 1)%array(i, j, k) - &
4876 e_drho(i, j, k)*drho1(idir)%array(i, j, k)
4877 v_drho_r(idir, 2)%array(i, j, k) = v_drho_r(idir, 2)%array(i, j, k) - &
4878 e_drho(i, j, k)*drho1(idir)%array(i, j, k)
4879 ELSE
4880 v_drho_r(idir, 1)%array(i, j, k) = v_drho_r(idir, 1)%array(i, j, k) - &
4881 e_drho(i, j, k)*(drho1a(idir)%array(i, j, k) + &
4882 fac*drho1b(idir)%array(i, j, k))
4883 END IF
4884 END DO
4885 END DO
4886 END DO
4887!$OMP END PARALLEL DO
4888 END IF
4889 END DO
4890
4891 ! partial integration
4892 DO ispin = 1, nspins
4893 CALL xc_pw_divergence(xc_deriv_method_id, v_drho_r(:, ispin), tmp_g, vxc_g, v_xc(ispin))
4894 END DO ! ispin
4895
4896 END IF
4897
4898 END IF ! .NOT.do_spinflip
4899
4900 DO idir = 1, 3
4901 DEALLOCATE (drho(idir)%array)
4902 DEALLOCATE (drho1(idir)%array)
4903 END DO
4904
4905 DO ispin = 1, nspins
4906 CALL deallocate_pw(v_drhoa(ispin), pw_pool)
4907 CALL deallocate_pw(v_drhob(ispin), pw_pool)
4908 END DO
4909
4910 DEALLOCATE (v_drhoa, v_drhob)
4911
4912 END IF ! gradient_f
4913
4914 IF (laplace_f .AND. my_compute_virial) THEN
4915 virial_pw%array(:, :, :) = -rhoa(:, :, :)
4916 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplace(1)%array)
4917 virial_pw%array(:, :, :) = -rhob(:, :, :)
4918 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplace(2)%array)
4919 END IF
4920
4921 ELSE
4922
4923 !-----------------!
4924 ! restricted case !
4925 !-----------------!
4926
4927 CALL xc_rho_set_get(rho1_set, rho=rho1)
4928
4929 IF (gradient_f) THEN
4930 CALL xc_rho_set_get(rho_set, drho=drho, norm_drho=norm_drho)
4931 CALL xc_rho_set_get(rho1_set, drho=drho1)
4932 CALL prepare_dr1dr(dr1dr, drho, drho1)
4933 END IF
4934
4935 IF (laplace_f) THEN
4936 CALL xc_rho_set_get(rho1_set, laplace_rho=laplace1)
4937
4938 ALLOCATE (v_laplace(nspins))
4939 DO ispin = 1, nspins
4940 CALL allocate_pw(v_laplace(ispin), pw_pool, bo)
4941 END DO
4942
4943 IF (my_compute_virial) CALL xc_rho_set_get(rho_set, rho=rho)
4944 END IF
4945
4946 IF (tau_f) THEN
4947 CALL xc_rho_set_get(rho1_set, tau=tau1)
4948 END IF
4949
4950 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rho, deriv_rho])
4951 IF (ASSOCIATED(deriv_att)) THEN
4952 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4953!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4954!$OMP SHARED(bo,v_xc,deriv_data,rho1,fac) COLLAPSE(3)
4955 DO k = bo(1, 3), bo(2, 3)
4956 DO j = bo(1, 2), bo(2, 2)
4957 DO i = bo(1, 1), bo(2, 1)
4958 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4959 deriv_data(i, j, k)*rho1(i, j, k)
4960 END DO
4961 END DO
4962 END DO
4963 END IF
4964 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rho, deriv_norm_drho])
4965 IF (ASSOCIATED(deriv_att)) THEN
4966 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4967!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4968!$OMP SHARED(bo,v_xc,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
4969 DO k = bo(1, 3), bo(2, 3)
4970 DO j = bo(1, 2), bo(2, 2)
4971 DO i = bo(1, 1), bo(2, 1)
4972 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4973 deriv_data(i, j, k)*dr1dr(i, j, k)
4974 END DO
4975 END DO
4976 END DO
4977 END IF
4978 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rho, deriv_tau])
4979 IF (ASSOCIATED(deriv_att)) THEN
4980 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4981!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4982!$OMP SHARED(bo,v_xc,deriv_data,tau1,v_xc_tau,fac) COLLAPSE(3)
4983 DO k = bo(1, 3), bo(2, 3)
4984 DO j = bo(1, 2), bo(2, 2)
4985 DO i = bo(1, 1), bo(2, 1)
4986 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
4987 deriv_data(i, j, k)*tau1(i, j, k)
4988 END DO
4989 END DO
4990 END DO
4991 END IF
4992 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rho, deriv_laplace_rho])
4993 IF (ASSOCIATED(deriv_att)) THEN
4994 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
4995!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
4996!$OMP SHARED(bo,v_xc,deriv_data,laplace1,v_laplace,fac) COLLAPSE(3)
4997 DO k = bo(1, 3), bo(2, 3)
4998 DO j = bo(1, 2), bo(2, 2)
4999 DO i = bo(1, 1), bo(2, 1)
5000 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
5001 deriv_data(i, j, k)*laplace1(i, j, k)
5002 END DO
5003 END DO
5004 END DO
5005 END IF
5006
5007
5008 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rho])
5009 IF (ASSOCIATED(deriv_att)) THEN
5010 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5011!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5012!$OMP SHARED(bo,v_drho,deriv_data,rho1,v_xc,fac) COLLAPSE(3)
5013 DO k = bo(1, 3), bo(2, 3)
5014 DO j = bo(1, 2), bo(2, 2)
5015 DO i = bo(1, 1), bo(2, 1)
5016 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
5017 deriv_data(i, j, k)*rho1(i, j, k)
5018 END DO
5019 END DO
5020 END DO
5021 END IF
5022 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drho])
5023 IF (ASSOCIATED(deriv_att)) THEN
5024 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5025!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5026!$OMP SHARED(bo,v_drho,deriv_data,dr1dr,fac) COLLAPSE(3)
5027 DO k = bo(1, 3), bo(2, 3)
5028 DO j = bo(1, 2), bo(2, 2)
5029 DO i = bo(1, 1), bo(2, 1)
5030 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
5031 deriv_data(i, j, k)*dr1dr(i, j, k)
5032 END DO
5033 END DO
5034 END DO
5035 END IF
5036 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_tau])
5037 IF (ASSOCIATED(deriv_att)) THEN
5038 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5039!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5040!$OMP SHARED(bo,v_drho,deriv_data,tau1,v_xc_tau,fac) COLLAPSE(3)
5041 DO k = bo(1, 3), bo(2, 3)
5042 DO j = bo(1, 2), bo(2, 2)
5043 DO i = bo(1, 1), bo(2, 1)
5044 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
5045 deriv_data(i, j, k)*tau1(i, j, k)
5046 END DO
5047 END DO
5048 END DO
5049 END IF
5050 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_laplace_rho])
5051 IF (ASSOCIATED(deriv_att)) THEN
5052 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5053!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5054!$OMP SHARED(bo,v_drho,deriv_data,laplace1,v_laplace,fac) COLLAPSE(3)
5055 DO k = bo(1, 3), bo(2, 3)
5056 DO j = bo(1, 2), bo(2, 2)
5057 DO i = bo(1, 1), bo(2, 1)
5058 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
5059 deriv_data(i, j, k)*laplace1(i, j, k)
5060 END DO
5061 END DO
5062 END DO
5063 END IF
5064
5065 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho])
5066 IF (ASSOCIATED(deriv_att)) THEN
5067 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5068 CALL xc_derivative_get(deriv_att, deriv_data=e_drho)
5069
5070 IF (my_compute_virial) THEN
5071 CALL virial_drho_drho1(virial_pw, drho, drho1, deriv_data, virial_xc)
5072 END IF ! my_compute_virial
5073
5074!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,gradient_cut,norm_drho,v_drho,deriv_data)
5075 v_drho(1)%array(:, :, :) = v_drho(1)%array(:, :, :) + &
5076 deriv_data(:, :, :)*dr1dr(:, :, :)/max(gradient_cut, norm_drho(:, :, :))**2
5077!$OMP END PARALLEL WORKSHARE
5078 END IF
5079
5080 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau, deriv_rho])
5081 IF (ASSOCIATED(deriv_att)) THEN
5082 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5083!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5084!$OMP SHARED(bo,v_xc_tau,deriv_data,rho1,v_xc,fac) COLLAPSE(3)
5085 DO k = bo(1, 3), bo(2, 3)
5086 DO j = bo(1, 2), bo(2, 2)
5087 DO i = bo(1, 1), bo(2, 1)
5088 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
5089 deriv_data(i, j, k)*rho1(i, j, k)
5090 END DO
5091 END DO
5092 END DO
5093 END IF
5094 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau, deriv_norm_drho])
5095 IF (ASSOCIATED(deriv_att)) THEN
5096 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5097!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5098!$OMP SHARED(bo,v_xc_tau,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
5099 DO k = bo(1, 3), bo(2, 3)
5100 DO j = bo(1, 2), bo(2, 2)
5101 DO i = bo(1, 1), bo(2, 1)
5102 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
5103 deriv_data(i, j, k)*dr1dr(i, j, k)
5104 END DO
5105 END DO
5106 END DO
5107 END IF
5108 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau, deriv_tau])
5109 IF (ASSOCIATED(deriv_att)) THEN
5110 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5111!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5112!$OMP SHARED(bo,v_xc_tau,deriv_data,tau1,fac) COLLAPSE(3)
5113 DO k = bo(1, 3), bo(2, 3)
5114 DO j = bo(1, 2), bo(2, 2)
5115 DO i = bo(1, 1), bo(2, 1)
5116 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
5117 deriv_data(i, j, k)*tau1(i, j, k)
5118 END DO
5119 END DO
5120 END DO
5121 END IF
5122 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_tau, deriv_laplace_rho])
5123 IF (ASSOCIATED(deriv_att)) THEN
5124 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5125!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5126!$OMP SHARED(bo,v_xc_tau,deriv_data,laplace1,v_laplace,fac) COLLAPSE(3)
5127 DO k = bo(1, 3), bo(2, 3)
5128 DO j = bo(1, 2), bo(2, 2)
5129 DO i = bo(1, 1), bo(2, 1)
5130 v_xc_tau(1)%array(i, j, k) = v_xc_tau(1)%array(i, j, k) + &
5131 deriv_data(i, j, k)*laplace1(i, j, k)
5132 END DO
5133 END DO
5134 END DO
5135 END IF
5136
5137
5138 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho, deriv_rho])
5139 IF (ASSOCIATED(deriv_att)) THEN
5140 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5141!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5142!$OMP SHARED(bo,v_laplace,deriv_data,rho1,v_xc,fac) COLLAPSE(3)
5143 DO k = bo(1, 3), bo(2, 3)
5144 DO j = bo(1, 2), bo(2, 2)
5145 DO i = bo(1, 1), bo(2, 1)
5146 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
5147 deriv_data(i, j, k)*rho1(i, j, k)
5148 END DO
5149 END DO
5150 END DO
5151 END IF
5152 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho, deriv_norm_drho])
5153 IF (ASSOCIATED(deriv_att)) THEN
5154 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5155!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5156!$OMP SHARED(bo,v_laplace,deriv_data,dr1dr,v_drho,fac) COLLAPSE(3)
5157 DO k = bo(1, 3), bo(2, 3)
5158 DO j = bo(1, 2), bo(2, 2)
5159 DO i = bo(1, 1), bo(2, 1)
5160 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
5161 deriv_data(i, j, k)*dr1dr(i, j, k)
5162 END DO
5163 END DO
5164 END DO
5165 END IF
5166 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho, deriv_tau])
5167 IF (ASSOCIATED(deriv_att)) THEN
5168 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5169!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5170!$OMP SHARED(bo,v_laplace,deriv_data,tau1,v_xc_tau,fac) COLLAPSE(3)
5171 DO k = bo(1, 3), bo(2, 3)
5172 DO j = bo(1, 2), bo(2, 2)
5173 DO i = bo(1, 1), bo(2, 1)
5174 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
5175 deriv_data(i, j, k)*tau1(i, j, k)
5176 END DO
5177 END DO
5178 END DO
5179 END IF
5181 IF (ASSOCIATED(deriv_att)) THEN
5182 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5183!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5184!$OMP SHARED(bo,v_laplace,deriv_data,laplace1,fac) COLLAPSE(3)
5185 DO k = bo(1, 3), bo(2, 3)
5186 DO j = bo(1, 2), bo(2, 2)
5187 DO i = bo(1, 1), bo(2, 1)
5188 v_laplace(1)%array(i, j, k) = v_laplace(1)%array(i, j, k) + &
5189 deriv_data(i, j, k)*laplace1(i, j, k)
5190 END DO
5191 END DO
5192 END DO
5193 END IF
5194
5195
5196 IF (my_compute_virial) THEN
5197 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_laplace_rho])
5198 IF (ASSOCIATED(deriv_att)) THEN
5199 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5200
5201 virial_pw%array(:, :, :) = -rho1(:, :, :)
5202 CALL virial_laplace(virial_pw, pw_pool, virial_xc, deriv_data)
5203 END IF
5204 END IF ! my_compute_virial
5205
5206
5207 IF (gradient_f) THEN
5208
5209 IF (my_compute_virial) THEN
5210 CALL virial_drho_drho(virial_pw, drho, v_drho(1), virial_xc)
5211 END IF ! my_compute_virial
5212
5213 IF (my_gapw) THEN
5214
5215 DO idir = 1, 3
5216!$OMP PARALLEL DO DEFAULT(NONE) &
5217!$OMP PRIVATE(ia,ir) &
5218!$OMP SHARED(bo,vxg,drho,v_drho,e_drho,drho1,idir,factor2) &
5219!$OMP COLLAPSE(2)
5220 DO ia = bo(1, 1), bo(2, 1)
5221 DO ir = bo(1, 2), bo(2, 2)
5222 vxg(idir, ia, ir, 1) = -drho(idir)%array(ia, ir, 1)*v_drho(1)%array(ia, ir, 1)
5223 IF (ASSOCIATED(e_drho)) THEN
5224 vxg(idir, ia, ir, 1) = vxg(idir, ia, ir, 1) + factor2*drho1(idir)%array(ia, ir, 1)*e_drho(ia, ir, 1)
5225 END IF
5226 END DO
5227 END DO
5228!$OMP END PARALLEL DO
5229 END DO
5230
5231 ELSE
5232 ! partial integration
5233 DO idir = 1, 3
5234!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(v_drho_r,drho,v_drho,drho1,e_drho,idir)
5235 v_drho_r(idir, 1)%array(:, :, :) = drho(idir)%array(:, :, :)*v_drho(1)%array(:, :, :) - &
5236 drho1(idir)%array(:, :, :)*e_drho(:, :, :)
5237!$OMP END PARALLEL WORKSHARE
5238 END DO
5239
5240 CALL xc_pw_divergence(xc_deriv_method_id, v_drho_r(:, 1), tmp_g, vxc_g, v_xc(1))
5241 END IF
5242
5243 END IF
5244
5245 IF (laplace_f .AND. my_compute_virial) THEN
5246 virial_pw%array(:, :, :) = -rho(:, :, :)
5247 CALL virial_laplace(virial_pw, pw_pool, virial_xc, v_laplace(1)%array)
5248 END IF
5249
5250 END IF
5251
5252 IF (laplace_f) THEN
5253 DO ispin = 1, nspins
5254 CALL xc_pw_laplace(v_laplace(ispin), pw_pool, xc_deriv_method_id)
5255 CALL pw_axpy(v_laplace(ispin), v_xc(ispin))
5256 END DO
5257 END IF
5258
5259 IF (gradient_f) THEN
5260
5261 DO ispin = 1, nspins
5262 CALL deallocate_pw(v_drho(ispin), pw_pool)
5263 DO idir = 1, 3
5264 CALL deallocate_pw(v_drho_r(idir, ispin), pw_pool)
5265 END DO
5266 END DO
5267 DEALLOCATE (v_drho, v_drho_r)
5268
5269 END IF
5270
5271 IF (laplace_f) THEN
5272 DO ispin = 1, nspins
5273 CALL deallocate_pw(v_laplace(ispin), pw_pool)
5274 END DO
5275 DEALLOCATE (v_laplace)
5276 END IF
5277
5278 IF (ASSOCIATED(tmp_g%pw_grid) .AND. ASSOCIATED(pw_pool)) THEN
5279 CALL pw_pool%give_back_pw(tmp_g)
5280 END IF
5281
5282 IF (ASSOCIATED(vxc_g%pw_grid) .AND. ASSOCIATED(pw_pool)) THEN
5283 CALL pw_pool%give_back_pw(vxc_g)
5284 END IF
5285
5286 IF (my_compute_virial .AND. (gradient_f .OR. laplace_f)) THEN
5287 CALL deallocate_pw(virial_pw, pw_pool)
5288 END IF
5289
5290 CALL timestop(handle)
5291
5292 END SUBROUTINE xc_calc_2nd_deriv_analytical
5293
5294! **************************************************************************************************
5295!> \brief Calculates the third functional derivative of the exchange-correlation functional, E_xc.
5296!> Any GGA functional can be written as:
5297!>
5298!> E_xc[\rho] = \int e_xc(\rho,\nabla\rho)dr
5299!>
5300!> This routine gives you back the contraction of the derivatives of e_xc with respect to the
5301!> alpha or beta density or with respect to the norm of their gradients contracted with rho1.
5302!> For example, the alpha component would be (d stands for total derivative):
5303!>
5304!> d^3 e_xc
5305!> v_xc(1) = \sum_{s,s'}^{a,b} ---------------------\rhos1\rho1s'
5306!> d\rhoa d\rhos d\rhos'
5307!>
5308!> \param v_xc Third derivative of the exchange-correlation functional
5309!> \param v_xc_tau ...
5310!> \param deriv_set derivatives of the exchange-correlation potential, e_xc
5311!> \param rho_set object containing the density at which the derivatives were calculated, \rho
5312!> \param rho1_set object containing the density with which to fold, \rho1s
5313!> \param pw_pool the pool for the grids
5314!> \param xc_section XC parameters
5315!> \par History
5316!> * 07.2024 Created [LHS]
5317! **************************************************************************************************
5318 SUBROUTINE xc_calc_3rd_deriv_analytical(v_xc, v_xc_tau, deriv_set, rho_set, rho1_set, &
5319 pw_pool, xc_section, spinflip)
5320
5321 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: v_xc, v_xc_tau
5322 TYPE(xc_derivative_set_type) :: deriv_set
5323 TYPE(xc_rho_set_type), INTENT(IN) :: rho_set, rho1_set
5324 TYPE(pw_pool_type), POINTER :: pw_pool
5325 TYPE(section_vals_type), POINTER :: xc_section
5326 LOGICAL, INTENT(in), OPTIONAL :: spinflip
5327
5328 CHARACTER(len=*), PARAMETER :: routinen = 'xc_calc_3rd_deriv_analytical'
5329
5330 INTEGER :: handle, i, idir, ispin, j, &
5331 k, nspins, xc_deriv_method_id
5332 INTEGER, DIMENSION(2, 3) :: bo
5333 LOGICAL :: lsd, do_spinflip, alda0, &
5334 rho_f, gradient_f, tau_f, laplace_f
5335 REAL(kind=dp) :: s, s_thresh, s_thresh2, gradient_cut
5336 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :) :: dr1dr, dra1dra, drb1drb
5337 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: deriv_data, deriv_data2, e_drhoa, e_drhob, &
5338 e_drho, norm_drho, norm_drhoa, &
5339 norm_drhob, rho1a, rho1b, &
5340 rhoa, rhob
5341 TYPE(cp_3d_r_cp_type), DIMENSION(3) :: drho, drho1, drho1a, drho1b, drhoa, drhob
5342 TYPE(pw_r3d_rs_type), DIMENSION(:), ALLOCATABLE :: v_drhoa, v_drhob, v_drho
5343 TYPE(pw_r3d_rs_type), DIMENSION(:, :), ALLOCATABLE :: v_drho_r
5344 TYPE(pw_c1d_gs_type) :: tmp_g, vxc_g
5345 TYPE(xc_derivative_type), POINTER :: deriv_att
5346
5347 CALL timeset(routinen, handle)
5348
5349 NULLIFY (e_drhoa, e_drhob, e_drho)
5350
5351 cpassert(ASSOCIATED(v_xc))
5352 cpassert(ASSOCIATED(xc_section))
5353
5354 ! Initialize parameters
5355 CALL section_vals_val_get(xc_section, "XC_GRID%XC_DERIV", &
5356 i_val=xc_deriv_method_id)
5357 !
5358 nspins = SIZE(v_xc)
5359 lsd = ASSOCIATED(rho_set%rhoa)
5360 !
5361 do_spinflip = .false.
5362 IF (PRESENT(spinflip)) do_spinflip = spinflip
5363 !
5364 bo = rho_set%local_bounds
5365 !
5366 CALL check_for_derivatives(deriv_set, lsd, rho_f, gradient_f, tau_f, laplace_f)
5367 !
5368 CALL xc_rho_set_get(rho_set, drho_cutoff=gradient_cut)
5369 !
5370 !S_THRESH has to be the same as S_THRESH in xc_calc_2nd_deriv_analytical
5371 alda0 = .false.
5372 s_thresh = 1.0e-04
5373 s_thresh2 = 1.0e-07
5374
5375 ! Initialize potential
5376 DO ispin = 1, nspins
5377 !CALL pw_zero(v_xc(ispin))
5378 v_xc(ispin)%array = 0.0_dp
5379 END DO
5380
5381 ! Create GGA fields
5382 IF (gradient_f) THEN
5383 ALLOCATE (v_drho_r(3, nspins), v_drho(nspins))
5384 DO ispin = 1, nspins
5385 DO idir = 1, 3
5386 CALL allocate_pw(v_drho_r(idir, ispin), pw_pool, bo)
5387 END DO
5388 CALL allocate_pw(v_drho(ispin), pw_pool, bo)
5389 END DO
5390
5391 IF (xc_requires_tmp_g(xc_deriv_method_id)) THEN
5392 IF (ASSOCIATED(pw_pool)) THEN
5393 CALL pw_pool%create_pw(tmp_g)
5394 CALL pw_pool%create_pw(vxc_g)
5395 ELSE
5396 ! remember to refix for gapw
5397 cpabort("XC_DERIV method is not implemented in GAPW")
5398 END IF
5399 END IF
5400
5401 END IF
5402
5403 ! Initialize mGGA potential
5404 IF (tau_f) THEN
5405 cpassert(ASSOCIATED(v_xc_tau))
5406 DO ispin = 1, nspins
5407 v_xc_tau(ispin)%array = 0.0_dp
5408 END DO
5409 END IF
5410
5411 IF (lsd) THEN
5412
5413 !-------------------!
5414 ! UNrestricted case !
5415 !-------------------!
5416
5417 IF (do_spinflip) THEN
5418 CALL xc_rho_set_get(rho1_set, rhoa=rho1a)
5419 CALL xc_rho_set_get(rho_set, rhoa=rhoa, rhob=rhob)
5420 ELSE
5421 CALL xc_rho_set_get(rho1_set, rhoa=rho1a, rhob=rho1b)
5422 END IF
5423
5424 IF (gradient_f) THEN
5425 CALL xc_rho_set_get(rho_set, drhoa=drhoa, drhob=drhob, &
5426 norm_drho=norm_drho, norm_drhoa=norm_drhoa, norm_drhob=norm_drhob)
5427 IF (do_spinflip) THEN
5428 CALL xc_rho_set_get(rho1_set, drhoa=drho1a)
5429 CALL calc_drho_from_a(drho1, drho1a)
5430 ELSE
5431 CALL xc_rho_set_get(rho1_set, drhoa=drho1a, drhob=drho1b)
5432 CALL calc_drho_from_ab(drho1, drho1a, drho1b)
5433 END IF
5434
5435 CALL calc_drho_from_ab(drho, drhoa, drhob)
5436
5437 CALL prepare_dr1dr(dra1dra, drhoa, drho1a)
5438 IF (do_spinflip) THEN
5439 CALL prepare_dr1dr(drb1drb, drhob, drho1a)
5440 CALL prepare_dr1dr(dr1dr, drho, drho1a)
5441 ELSE IF (nspins /= 1) THEN
5442 CALL prepare_dr1dr(drb1drb, drhob, drho1b)
5443 CALL prepare_dr1dr(dr1dr, drho, drho1)
5444 ELSE
5445 cpabort("Exchange-correlation's third derivative for closed-shell not yet implemented")
5446 END IF
5447
5448 ! Create vectors for partial integration term
5449 ALLOCATE (v_drhoa(nspins), v_drhob(nspins))
5450 DO ispin = 1, nspins
5451 CALL allocate_pw(v_drhoa(ispin), pw_pool, bo)
5452 CALL allocate_pw(v_drhob(ispin), pw_pool, bo)
5453 END DO
5454
5455 END IF
5456
5457 IF (laplace_f) THEN
5458 cpabort("Exchange-correlation's laplace analytic third derivative not implemented")
5459 END IF
5460
5461 IF (tau_f) THEN
5462 cpabort("Exchange-correlation's mGGA analytic third derivative not implemented")
5463 END IF
5464
5465 IF (nspins /= 1) THEN
5466
5467 IF (.NOT. do_spinflip) THEN
5468 ! Analytic third derivative of the excchange-correlation functional
5469 cpabort("Exchange-correlation's analytic third derivative not implemented")
5470
5471 ELSE
5472
5473 ! vxc contributions
5474 ! vxca = (vxc^{\alpha}-vxc^{\beta})*rho1/|rhoa-rhob|^2
5475 ! vxcb =-(vxc^{\alpha}-vxc^{\beta})*rho1/|rhoa-rhob|^2
5476 ! Alpha LDA contribution
5477 ! | d e_xc d e_xc | rho1a
5478 ! vxca = rho1a*|-------- - --------|*---------------
5479 ! | drhoa drhob | |rhoa - rhob|^2
5480 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa])
5481 IF (ASSOCIATED(deriv_att)) THEN
5482 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5483 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob])
5484 IF (ASSOCIATED(deriv_att)) THEN
5485 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5486!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5487!$OMP SHARED(bo,v_xc,deriv_data,deriv_data2,rho1a,rhoa,rhob,S_THRESH2) COLLAPSE(3)
5488 DO k = bo(1, 3), bo(2, 3)
5489 DO j = bo(1, 2), bo(2, 2)
5490 DO i = bo(1, 1), bo(2, 1)
5491 s = rhoa(i, j, k) - rhob(i, j, k)
5492 s = -sign(max(s**2, s_thresh2), s)
5493 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
5494 (deriv_data(i, j, k) - deriv_data2(i, j, k))*rho1a(i, j, k)**2/s
5495 END DO
5496 END DO
5497 END DO
5498!$OMP END PARALLEL DO
5499 END IF
5500 END IF
5501 ! GGA contributions to the spin-flip xcKernel
5502 ! Alpha GGA contributions
5503 ! | d e_xc d e_xc | rho1a
5504 ! vxca += + |----------*dra1dra - ----------*drb1drb|*---------------
5505 ! | d|drhoa| d|drhob| | |rhoa - rhob|^2
5506 IF (.NOT. alda0) THEN
5507 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa])
5508 IF (ASSOCIATED(deriv_att)) THEN
5509 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5510 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob])
5511 IF (ASSOCIATED(deriv_att)) THEN
5512 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5513!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5514!$OMP SHARED(bo,deriv_data,deriv_data2,dra1dra,drb1drb,v_xc,rho1a,rhoa,rhob,S_THRESH2) COLLAPSE(3)
5515 DO k = bo(1, 3), bo(2, 3)
5516 DO j = bo(1, 2), bo(2, 2)
5517 DO i = bo(1, 1), bo(2, 1)
5518 s = rhoa(i, j, k) - rhob(i, j, k)
5519 s = -sign(max(s**2, s_thresh2), s)
5520 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
5521 (deriv_data(i, j, k)*dra1dra(i, j, k) - deriv_data2(i, j, k)*drb1drb(i, j, k)) &
5522 *rho1a(i, j, k)/s
5523 END DO
5524 END DO
5525 END DO
5526!$OMP END PARALLEL DO
5527 END IF
5528 END IF
5529 END IF
5530 ! Beta contribution = - alpha
5531!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5532!$OMP SHARED(bo,v_xc) COLLAPSE(3)
5533 DO k = bo(1, 3), bo(2, 3)
5534 DO j = bo(1, 2), bo(2, 2)
5535 DO i = bo(1, 1), bo(2, 1)
5536 v_xc(2)%array(i, j, k) = -v_xc(1)%array(i, j, k)
5537 END DO
5538 END DO
5539 END DO
5540!$OMP END PARALLEL DO
5541 ! fxc contributions
5542 ! vxca = rho1*(fxc^{\alpha\alpha}-fxc^{\alpha\beta})*rho1/|rhoa-rhob|
5543 ! vxcb = rho1*(fxc^{\beta\alpha}-fxc^{\beta\beta})*rho1/|rhoa-rhob|
5544 ! Alpha LDA contribution
5545 ! | d^2 e_xc d^2 e_xc | rho1a
5546 ! vxca += rho1a*|------------- - -------------|*-------------
5547 ! | drhoa drhoa drhoa drhob | |rhoa - rhob|
5548 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhob])
5549 IF (ASSOCIATED(deriv_att)) THEN
5550 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5551 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_rhoa])
5552 IF (ASSOCIATED(deriv_att)) THEN
5553 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5554!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5555!$OMP SHARED(bo,deriv_data,deriv_data2,rho1a,v_xc,rhoa,rhob,S_THRESH) COLLAPSE(3)
5556 DO k = bo(1, 3), bo(2, 3)
5557 DO j = bo(1, 2), bo(2, 2)
5558 DO i = bo(1, 1), bo(2, 1)
5559 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
5560 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
5561 rho1a(i, j, k)**2*(deriv_data(i, j, k) - deriv_data2(i, j, k))/s
5562 END DO
5563 END DO
5564 END DO
5565!$OMP END PARALLEL DO
5566 END IF
5567 END IF
5568 ! Beta LDA contribution
5569 ! | d^2 e_xc d^2 e_xc | rho1a
5570 ! vxcb += rho1a*|------------- - -------------|*-------------
5571 ! | drhob drhoa drhob drhob | |rhoa - rhob|
5572 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_rhob])
5573 IF (ASSOCIATED(deriv_att)) THEN
5574 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5575 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_rhoa])
5576 IF (ASSOCIATED(deriv_att)) THEN
5577 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5578!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5579!$OMP SHARED(bo,deriv_data,deriv_data2,rho1a,v_xc,rhoa,rhob,S_THRESH) COLLAPSE(3)
5580 DO k = bo(1, 3), bo(2, 3)
5581 DO j = bo(1, 2), bo(2, 2)
5582 DO i = bo(1, 1), bo(2, 1)
5583 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
5584 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
5585 rho1a(i, j, k)**2*(deriv_data(i, j, k) - deriv_data2(i, j, k))/s
5586 END DO
5587 END DO
5588 END DO
5589!$OMP END PARALLEL DO
5590 END IF
5591 END IF
5592 ! Alpha GGA contribution
5593 IF (.NOT. alda0) THEN
5594 ! rho1a | d^2 e_xc d^2 e_xc |
5595 ! vxca += + -------------*|----------------*dra1dra - ----------------*drb1drb|
5596 ! |rhoa - rhob| | drhoa d|drhoa| drhoa d|drhob| |
5597 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhob])
5598 IF (ASSOCIATED(deriv_att)) THEN
5599 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5600 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhoa, deriv_norm_drhoa])
5601 IF (ASSOCIATED(deriv_att)) THEN
5602 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5603!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5604!$OMP SHARED(bo,deriv_data,deriv_data2,dra1dra,drb1drb,rho1a,v_xc,rhoa,rhob,S_THRESH) COLLAPSE(3)
5605 DO k = bo(1, 3), bo(2, 3)
5606 DO j = bo(1, 2), bo(2, 2)
5607 DO i = bo(1, 1), bo(2, 1)
5608 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
5609 v_xc(1)%array(i, j, k) = v_xc(1)%array(i, j, k) + &
5610 (deriv_data(i, j, k)*dra1dra(i, j, k) - deriv_data2(i, j, k)*drb1drb(i, j, k))* &
5611 rho1a(i, j, k)/s
5612 END DO
5613 END DO
5614 END DO
5615!$OMP END PARALLEL DO
5616 END IF
5617 END IF
5618 ! Beta GGA contribution
5619 ! rho1a | d^2 e_xc d^2 e_xc |
5620 ! vxcb += + -------------*|----------------*dra1dra - ----------------*drb1drb|
5621 ! |rhoa - rhob| | drhob d|drhoa| drhob d|drhob| |
5622 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_norm_drhob])
5623 IF (ASSOCIATED(deriv_att)) THEN
5624 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5625 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_rhob, deriv_norm_drhoa])
5626 IF (ASSOCIATED(deriv_att)) THEN
5627 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5628!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5629!$OMP SHARED(bo,deriv_data,deriv_data2,dra1dra,drb1drb,rho1a,v_xc,rhoa,rhob,S_THRESH) COLLAPSE(3)
5630 DO k = bo(1, 3), bo(2, 3)
5631 DO j = bo(1, 2), bo(2, 2)
5632 DO i = bo(1, 1), bo(2, 1)
5633 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
5634 v_xc(2)%array(i, j, k) = v_xc(2)%array(i, j, k) + &
5635 (deriv_data(i, j, k)*dra1dra(i, j, k) - deriv_data2(i, j, k)*drb1drb(i, j, k))* &
5636 rho1a(i, j, k)/s
5637 END DO
5638 END DO
5639 END DO
5640!$OMP END PARALLEL DO
5641 END IF
5642 END IF
5643 !
5644 !
5645 ! Calculate the vector for the partial integration term of GGA functionals
5646 ! First contribution alpha
5647 ! | d^2 e_xc d^2 e_xc |
5648 ! v_drhoa(1) += -|---------------- - ----------------|*rho1a
5649 ! | d|drhoa| drhoa d|drhoa| drhob |
5650 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhob])
5651 IF (ASSOCIATED(deriv_att)) THEN
5652 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5653 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_rhoa])
5654 IF (ASSOCIATED(deriv_att)) THEN
5655 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5656!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5657!$OMP SHARED(bo,deriv_data,deriv_data2,rho1a,v_drhoa) COLLAPSE(3)
5658 DO k = bo(1, 3), bo(2, 3)
5659 DO j = bo(1, 2), bo(2, 2)
5660 DO i = bo(1, 1), bo(2, 1)
5661 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
5662 (deriv_data(i, j, k) - deriv_data2(i, j, k))*rho1a(i, j, k)
5663 END DO
5664 END DO
5665 END DO
5666!$OMP END PARALLEL DO
5667 END IF
5668 END IF
5669 ! First contribution beta
5670 ! | d^2 e_xc d^2 e_xc |
5671 ! v_drhob(2) += +|---------------- - ----------------|*rho1a
5672 ! | d|drhob| drhob d|drhob| drhoa |
5673 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_rhoa])
5674 IF (ASSOCIATED(deriv_att)) THEN
5675 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5676 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_rhob])
5677 IF (ASSOCIATED(deriv_att)) THEN
5678 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5679!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5680!$OMP SHARED(bo,deriv_data,deriv_data2,rho1a,v_drhob) COLLAPSE(3)
5681 DO k = bo(1, 3), bo(2, 3)
5682 DO j = bo(1, 2), bo(2, 2)
5683 DO i = bo(1, 1), bo(2, 1)
5684 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) + &
5685 (deriv_data(i, j, k) - deriv_data2(i, j, k))*rho1a(i, j, k)
5686 END DO
5687 END DO
5688 END DO
5689!$OMP END PARALLEL DO
5690 END IF
5691 END IF
5692 ! First contribution spinless
5693 ! | d^2 e_xc d^2 e_xc |
5694 ! v_drho(1) += -|--------------- - ---------------|*rho1a
5695 ! | d|drho| drhoa d|drho| drhob |
5696 !
5697 ! | d^2 e_xc d^2 e_xc |
5698 ! v_drho(2) += -|--------------- - ---------------|*rho1a
5699 ! | d|drho| drhoa d|drho| drhob |
5700 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rhoa])
5701 IF (ASSOCIATED(deriv_att)) THEN
5702 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5703 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_rhob])
5704 IF (ASSOCIATED(deriv_att)) THEN
5705 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5706!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5707!$OMP SHARED(bo,deriv_data,deriv_data2,rho1a,v_drho) COLLAPSE(3)
5708 DO k = bo(1, 3), bo(2, 3)
5709 DO j = bo(1, 2), bo(2, 2)
5710 DO i = bo(1, 1), bo(2, 1)
5711 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
5712 (deriv_data(i, j, k) - deriv_data2(i, j, k))*rho1a(i, j, k)
5713 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
5714 (deriv_data(i, j, k) - deriv_data2(i, j, k))*rho1a(i, j, k)
5715 END DO
5716 END DO
5717 END DO
5718!$OMP END PARALLEL DO
5719 END IF
5720 END IF
5721 ! Second contribution
5722 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhob])
5723 IF (ASSOCIATED(deriv_att)) THEN
5724 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5725 ! d^2 e_xc d^2 e_xc
5726 ! v_drhoa(1) += - -------------------*dra1dra + ------------------*drb1drb
5727 ! d|drhoa| d|drhoa| d|drhoa| d|drhob|
5728 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa, deriv_norm_drhoa])
5729 IF (ASSOCIATED(deriv_att)) THEN
5730 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5731!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5732!$OMP SHARED(bo,deriv_data,deriv_data2,dra1dra,drb1drb,v_drhoa) COLLAPSE(3)
5733 DO k = bo(1, 3), bo(2, 3)
5734 DO j = bo(1, 2), bo(2, 2)
5735 DO i = bo(1, 1), bo(2, 1)
5736 v_drhoa(1)%array(i, j, k) = v_drhoa(1)%array(i, j, k) - &
5737 deriv_data(i, j, k)*dra1dra(i, j, k) + deriv_data2(i, j, k)*drb1drb(i, j, k)
5738 END DO
5739 END DO
5740 END DO
5741!$OMP END PARALLEL DO
5742 END IF
5743 ! d^2 e_xc d^2 e_xc
5744 ! v_drhob(2) += - -------------------*dra1dra + -------------------*drb1drb
5745 ! d|drhoa| d|drhob| d|drhob| d|drhob|
5746 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob, deriv_norm_drhob])
5747 IF (ASSOCIATED(deriv_att)) THEN
5748 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5749!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5750!$OMP SHARED(bo,deriv_data,deriv_data2,dra1dra,drb1drb,v_drhob) COLLAPSE(3)
5751 DO k = bo(1, 3), bo(2, 3)
5752 DO j = bo(1, 2), bo(2, 2)
5753 DO i = bo(1, 1), bo(2, 1)
5754 v_drhob(2)%array(i, j, k) = v_drhob(2)%array(i, j, k) - &
5755 deriv_data(i, j, k)*dra1dra(i, j, k) + deriv_data2(i, j, k)*drb1drb(i, j, k)
5756 END DO
5757 END DO
5758 END DO
5759!$OMP END PARALLEL DO
5760 END IF
5761 END IF
5762 ! d^2 e_xc d^2 e_xc
5763 ! v_drho(1) += - ------------------*dra1dra + ------------------*drb1drb
5764 ! d|drho| d|drhoa| d|drho| d|drhob|
5765 !
5766 ! d^2 e_xc d^2 e_xc
5767 ! v_drho(2) += - ------------------*dra1dra + ------------------*drb1drb
5768 ! d|drho| d|drhoa| d|drho| d|drhob|
5769 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhob])
5770 IF (ASSOCIATED(deriv_att)) THEN
5771 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data2)
5772 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drho, deriv_norm_drhoa])
5773 IF (ASSOCIATED(deriv_att)) THEN
5774 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5775!$OMP PARALLEL DO PRIVATE(k,j,i) DEFAULT(NONE)&
5776!$OMP SHARED(bo,deriv_data,deriv_data2,dra1dra,drb1drb,v_drho) COLLAPSE(3)
5777 DO k = bo(1, 3), bo(2, 3)
5778 DO j = bo(1, 2), bo(2, 2)
5779 DO i = bo(1, 1), bo(2, 1)
5780 v_drho(1)%array(i, j, k) = v_drho(1)%array(i, j, k) - &
5781 deriv_data(i, j, k)*dra1dra(i, j, k) + &
5782 deriv_data2(i, j, k)*drb1drb(i, j, k)
5783 v_drho(2)%array(i, j, k) = v_drho(2)%array(i, j, k) - &
5784 deriv_data(i, j, k)*dra1dra(i, j, k) + &
5785 deriv_data2(i, j, k)*drb1drb(i, j, k)
5786 END DO
5787 END DO
5788 END DO
5789!$OMP END PARALLEL DO
5790 END IF
5791 END IF
5792 !
5793
5794 ! Last GGA contribution
5795 ! Alpha contribution
5796 ! d e_xc
5797 ! v_drhoa(1) += + ----------*dra1dra
5798 ! d|drhoa|
5799 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhoa])
5800 IF (ASSOCIATED(deriv_att)) THEN
5801 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5802 CALL xc_derivative_get(deriv_att, deriv_data=e_drhoa)
5803
5804!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dra1dra,gradient_cut,norm_drhoa,v_drhoa,deriv_data)
5805 v_drhoa(1)%array(:, :, :) = v_drhoa(1)%array(:, :, :) + &
5806 deriv_data(:, :, :)*dra1dra(:, :, :)/max(gradient_cut, norm_drhoa(:, :, :))**2
5807!$OMP END PARALLEL WORKSHARE
5808 END IF
5809 ! Beta contribution
5810 ! d e_xc
5811 ! v_drhob(2) += - ----------*drb1drb
5812 ! d|drhob|
5813 deriv_att => xc_dset_get_derivative(deriv_set, [deriv_norm_drhob])
5814 IF (ASSOCIATED(deriv_att)) THEN
5815 CALL xc_derivative_get(deriv_att, deriv_data=deriv_data)
5816 CALL xc_derivative_get(deriv_att, deriv_data=e_drhob)
5817
5818!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drb1drb,gradient_cut,norm_drhob,v_drhob,deriv_data)
5819 v_drhob(2)%array(:, :, :) = v_drhob(2)%array(:, :, :) - &
5820 deriv_data(:, :, :)*drb1drb(:, :, :)/max(gradient_cut, norm_drhob(:, :, :))**2
5821!$OMP END PARALLEL WORKSHARE
5822 END IF
5823 END IF ! If ALDA0
5824 END IF
5825
5826 ELSE
5827
5828 ! Analytic third derivative for closed-shell
5829 cpabort("Exchange-correlation's analytic third derivative not implemented")
5830
5831 END IF
5832
5833 IF (gradient_f) THEN
5834 IF (.NOT. alda0) THEN
5835
5836 ! partial integration
5837 DO idir = 1, 3
5838
5839 ! GGA contributions to the spin-flip xc-Kernel
5840 !
5841 ! v_drhoa(1)*drhoa(:)*rhoa1 v_drhob(1)*drhob(:)*rhoa1 v_drho(1)*drho(:)*rhoa1
5842 ! v_drho_r(:,1) = --------------------------- + --------------------------- + -------------------------
5843 ! |rhoa - rhob| |rhoa - rhob| |rhoa - rhob|
5844 !
5845 ! v_drhoa(2)*drhoa(:)*rhoa1 v_drhob(2)*drhob(:)*rhoa1 v_drho(2)*drho(:)*rhoa1
5846 ! v_drho_r(:,2) = --------------------------- + --------------------------- + -------------------------
5847 ! |rhoa - rhob| |rhoa - rhob| |rhoa - rhob|
5848 IF (do_spinflip) THEN
5849!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5850!$OMP SHARED(bo,v_drho_r,v_drho,v_drhoa,v_drhob,rhoa,rhob,drho,drhoa,drhob,rho1a,idir,S_THRESH) COLLAPSE(3)
5851 DO k = bo(1, 3), bo(2, 3)
5852 DO j = bo(1, 2), bo(2, 2)
5853 DO i = bo(1, 1), bo(2, 1)
5854 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
5855 DO ispin = 1, 2
5856 v_drho_r(idir, ispin)%array(i, j, k) = v_drho_r(idir, ispin)%array(i, j, k) + &
5857 v_drhoa(ispin)%array(i, j, k)*drhoa(idir)%array(i, j, k)*rho1a(i, j, k)/s + &
5858 v_drhob(ispin)%array(i, j, k)*drhob(idir)%array(i, j, k)*rho1a(i, j, k)/s + &
5859 v_drho(ispin)%array(i, j, k)*drho(idir)%array(i, j, k)*rho1a(i, j, k)/s
5860 END DO
5861 END DO
5862 END DO
5863 END DO
5864!$OMP END PARALLEL DO
5865 END IF
5866 ! Last GGA contribution
5867 ! Alpha contribution
5868 ! rho1a d e_xc
5869 ! v_drho_r(:,1) += - -------------*----------*drho1a(:)
5870 ! |rhoa - rhob| d|drhoa|
5871 IF (ASSOCIATED(e_drhoa)) THEN
5872!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5873!$OMP SHARED(bo,e_drhoa,v_drho_r,drho1a,rho1a,rhoa,rhob,S_THRESH,idir) COLLAPSE(3)
5874 DO k = bo(1, 3), bo(2, 3)
5875 DO j = bo(1, 2), bo(2, 2)
5876 DO i = bo(1, 1), bo(2, 1)
5877 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
5878 v_drho_r(idir, 1)%array(i, j, k) = v_drho_r(idir, 1)%array(i, j, k) - &
5879 e_drhoa(i, j, k)*drho1a(idir)%array(i, j, k)*rho1a(i, j, k)/s
5880 END DO
5881 END DO
5882 END DO
5883!$OMP END PARALLEL DO
5884 END IF
5885 ! Beta contribution
5886 ! rho1a d e_xc
5887 ! v_drho_r(:,2) += + -------------*----------*drho1a(:)
5888 ! |rhoa - rhob| d|drhob|
5889 IF (ASSOCIATED(e_drhob)) THEN
5890!$OMP PARALLEL DO PRIVATE(k,j,i,s) DEFAULT(NONE)&
5891!$OMP SHARED(bo,e_drhob,v_drho_r,drho1a,rho1a,rhoa,rhob,S_THRESH,idir) COLLAPSE(3)
5892 DO k = bo(1, 3), bo(2, 3)
5893 DO j = bo(1, 2), bo(2, 2)
5894 DO i = bo(1, 1), bo(2, 1)
5895 s = max(abs(rhoa(i, j, k) - rhob(i, j, k)), s_thresh)
5896 v_drho_r(idir, 2)%array(i, j, k) = v_drho_r(idir, 2)%array(i, j, k) + &
5897 e_drhob(i, j, k)*drho1a(idir)%array(i, j, k)*rho1a(i, j, k)/s
5898 END DO
5899 END DO
5900 END DO
5901!$OMP END PARALLEL DO
5902 END IF
5903 END DO
5904
5905 ! partial integration: v_xc = v_xc - \nabla \cdot vdrho_r
5906 DO ispin = 1, nspins
5907 CALL xc_pw_divergence(xc_deriv_method_id, v_drho_r(:, ispin), tmp_g, vxc_g, v_xc(ispin))
5908 END DO ! ispin
5909 END IF ! ALDA0
5910
5911 DO idir = 1, 3
5912 DEALLOCATE (drho(idir)%array)
5913 DEALLOCATE (drho1(idir)%array)
5914 END DO
5915
5916 DO ispin = 1, nspins
5917 CALL deallocate_pw(v_drhoa(ispin), pw_pool)
5918 CALL deallocate_pw(v_drhob(ispin), pw_pool)
5919 END DO
5920
5921 DEALLOCATE (v_drhoa, v_drhob)
5922
5923 END IF ! gradient_f
5924
5925 ELSE
5926
5927 !-----------------!
5928 ! restricted case !
5929 !-----------------!
5930 cpabort("Exchange-correlation's analytic third derivative not implemented")
5931
5932 END IF
5933
5934 IF (gradient_f) THEN
5935
5936 DO ispin = 1, nspins
5937 CALL deallocate_pw(v_drho(ispin), pw_pool)
5938 DO idir = 1, 3
5939 CALL deallocate_pw(v_drho_r(idir, ispin), pw_pool)
5940 END DO
5941 END DO
5942 DEALLOCATE (v_drho, v_drho_r)
5943
5944 END IF
5945
5946 IF (ASSOCIATED(tmp_g%pw_grid) .AND. ASSOCIATED(pw_pool)) THEN
5947 CALL pw_pool%give_back_pw(tmp_g)
5948 END IF
5949
5950 IF (ASSOCIATED(vxc_g%pw_grid) .AND. ASSOCIATED(pw_pool)) THEN
5951 CALL pw_pool%give_back_pw(vxc_g)
5952 END IF
5953
5954 CALL timestop(handle)
5955 END SUBROUTINE xc_calc_3rd_deriv_analytical
5956
5957! **************************************************************************************************
5958!> \brief allocates grids using pw_pool (if associated) or with bounds
5959!> \param pw ...
5960!> \param pw_pool ...
5961!> \param bo ...
5962! **************************************************************************************************
5963 SUBROUTINE allocate_pw(pw, pw_pool, bo)
5964 TYPE(pw_r3d_rs_type), INTENT(OUT) :: pw
5965 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
5966 INTEGER, DIMENSION(2, 3), INTENT(IN) :: bo
5967
5968 IF (ASSOCIATED(pw_pool)) THEN
5969 CALL pw_pool%create_pw(pw)
5970 CALL pw_zero(pw)
5971 ELSE
5972 ALLOCATE (pw%array(bo(1, 1):bo(2, 1), bo(1, 2):bo(2, 2), bo(1, 3):bo(2, 3)))
5973 pw%array = 0.0_dp
5974 END IF
5975
5976 END SUBROUTINE allocate_pw
5977
5978! **************************************************************************************************
5979!> \brief deallocates grid allocated with allocate_pw
5980!> \param pw ...
5981!> \param pw_pool ...
5982! **************************************************************************************************
5983 SUBROUTINE deallocate_pw(pw, pw_pool)
5984 TYPE(pw_r3d_rs_type), INTENT(INOUT) :: pw
5985 TYPE(pw_pool_type), INTENT(IN), POINTER :: pw_pool
5986
5987 IF (ASSOCIATED(pw_pool)) THEN
5988 CALL pw_pool%give_back_pw(pw)
5989 ELSE
5990 CALL pw%release()
5991 END IF
5992
5993 END SUBROUTINE deallocate_pw
5994
5995! **************************************************************************************************
5996!> \brief updates virial from first derivative w.r.t. norm_drho
5997!> \param virial_pw ...
5998!> \param drho ...
5999!> \param drho1 ...
6000!> \param deriv_data ...
6001!> \param virial_xc ...
6002! **************************************************************************************************
6003 SUBROUTINE virial_drho_drho1(virial_pw, drho, drho1, deriv_data, virial_xc)
6004 TYPE(pw_r3d_rs_type), INTENT(IN) :: virial_pw
6005 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drho, drho1
6006 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: deriv_data
6007 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT) :: virial_xc
6008
6009 INTEGER :: idir, jdir
6010 REAL(kind=dp) :: tmp
6011
6012 DO idir = 1, 3
6013!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,idir,virial_pw,deriv_data)
6014 virial_pw%array(:, :, :) = drho(idir)%array(:, :, :)*deriv_data(:, :, :)
6015!$OMP END PARALLEL WORKSHARE
6016 DO jdir = 1, 3
6017 tmp = virial_pw%pw_grid%dvol*accurate_dot_product(virial_pw%array(:, :, :), &
6018 drho1(jdir)%array(:, :, :))
6019 virial_xc(jdir, idir) = virial_xc(jdir, idir) + tmp
6020 virial_xc(idir, jdir) = virial_xc(idir, jdir) + tmp
6021 END DO
6022 END DO
6023
6024 END SUBROUTINE virial_drho_drho1
6025
6026! **************************************************************************************************
6027!> \brief Adds virial contribution from second order potential parts
6028!> \param virial_pw ...
6029!> \param drho ...
6030!> \param v_drho ...
6031!> \param virial_xc ...
6032! **************************************************************************************************
6033 SUBROUTINE virial_drho_drho(virial_pw, drho, v_drho, virial_xc)
6034 TYPE(pw_r3d_rs_type), INTENT(IN) :: virial_pw
6035 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drho
6036 TYPE(pw_r3d_rs_type), INTENT(IN) :: v_drho
6037 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT) :: virial_xc
6038
6039 INTEGER :: idir, jdir
6040 REAL(kind=dp) :: tmp
6041
6042 DO idir = 1, 3
6043!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,idir,v_drho,virial_pw)
6044 virial_pw%array(:, :, :) = drho(idir)%array(:, :, :)*v_drho%array(:, :, :)
6045!$OMP END PARALLEL WORKSHARE
6046 DO jdir = 1, idir
6047 tmp = -virial_pw%pw_grid%dvol*accurate_dot_product(virial_pw%array(:, :, :), &
6048 drho(jdir)%array(:, :, :))
6049 virial_xc(jdir, idir) = virial_xc(jdir, idir) + tmp
6050 virial_xc(idir, jdir) = virial_xc(jdir, idir)
6051 END DO
6052 END DO
6053
6054 END SUBROUTINE virial_drho_drho
6055
6056! **************************************************************************************************
6057!> \brief ...
6058!> \param rho_r ...
6059!> \param pw_pool ...
6060!> \param virial_xc ...
6061!> \param deriv_data ...
6062! **************************************************************************************************
6063 SUBROUTINE virial_laplace(rho_r, pw_pool, virial_xc, deriv_data)
6064 TYPE(pw_r3d_rs_type), TARGET :: rho_r
6065 TYPE(pw_pool_type), POINTER, INTENT(IN) :: pw_pool
6066 REAL(kind=dp), DIMENSION(3, 3), INTENT(INOUT) :: virial_xc
6067 REAL(kind=dp), DIMENSION(:, :, :), INTENT(IN) :: deriv_data
6068
6069 CHARACTER(len=*), PARAMETER :: routinen = 'virial_laplace'
6070
6071 INTEGER :: handle, idir, jdir
6072 TYPE(pw_r3d_rs_type), POINTER :: virial_pw
6073 TYPE(pw_c1d_gs_type), POINTER :: tmp_g, rho_g
6074 INTEGER, DIMENSION(3) :: my_deriv
6075
6076 CALL timeset(routinen, handle)
6077
6078 NULLIFY (virial_pw, tmp_g, rho_g)
6079 ALLOCATE (virial_pw, tmp_g, rho_g)
6080 CALL pw_pool%create_pw(virial_pw)
6081 CALL pw_pool%create_pw(tmp_g)
6082 CALL pw_pool%create_pw(rho_g)
6083 CALL pw_zero(virial_pw)
6084 CALL pw_transfer(rho_r, rho_g)
6085 DO idir = 1, 3
6086 DO jdir = idir, 3
6087 CALL pw_copy(rho_g, tmp_g)
6088
6089 my_deriv = 0
6090 my_deriv(idir) = 1
6091 my_deriv(jdir) = my_deriv(jdir) + 1
6092
6093 CALL pw_derive(tmp_g, my_deriv)
6094 CALL pw_transfer(tmp_g, virial_pw)
6095 virial_xc(idir, jdir) = virial_xc(idir, jdir) - 2.0_dp*virial_pw%pw_grid%dvol* &
6096 accurate_dot_product(virial_pw%array(:, :, :), &
6097 deriv_data(:, :, :))
6098 virial_xc(jdir, idir) = virial_xc(idir, jdir)
6099 END DO
6100 END DO
6101 CALL pw_pool%give_back_pw(virial_pw)
6102 CALL pw_pool%give_back_pw(tmp_g)
6103 CALL pw_pool%give_back_pw(rho_g)
6104 DEALLOCATE (virial_pw, tmp_g, rho_g)
6105
6106 CALL timestop(handle)
6107
6108 END SUBROUTINE virial_laplace
6109
6110! **************************************************************************************************
6111!> \brief Prepare objects for the calculation of the 2nd derivatives of the density functional.
6112!> The calculation must then be performed with xc_calc_2nd_deriv.
6113!> \param deriv_set object containing the XC derivatives (out)
6114!> \param rho_set object that will contain the density at which the
6115!> derivatives were calculated
6116!> \param rho_r the place where you evaluate the derivative
6117!> \param pw_pool the pool for the grids
6118!> \param xc_section which functional should be used and how to calculate it
6119!> \param tau_r kinetic energy density in real space
6120! **************************************************************************************************
6121 SUBROUTINE xc_prep_2nd_deriv(deriv_set, &
6122 rho_set, rho_r, pw_pool, xc_section, tau_r)
6123
6124 TYPE(xc_derivative_set_type) :: deriv_set
6125 TYPE(xc_rho_set_type) :: rho_set
6126 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r
6127 TYPE(pw_pool_type), POINTER :: pw_pool
6128 TYPE(section_vals_type), POINTER :: xc_section
6129 TYPE(pw_r3d_rs_type), DIMENSION(:), OPTIONAL, POINTER :: tau_r
6130
6131 CHARACTER(len=*), PARAMETER :: routinen = 'xc_prep_2nd_deriv'
6132
6133 INTEGER :: handle, nspins
6134 LOGICAL :: lsd
6135 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
6136 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: tau
6137
6138 CALL timeset(routinen, handle)
6139
6140 cpassert(ASSOCIATED(xc_section))
6141 cpassert(ASSOCIATED(pw_pool))
6142
6143 nspins = SIZE(rho_r)
6144 lsd = (nspins /= 1)
6145
6146 NULLIFY (rho_g, tau)
6147 IF (PRESENT(tau_r)) &
6148 tau => tau_r
6149
6150 IF (section_get_lval(xc_section, "2ND_DERIV_ANALYTICAL")) THEN
6151 CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 2, &
6152 rho_r, rho_g, tau, xc_section, pw_pool, &
6153 calc_potential=.true.)
6154 ELSE
6155 CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 1, &
6156 rho_r, rho_g, tau, xc_section, pw_pool, &
6157 calc_potential=.true.)
6158 END IF
6159
6160 CALL timestop(handle)
6161
6162 END SUBROUTINE xc_prep_2nd_deriv
6163
6164! **************************************************************************************************
6165!> \brief Prepare deriv_set for the calculation of the 3rd derivatives of the density functional.
6166!> The calculation must then be performed with xc_calc_3rd_deriv.
6167!> \param deriv_set object containing the XC derivatives (out)
6168!> \param rho_set object that will contain the density at which the
6169!> derivatives were calculated
6170!> \param rho_r the place where you evaluate the derivative
6171!> \param pw_pool the pool for the grids
6172!> \param xc_section which functional should be used and how to calculate it
6173!> \param tau_r kinetic energy density in real space
6174!> \param do_sf Flag to activate the noncollinear kernel for spin flip calculations
6175!> \par History
6176!> * 07.2024 Created [LHS]
6177! **************************************************************************************************
6178 SUBROUTINE xc_prep_3rd_deriv(deriv_set, rho_set, rho_r, pw_pool, xc_section, tau_r, do_sf)
6179
6180 TYPE(xc_derivative_set_type) :: deriv_set
6181 TYPE(xc_rho_set_type) :: rho_set
6182 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: rho_r
6183 TYPE(pw_pool_type), POINTER :: pw_pool
6184 TYPE(section_vals_type), POINTER :: xc_section
6185 TYPE(pw_r3d_rs_type), DIMENSION(:), OPTIONAL, POINTER :: tau_r
6186 LOGICAL, OPTIONAL :: do_sf
6187
6188 CHARACTER(len=*), PARAMETER :: routinen = 'xc_prep_3rd_deriv'
6189
6190 INTEGER :: handle, nspins
6191 LOGICAL :: lsd, my_do_sf
6192 TYPE(pw_c1d_gs_type), DIMENSION(:), POINTER :: rho_g
6193 TYPE(pw_r3d_rs_type), DIMENSION(:), POINTER :: tau
6194
6195 CALL timeset(routinen, handle)
6196
6197 cpassert(ASSOCIATED(xc_section))
6198 cpassert(ASSOCIATED(pw_pool))
6199
6200 nspins = SIZE(rho_r)
6201 lsd = (nspins /= 1)
6202
6203 NULLIFY (rho_g, tau)
6204 IF (PRESENT(tau_r)) &
6205 tau => tau_r
6206
6207 my_do_sf = .false.
6208 IF (PRESENT(do_sf)) my_do_sf = do_sf
6209
6210 IF (do_sf) THEN
6211 CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 2, &
6212 rho_r, rho_g, tau, xc_section, pw_pool, &
6213 calc_potential=.true.)
6214 ELSE
6215 CALL xc_rho_set_and_dset_create(rho_set, deriv_set, 3, &
6216 rho_r, rho_g, tau, xc_section, pw_pool, &
6217 calc_potential=.true.)
6218 END IF
6219
6220 CALL timestop(handle)
6221
6222 END SUBROUTINE xc_prep_3rd_deriv
6223
6224! **************************************************************************************************
6225!> \brief divides derivatives from deriv_set by norm_drho
6226!> \param deriv_set ...
6227!> \param rho_set ...
6228!> \param lsd ...
6229! **************************************************************************************************
6230 SUBROUTINE divide_by_norm_drho(deriv_set, rho_set, lsd)
6231
6232 TYPE(xc_derivative_set_type), INTENT(INOUT) :: deriv_set
6233 TYPE(xc_rho_set_type), INTENT(IN) :: rho_set
6234 LOGICAL, INTENT(IN) :: lsd
6235
6236 INTEGER, DIMENSION(:), POINTER :: split_desc
6237 INTEGER :: idesc
6238 INTEGER, DIMENSION(2, 3) :: bo
6239 REAL(kind=dp) :: drho_cutoff
6240 REAL(kind=dp), DIMENSION(:, :, :), POINTER :: norm_drho, norm_drhoa, norm_drhob
6241 TYPE(cp_3d_r_cp_type), DIMENSION(3) :: drho, drhoa, drhob
6242 TYPE(cp_sll_xc_deriv_type), POINTER :: pos
6243 TYPE(xc_derivative_type), POINTER :: deriv_att
6244
6245! check for unknown derivatives and divide by norm_drho where necessary
6246
6247 bo = rho_set%local_bounds
6248 CALL xc_rho_set_get(rho_set, drho_cutoff=drho_cutoff, norm_drho=norm_drho, &
6249 norm_drhoa=norm_drhoa, norm_drhob=norm_drhob, &
6250 drho=drho, drhoa=drhoa, drhob=drhob, can_return_null=.true.)
6251
6252 pos => deriv_set%derivs
6253 DO WHILE (cp_sll_xc_deriv_next(pos, el_att=deriv_att))
6254 CALL xc_derivative_get(deriv_att, split_desc=split_desc)
6255 DO idesc = 1, SIZE(split_desc)
6256 SELECT CASE (split_desc(idesc))
6257 CASE (deriv_norm_drho)
6258 IF (ASSOCIATED(norm_drho)) THEN
6259!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,norm_drho,drho_cutoff)
6260 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
6261 max(norm_drho(:, :, :), drho_cutoff)
6262!$OMP END PARALLEL WORKSHARE
6263 ELSE IF (ASSOCIATED(drho(1)%array)) THEN
6264!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,drho,drho_cutoff)
6265 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
6266 max(sqrt(drho(1)%array(:, :, :)**2 + &
6267 drho(2)%array(:, :, :)**2 + &
6268 drho(3)%array(:, :, :)**2), drho_cutoff)
6269!$OMP END PARALLEL WORKSHARE
6270 ELSE IF (ASSOCIATED(drhoa(1)%array) .AND. ASSOCIATED(drhob(1)%array)) THEN
6271!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,drhoa,drhob,drho_cutoff)
6272 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
6273 max(sqrt((drhoa(1)%array(:, :, :) + drhob(1)%array(:, :, :))**2 + &
6274 (drhoa(2)%array(:, :, :) + drhob(2)%array(:, :, :))**2 + &
6275 (drhoa(3)%array(:, :, :) + drhob(3)%array(:, :, :))**2), drho_cutoff)
6276!$OMP END PARALLEL WORKSHARE
6277 ELSE
6278 cpabort("Normalization of derivative requires any of norm_drho, drho or drhoa+drhob!")
6279 END IF
6280 CASE (deriv_norm_drhoa)
6281 IF (ASSOCIATED(norm_drhoa)) THEN
6282!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,norm_drhoa,drho_cutoff)
6283 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
6284 max(norm_drhoa(:, :, :), drho_cutoff)
6285!$OMP END PARALLEL WORKSHARE
6286 ELSE IF (ASSOCIATED(drhoa(1)%array)) THEN
6287!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,drhoa,drho_cutoff)
6288 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
6289 max(sqrt(drhoa(1)%array(:, :, :)**2 + &
6290 drhoa(2)%array(:, :, :)**2 + &
6291 drhoa(3)%array(:, :, :)**2), drho_cutoff)
6292!$OMP END PARALLEL WORKSHARE
6293 ELSE
6294 cpabort("Normalization of derivative requires any of norm_drhoa or drhoa!")
6295 END IF
6296 CASE (deriv_norm_drhob)
6297 IF (ASSOCIATED(norm_drhob)) THEN
6298!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,norm_drhob,drho_cutoff)
6299 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
6300 max(norm_drhob(:, :, :), drho_cutoff)
6301!$OMP END PARALLEL WORKSHARE
6302 ELSE IF (ASSOCIATED(drhob(1)%array)) THEN
6303!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(deriv_att,drhob,drho_cutoff)
6304 deriv_att%deriv_data(:, :, :) = deriv_att%deriv_data(:, :, :)/ &
6305 max(sqrt(drhob(1)%array(:, :, :)**2 + &
6306 drhob(2)%array(:, :, :)**2 + &
6307 drhob(3)%array(:, :, :)**2), drho_cutoff)
6308!$OMP END PARALLEL WORKSHARE
6309 ELSE
6310 cpabort("Normalization of derivative requires any of norm_drhob or drhob!")
6311 END IF
6313 IF (lsd) &
6314 cpabort(trim(id_to_desc(split_desc(idesc)))//" not handled in lsd!'")
6316 CASE default
6317 cpabort("Unknown derivative id")
6318 END SELECT
6319 END DO
6320 END DO
6321
6322 END SUBROUTINE divide_by_norm_drho
6323
6324! **************************************************************************************************
6325!> \brief allocates and calculates drho from given spin densities drhoa, drhob
6326!> \param drho ...
6327!> \param drhoa ...
6328!> \param drhob ...
6329! **************************************************************************************************
6330 SUBROUTINE calc_drho_from_ab(drho, drhoa, drhob)
6331 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(OUT) :: drho
6332 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drhoa, drhob
6333
6334 CHARACTER(len=*), PARAMETER :: routinen = 'calc_drho_from_ab'
6335
6336 INTEGER :: handle, idir
6337
6338 CALL timeset(routinen, handle)
6339
6340 DO idir = 1, 3
6341 NULLIFY (drho(idir)%array)
6342 ALLOCATE (drho(idir)%array(lbound(drhoa(1)%array, 1):ubound(drhoa(1)%array, 1), &
6343 lbound(drhoa(1)%array, 2):ubound(drhoa(1)%array, 2), &
6344 lbound(drhoa(1)%array, 3):ubound(drhoa(1)%array, 3)))
6345!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,drhoa,drhob,idir)
6346 drho(idir)%array(:, :, :) = drhoa(idir)%array(:, :, :) + drhob(idir)%array(:, :, :)
6347!$OMP END PARALLEL WORKSHARE
6348 END DO
6349
6350 CALL timestop(handle)
6351
6352 END SUBROUTINE
6353
6354! **************************************************************************************************
6355!> \brief allocates and calculates drho from given spin densities drhoa, drhob
6356!> \param drho ...
6357!> \param drhoa ...
6358!> \param drhob ...
6359! **************************************************************************************************
6360 SUBROUTINE calc_drho_from_a(drho, drhoa)
6361 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(OUT) :: drho
6362 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drhoa
6363
6364 CHARACTER(len=*), PARAMETER :: routinen = 'calc_drho_from_a'
6365
6366 INTEGER :: handle, idir
6367
6368 CALL timeset(routinen, handle)
6369
6370 DO idir = 1, 3
6371 NULLIFY (drho(idir)%array)
6372 ALLOCATE (drho(idir)%array(lbound(drhoa(1)%array, 1):ubound(drhoa(1)%array, 1), &
6373 lbound(drhoa(1)%array, 2):ubound(drhoa(1)%array, 2), &
6374 lbound(drhoa(1)%array, 3):ubound(drhoa(1)%array, 3)))
6375!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(drho,drhoa,idir)
6376 drho(idir)%array(:, :, :) = drhoa(idir)%array(:, :, :)
6377!$OMP END PARALLEL WORKSHARE
6378 END DO
6379
6380 CALL timestop(handle)
6381
6382 END SUBROUTINE
6383
6384! **************************************************************************************************
6385!> \brief allocates and calculates dot products of two density gradients
6386!> \param dr1dr ...
6387!> \param drho ...
6388!> \param drho1 ...
6389! **************************************************************************************************
6390 SUBROUTINE prepare_dr1dr(dr1dr, drho, drho1)
6391 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :), &
6392 INTENT(OUT) :: dr1dr
6393 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drho, drho1
6394
6395 CHARACTER(len=*), PARAMETER :: routinen = 'prepare_dr1dr'
6396
6397 INTEGER :: handle, idir
6398
6399 CALL timeset(routinen, handle)
6400
6401 ALLOCATE (dr1dr(lbound(drho(1)%array, 1):ubound(drho(1)%array, 1), &
6402 lbound(drho(1)%array, 2):ubound(drho(1)%array, 2), &
6403 lbound(drho(1)%array, 3):ubound(drho(1)%array, 3)))
6404
6405!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,drho,drho1)
6406 dr1dr(:, :, :) = drho(1)%array(:, :, :)*drho1(1)%array(:, :, :)
6407!$OMP END PARALLEL WORKSHARE
6408 DO idir = 2, 3
6409!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(dr1dr,drho,drho1,idir)
6410 dr1dr(:, :, :) = dr1dr(:, :, :) + drho(idir)%array(:, :, :)*drho1(idir)%array(:, :, :)
6411!$OMP END PARALLEL WORKSHARE
6412 END DO
6413
6414 CALL timestop(handle)
6415
6416 END SUBROUTINE prepare_dr1dr
6417
6418! **************************************************************************************************
6419!> \brief allocates and calculates dot product of two densities for triplets
6420!> \param dr1dr ...
6421!> \param drhoa ...
6422!> \param drhob ...
6423!> \param drho1a ...
6424!> \param drho1b ...
6425!> \param fac ...
6426! **************************************************************************************************
6427 SUBROUTINE prepare_dr1dr_ab(dr1dr, drhoa, drhob, drho1a, drho1b, fac)
6428 REAL(kind=dp), ALLOCATABLE, DIMENSION(:, :, :), &
6429 INTENT(OUT) :: dr1dr
6430 TYPE(cp_3d_r_cp_type), DIMENSION(3), INTENT(IN) :: drhoa, drhob, drho1a, drho1b
6431 REAL(kind=dp), INTENT(IN) :: fac
6432
6433 CHARACTER(len=*), PARAMETER :: routinen = 'prepare_dr1dr_ab'
6434
6435 INTEGER :: handle, idir
6436
6437 CALL timeset(routinen, handle)
6438
6439 ALLOCATE (dr1dr(lbound(drhoa(1)%array, 1):ubound(drhoa(1)%array, 1), &
6440 lbound(drhoa(1)%array, 2):ubound(drhoa(1)%array, 2), &
6441 lbound(drhoa(1)%array, 3):ubound(drhoa(1)%array, 3)))
6442
6443!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(fac,dr1dr,drho1a,drho1b,drhoa,drhob)
6444 dr1dr(:, :, :) = drhoa(1)%array(:, :, :)*(drho1a(1)%array(:, :, :) + &
6445 fac*drho1b(1)%array(:, :, :)) + &
6446 drhob(1)%array(:, :, :)*(fac*drho1a(1)%array(:, :, :) + &
6447 drho1b(1)%array(:, :, :))
6448!$OMP END PARALLEL WORKSHARE
6449 DO idir = 2, 3
6450!$OMP PARALLEL WORKSHARE DEFAULT(NONE) SHARED(fac,dr1dr,drho1a,drho1b,drhoa,drhob,idir)
6451 dr1dr(:, :, :) = dr1dr(:, :, :) + &
6452 drhoa(idir)%array(:, :, :)*(drho1a(idir)%array(:, :, :) + &
6453 fac*drho1b(idir)%array(:, :, :)) + &
6454 drhob(idir)%array(:, :, :)*(fac*drho1a(idir)%array(:, :, :) + &
6455 drho1b(idir)%array(:, :, :))
6456!$OMP END PARALLEL WORKSHARE
6457 END DO
6458
6459 CALL timestop(handle)
6460
6461 END SUBROUTINE prepare_dr1dr_ab
6462
6463! **************************************************************************************************
6464!> \brief checks for gradients
6465!> \param deriv_set ...
6466!> \param lsd ...
6467!> \param gradient_f ...
6468!> \param tau_f ...
6469!> \param laplace_f ...
6470! **************************************************************************************************
6471 SUBROUTINE check_for_derivatives(deriv_set, lsd, rho_f, gradient_f, tau_f, laplace_f)
6472 TYPE(xc_derivative_set_type), INTENT(IN) :: deriv_set
6473 LOGICAL, INTENT(IN) :: lsd
6474 LOGICAL, INTENT(OUT) :: rho_f, gradient_f, tau_f, laplace_f
6475
6476 CHARACTER(len=*), PARAMETER :: routinen = 'check_for_derivatives'
6477
6478 INTEGER :: handle, iorder, order
6479 INTEGER, DIMENSION(:), POINTER :: split_desc
6480 TYPE(cp_sll_xc_deriv_type), POINTER :: pos
6481 TYPE(xc_derivative_type), POINTER :: deriv_att
6482
6483 CALL timeset(routinen, handle)
6484
6485 rho_f = .false.
6486 gradient_f = .false.
6487 tau_f = .false.
6488 laplace_f = .false.
6489 ! check for unknown derivatives
6490 pos => deriv_set%derivs
6491 DO WHILE (cp_sll_xc_deriv_next(pos, el_att=deriv_att))
6492 CALL xc_derivative_get(deriv_att, order=order, &
6493 split_desc=split_desc)
6494 IF (lsd) THEN
6495 DO iorder = 1, size(split_desc)
6496 SELECT CASE (split_desc(iorder))
6497 CASE (deriv_rhoa, deriv_rhob)
6498 rho_f = .true.
6500 gradient_f = .true.
6501 CASE (deriv_tau_a, deriv_tau_b)
6502 tau_f = .true.
6504 laplace_f = .true.
6506 cpabort("Derivative not handled in lsd!")
6507 CASE default
6508 cpabort("Unknown derivative id")
6509 END SELECT
6510 END DO
6511 ELSE
6512 DO iorder = 1, size(split_desc)
6513 SELECT CASE (split_desc(iorder))
6514 CASE (deriv_rho)
6515 rho_f = .true.
6516 CASE (deriv_tau)
6517 tau_f = .true.
6518 CASE (deriv_norm_drho)
6519 gradient_f = .true.
6520 CASE (deriv_laplace_rho)
6521 laplace_f = .true.
6522 CASE default
6523 cpabort("Unknown derivative id")
6524 END SELECT
6525 END DO
6526 END IF
6527 END DO
6528
6529 CALL timestop(handle)
6530
6531 END SUBROUTINE check_for_derivatives
6532
6533END MODULE xc
6534
static GRID_HOST_DEVICE double fac(const int i)
Factorial function, e.g. fac(5) = 5! = 120.
Definition grid_common.h:51
various utilities that regard array of different kinds: output, allocation,... maybe it is not a good...
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...
various routines to log and control the output. The idea is that decisions about where to log should ...
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
type(cp_logger_type) function, pointer, public cp_get_default_logger()
returns the default logger
objects that represent the structure of input sections and the data contained in an input section
real(kind=dp) function, public section_get_rval(section_vals, keyword_name)
...
integer function, public section_get_ival(section_vals, keyword_name)
...
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
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
logical function, public section_get_lval(section_vals, keyword_name)
...
sums arrays of real/complex numbers with much reduced round-off as compared to a naive implementation...
Definition kahan_sum.F:29
Defines the basic variable types.
Definition kinds.F:23
integer, parameter, public dp
Definition kinds.F:34
integer, parameter, public default_path_length
Definition kinds.F:58
integer, parameter, public pw_mode_distributed
subroutine, public pw_derive(pw, n)
Calculate the derivative of a plane wave vector.
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
Module with functions to handle derivative descriptors. derivative description are strings have the f...
integer, parameter, public deriv_norm_drho
integer, parameter, public deriv_laplace_rhob
integer, parameter, public deriv_norm_drhoa
integer, parameter, public deriv_rhob
integer, parameter, public deriv_rhoa
integer, parameter, public deriv_tau
integer, parameter, public deriv_tau_b
integer, parameter, public deriv_tau_a
integer, parameter, public deriv_laplace_rhoa
integer, parameter, public deriv_rho
integer, parameter, public deriv_norm_drhob
character(len=max_label_length) function, public id_to_desc(id)
...
integer, parameter, public deriv_laplace_rho
represent a group ofunctional derivatives
subroutine, public xc_dset_zero_all(deriv_set)
...
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...
type(xc_derivative_type) function, pointer, public xc_dset_get_derivative(derivative_set, description, allocate_deriv)
returns the requested xc_derivative
subroutine, public xc_dset_release(derivative_set)
releases a derivative set
subroutine, public xc_dset_create(derivative_set, pw_pool, local_bounds)
creates a derivative set object
Provides types for the management of the xc-functionals and their derivatives.
subroutine, public xc_derivative_get(deriv, split_desc, order, deriv_data, accept_null_data)
returns various information on the given derivative
type(xc_rho_cflags_type) function, public xc_functionals_get_needs(functionals, lsd, calc_potential)
...
subroutine, public xc_functionals_eval(functionals, lsd, rho_set, deriv_set, deriv_order)
...
input constants for xc
integer, parameter, public xc_default_f_routine
integer, parameter, public xc_test_lsd_f_routine
integer, parameter, public xc_debug_new_routine
contains the structure
contains the structure
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
subroutine, public xc_rho_set_release(rho_set, pw_pool)
releases the given rho_set
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...
subroutine, public xc_rho_set_update(rho_set, rho_r, rho_g, tau, needs, xc_deriv_method_id, xc_rho_smooth_id, pw_pool, spinflip)
updates the given rho set with the density given by rho_r (and rho_g). The rho set will contain the c...
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
contains utility functions for the xc package
Definition xc_util.F:14
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
subroutine, public xc_pw_smooth(pw_in, pw_out, xc_smooth_id)
...
Definition xc_util.F:73
elemental logical function, public xc_requires_tmp_g(xc_deriv_id)
...
Definition xc_util.F:58
Exchange and Correlation functional calculations.
Definition xc.F:17
subroutine, public divide_by_norm_drho(deriv_set, rho_set, lsd)
divides derivatives from deriv_set by norm_drho
Definition xc.F:6239
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, spinflip)
Calculates the second derivative of E_xc at rho in the direction rho1 (if you see the second derivati...
Definition xc.F:2650
subroutine, public xc_prep_3rd_deriv(deriv_set, rho_set, rho_r, pw_pool, xc_section, tau_r, do_sf)
Prepare deriv_set for the calculation of the 3rd derivatives of the density functional....
Definition xc.F:6187
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:1145
logical function, public xc_uses_norm_drho(xc_fun_section, lsd)
...
Definition xc.F:111
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:1460
subroutine, public xc_calc_2nd_deriv(v_xc, v_xc_tau, deriv_set, rho_set, rho1_r, rho1_g, tau1_r, pw_pool, xc_section, gapw, vxg, do_excitations, do_sf, do_triplet, compute_virial, virial_xc)
Caller routine to calculate the second order potential in the direction of rho1_r.
Definition xc.F:1532
logical function, public xc_uses_kinetic_energy_density(xc_fun_section, lsd)
...
Definition xc.F:91
subroutine, public xc_calc_3rd_deriv_analytical(v_xc, v_xc_tau, deriv_set, rho_set, rho1_set, pw_pool, xc_section, spinflip)
Calculates the third functional derivative of the exchange-correlation functional,...
Definition xc.F:5328
subroutine, public calc_xc_density(pot, rho, rho_cutoff)
Definition xc.F:1074
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:6131
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:914
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
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:1663
represent a pointer to a contiguous 3d array
represent a single linked list that stores pointers to the elements
type of a logger, at the moment it contains just a print level starting at which level it should be l...
Manages a pool of grids (to be used for example as tmp objects), but can also be used to instantiate ...
A derivative set contains the different derivatives of a xc-functional in form of a linked list.
represent a derivative of a functional
contains a flag for each component of xc_rho_set, so that you can use it to tell which components you...
represent a density, with all the representation and data needed to perform a functional evaluation