Line data Source code
1 : !!****m* ABINIT/m_pawxc
2 : !! NAME
3 : !! m_pawxc
4 : !!
5 : !! FUNCTION
6 : !! XC+PAW related operations
7 : !!
8 : !! COPYRIGHT
9 : !! Copyright (C) 2013-2026 ABINIT group (MT, FJ, TR, GJ, TD)
10 : !! This file is distributed under the terms of the
11 : !! GNU General Public License, see ~abinit/COPYING
12 : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : !!
14 : !! NOTES
15 : !! FOR DEVELOPERS: in order to preserve the portability of libPAW library,
16 : !! please consult ~abinit/src/??_libpaw/libpaw-coding-rules.txt
17 : !!
18 : !! SOURCE
19 :
20 : #include "libpaw.h"
21 :
22 : module m_pawxc
23 :
24 : USE_DEFS
25 : USE_MSG_HANDLING
26 : USE_MEMORY_PROFILING
27 :
28 : #ifdef LIBPAW_ISO_C_BINDING
29 : use, intrinsic :: iso_c_binding, only : c_ptr,c_loc,c_f_pointer
30 : #endif
31 :
32 : #ifdef HAVE_LIBPAW_ABINIT
33 : use m_xcpositron, only : xcpositron
34 : use m_drivexc, only : drivexc,size_dvxc,xcmult,mkdenpos
35 : use m_xc_noncoll, only : rotate_mag,rotate_back_mag,rotate_back_mag_dfpt
36 : #endif
37 :
38 : use m_libpaw_libxc
39 :
40 : use m_pawang, only : pawang_type
41 : use m_pawrad, only : pawrad_type,nderiv_gen,pawrad_deducer0,simp_gen
42 :
43 : implicit none
44 :
45 : private
46 :
47 : public :: pawxc ! Compute xc correlation potential and energies inside a paw sphere. USE (r,theta,phi)
48 : public :: pawxcpositron ! Compute electron-positron correlation potential and energies inside a PAW sphere. USE (r,theta,phi)
49 : public :: pawxc_dfpt ! Compute first-order change of XC potential and contribution to
50 : ! 2nd-order change of XC energy inside a PAW sphere. USE (r,theta,phi)
51 : public :: pawxcsum ! Compute useful sums of moments of densities needed to compute on-site contributions to XC energy and potential
52 : public :: pawxcm ! Compute xc correlation potential and energies inside a paw sphere. USE (L,M) MOMENTS
53 : public :: pawxcmpositron ! Compute electron-positron correlation potential and energies inside a PAW sphere. USE (L,M) MOMENTS
54 : public :: pawxcm_dfpt ! Compute 1st-order change of XC potential and contrib
55 : ! to 2nd-order change of XC ene inside a PAW sphere. USE (L,M) MOMENTS
56 : public :: pawxc_get_nkxc ! Compute size of XC kernel (Kxc) according to spin polarization and XC type
57 : public :: pawxc_get_xclevel ! Get XC level (1=LDA, 2=GGA/mGGA, 3=TDDFT)
58 : public :: pawxc_get_usekden ! Assess whether kinetic energy density is used in XC functional
59 : public :: pawxc_get_uselaplacian ! Assess whether laplacian of density is used in XC functional
60 : public :: pawxc_is_tb09 ! Assess whether the XC functional is Tran-Blaha 09 (modified BJ)
61 :
62 : !Private procedures
63 : private :: pawxcsph ! Compute XC energy and potential for a spherical density rho(r) given as (up,dn)
64 : private :: pawxcsphpositron ! Compute electron-positron XC energy and potential for spherical densities rho_el(r) rho_pos(r)
65 : private :: pawxcsph_dfpt ! Compute XC 1st-order potential for a 1st-order spherical density rho1(r)
66 : private :: pawxc_rotate_mag ! Rotate a non-collinear density wrt a magnetization
67 : private :: pawxc_rotate_back_mag ! Rotate back a collinear XC potential wrt a magnetization
68 : private :: pawxc_rotate_back_mag_dfpt ! Rotate back a collinear 1st-order XC potential wrt a magnetization
69 :
70 : !Wrappers
71 : private :: pawxc_drivexc_wrapper ! wrapper for drivexc
72 : private :: pawxc_mkdenpos_wrapper ! wrapper for mkdenpos
73 : private :: pawxc_xcmult_wrapper ! wrapper for xcmult
74 : private :: pawxc_size_dvxc_wrapper ! wrapper for size_dvxc
75 : private :: pawxc_xcpositron_wrapper ! wrapper for xcpositron
76 :
77 : !Zero of density
78 : real(dp),parameter :: rho_min=tol14
79 : !!***
80 :
81 : CONTAINS !===========================================================
82 : !!***
83 :
84 : !!****f* m_pawxc/pawxc_xcpositron_wrapper
85 : !! NAME
86 : !! pawxc_xcpositron_wrapper
87 : !!
88 : !! FUNCTION
89 : !! Compute electron-positron correlation potentials and energy density.
90 : !! Used electron-positron correlation functional is controlled by ipawxc_xcpositron_wrapper argument.
91 : !! Returns Fxc, Vxc_pos, Vxc_el from input rhor_pos and rhor_el for positron and electrons.
92 : !!
93 : !! INPUTS
94 : !! grhoe2(ngr)=square of the gradient of electronic density rhoe (needed for GGA)
95 : !! ixcpositron=type of electron-positron correlation functional:
96 : !! 1 or -1: LDA zero positron density limit parametrized by Arponen & Pajanne
97 : !! and provided by Boronski & Nieminen [1,2]
98 : !! 11: LDA zero positron density limit parametrized by Arponen & Pajanne
99 : !! and fitted by Sterne & Kaiser [1,3]
100 : !! 2: LDA electron-positron correlation
101 : !! provided by Puska, Seitsonen, and Nieminen [1,4]
102 : !! 3: GGA zero positron density limit parametrized by Arponen & Pajanne
103 : !! and provided by Boronski & Nieminen [1,2,5]
104 : !! 31: GGA zero positron density limit parametrized by Arponen & Pajanne
105 : !! and fitted by Sterne & Kaiser [1,3,5]
106 : !! See references below
107 : !! ngr=size of grho2 array (0 if LDA, npt if GGA)
108 : !! npt=number of real space points on which density is provided
109 : !! posdensity0_limit=True if we are in the zero positron density limit
110 : !! rhoer(npt)=electron density (bohr^-3)
111 : !! rhopr(npt)=positron density (bohr^-3)
112 : !!
113 : !! OUTPUT
114 : !! fnxc(npt)=correlation energy per unit volume fxc
115 : !! vxce(npt)=correlation potential for electron dfxc/drhoe (hartree)
116 : !! vxcp(npt)=correlation potential for positron dfxc/drhop (hartree)
117 : !! vxcegr(ngr)= 1/|gradRhoe| dfxc/d|gradRhoe| (empty if LDA, i.e. ngr=0)
118 : !! Optional outputs:
119 : !! dvxce(npt)=partial second derivatives of the xc energy wr to the electronic density
120 : !! dvxce(:)=dVxce/dRhoe
121 : !! dvxcp(npt)=partial second derivatives of the xc energy wr to the positronic density
122 : !! dvxcp(:)=dVxcp/drhop
123 : !!
124 : !! NOTES
125 : !! References for electron-positron correlation functionals:
126 : !! [1] J. Arponen and E. Pajanne, Ann. Phys. (N.Y.) 121, 343 (1979) [[cite:Arponen1979a]].
127 : !! [2] E. Boronski and R.M. Nieminen, Phys. Rev. B 34, 3820 (1986) [[cite:Boronski1986]].
128 : !! [3] P.A. Sterne and J.H. Kaiser, Phys. Rev. B 43, 13892 (1991) [[cite:Sterne1991]].
129 : !! [4] M.J. Puska, A.P. Seitsonen and R.M. Nieminen, Phys. Rev. B 52, 10947 (1994) [[cite:Puska1994]].
130 : !! [5] B. Barbiellini, M.J. Puska, T. Torsti and R.M.Nieminen, Phys. Rev. B 51, 7341 (1995) [[cite:Barbiellini1995]]
131 : !!
132 : !! SOURCE
133 :
134 58760 : subroutine pawxc_xcpositron_wrapper(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,&
135 58760 : & rhoer,rhopr,vxce,vxcegr,vxcp,&
136 : & dvxce,dvxcp) ! optional arguments
137 :
138 : !Arguments ------------------------------------
139 : !scalars
140 : integer,intent(in) :: ixcpositron,ngr,npt
141 : logical,intent(in) :: posdensity0_limit
142 : !arrays
143 : real(dp),intent(in) :: grhoe2(ngr),rhoer(npt),rhopr(npt)
144 : real(dp),intent(out) :: fnxc(npt),vxce(npt),vxcegr(ngr),vxcp(npt)
145 : real(dp),intent(out),optional :: dvxce(npt),dvxcp(npt)
146 :
147 : !Local variables-------------------------------
148 :
149 : ! *************************************************************************
150 :
151 : #if defined HAVE_LIBPAW_ABINIT
152 58760 : call pawxc_xcpositron_abinit()
153 : #else
154 : call pawxc_xcpositron_local()
155 : #endif
156 : !!***
157 :
158 : contains
159 : !!***
160 :
161 : #if defined HAVE_LIBPAW_ABINIT
162 : !!****f* pawxc_xcpositron_wrapper/pawxc_xcpositron_abinit
163 : !! NAME
164 : !! pawxc_xcpositron_abinit
165 : !!
166 : !! FUNCTION
167 : !! ABINIT version of electron-positron correlation
168 : !!
169 : !! SOURCE
170 :
171 58760 : subroutine pawxc_xcpositron_abinit()
172 :
173 : ! *************************************************************************
174 :
175 58760 : if(present(dvxce) .and. present(dvxcp)) then
176 : call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,&
177 0 : & dvxce=dvxce,dvxcp=dvxcp) ! optional arguments
178 58760 : elseif( present(dvxce) .and. .not. present(dvxcp)) then
179 : call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,&
180 0 : & dvxce=dvxce) ! optional arguments
181 58760 : elseif( .not. present(dvxce) .and. present(dvxcp)) then
182 : call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp,&
183 0 : & dvxcp=dvxcp) ! optional arguments
184 : else
185 58760 : call xcpositron(fnxc,grhoe2,ixcpositron,ngr,npt,posdensity0_limit,rhoer,rhopr,vxce,vxcegr,vxcp)
186 : end if
187 :
188 58760 : end subroutine pawxc_xcpositron_abinit
189 : !!***
190 :
191 : #else
192 : !!****f* pawxc_xcpositron_wrapper/pawxc_xcpositron_local
193 : !! NAME
194 : !! pawxc_xcpositron_local
195 : !!
196 : !! FUNCTION
197 : !! Local version of electron-positron correlation (to use outside ABINIT)
198 : !! NOT AVAILABLE
199 : !!
200 : !! SOURCE
201 :
202 : subroutine pawxc_xcpositron_local()
203 :
204 : character(len=*), parameter :: msg='xcpositron only available in ABINIT!'
205 :
206 : ! *************************************************************************
207 :
208 : LIBPAW_BUG(msg)
209 :
210 : end subroutine pawxc_xcpositron_local
211 : !!***
212 : #endif
213 :
214 : end subroutine pawxc_xcpositron_wrapper
215 : !!***
216 :
217 : !----------------------------------------------------------------------
218 :
219 : !!****f* m_pawxc/pawxc_size_dvxc_wrapper
220 : !! NAME
221 : !! pawxc_size_dvxc_wrapper
222 : !!
223 : !! FUNCTION
224 : !! Give the sizes of the several arrays involved in exchange-correlation calculation
225 : !! needed to allocated them for the drivexc routine
226 : !!
227 : !! INPUTS
228 : !! ixc= choice of exchange-correlation scheme
229 : !! order= gives the maximal derivative of Exc computed.
230 : !! 1=usual value (return exc and vxc)
231 : !! 2=also computes the kernel (return exc,vxc,kxc)
232 : !! -2=like 2, except (to be described)
233 : !! 3=also computes the derivative of the kernel (return exc,vxc,kxc,k3xc)
234 : !! nspden= number of spin components
235 : !! [xc_funcs(2)]= <type(libxc_functional_type)>
236 : !! [add_tfw]= optional flag controling the addition of Weiszacker gradient correction to Thomas-Fermi XC energy
237 : !!
238 : !! OUTPUT
239 : !! --- All optionals
240 : !! [usegradient]= [flag] 1 if the XC functional needs the gradient of the density (grho2_updn)
241 : !! [uselaplacian]= [flag] 1 if the XC functional needs the laplacian of the density (lrho_updn)
242 : !! [usekden]= [flag] 1 if the XC functional needs the kinetic energy density (lrho_updn)
243 : !! [nvxcgrho]= size of the array dvxcdgr(npts,nvxcgrho) (derivative of Exc wrt to gradient)
244 : !! [nvxclrho]= size of the array dvxclpl(npts,nvxclrho) (derivative of Exc wrt to laplacian)
245 : !! [nvxctau]= size of the array dvxctau(npts,nvxctau) (derivative of Exc wrt to kin. ener. density)
246 : !! [ndvxc]= size of the array dvxc(npts,ndvxc) (second derivatives of Exc wrt to density and gradient)
247 : !! [nd2vxc]= size of the array d2vxc(npts,nd2vxc) (third derivatives of Exc wrt density)
248 : !!
249 : !! SOURCE
250 :
251 234713 : subroutine pawxc_size_dvxc_wrapper(ixc,order,nspden,&
252 : & usegradient,uselaplacian,usekden,&
253 : & nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc)
254 :
255 : !Arguments----------------------
256 : integer,intent(in) :: ixc,nspden,order
257 : integer,intent(out),optional :: nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc
258 : integer,intent(out),optional :: usegradient,uselaplacian,usekden
259 : !Local variables----------------
260 : integer :: nvxcgrho_,nvxclrho_,nvxctau_,ndvxc_,nd2vxc_
261 : integer :: usegradient_,uselaplacian_,usekden_
262 :
263 : ! *************************************************************************
264 :
265 : #if defined HAVE_LIBPAW_ABINIT
266 : call size_dvxc(ixc,order,nspden,&
267 : & usegradient=usegradient_,uselaplacian=uselaplacian_,usekden=usekden_,&
268 : nvxcgrho=nvxcgrho_,nvxclrho=nvxclrho_,nvxctau=nvxctau_,&
269 234713 : & ndvxc=ndvxc_,nd2vxc=nd2vxc_)
270 : #else
271 : call pawxc_size_dvxc_local()
272 : #endif
273 234713 : if (present(usegradient)) usegradient=usegradient_
274 234713 : if (present(uselaplacian)) uselaplacian=uselaplacian_
275 234713 : if (present(usekden)) usekden=usekden_
276 234713 : if (present(nvxcgrho)) nvxcgrho=nvxcgrho_
277 234713 : if (present(nvxclrho)) nvxclrho=nvxclrho_
278 234713 : if (present(nvxctau)) nvxctau=nvxctau_
279 234713 : if (present(ndvxc)) ndvxc=ndvxc_
280 234713 : if (present(nd2vxc)) nd2vxc=nd2vxc_
281 : !!***
282 :
283 : #if ! defined HAVE_LIBPAW_ABINIT
284 : contains
285 : !!***
286 :
287 : !!****f* pawxc_size_dvxc_wrapper/pawxc_size_dvxc_local
288 : !! NAME
289 : !! pawxc_size_dvxc_local
290 : !!
291 : !! FUNCTION
292 : !! Local version of size_dvxc routine (to use outside ABINIT)
293 : !!
294 : !! SOURCE
295 :
296 : subroutine pawxc_size_dvxc_local()
297 :
298 : !Local variables----------------
299 : logical :: need_gradient,need_kden,need_laplacian
300 :
301 : ! *************************************************************************
302 :
303 : !Do we use the gradient?
304 : need_gradient=((ixc>=11.and.ixc<=17).or.(ixc==23.or.ixc==24).or. &
305 : & (ixc==26.or.ixc==27).or.(ixc>=31.and.ixc<=35).or. &
306 : & (ixc==41.or.ixc==42).or.ixc==1402000.or.ixc==60)
307 : if (ixc<0) then
308 : if (libxc_functionals_isgga().or.libxc_functionals_ismgga().or. &
309 : & libxc_functionals_is_hybrid()) need_gradient=.true.
310 : end if
311 : usegradient_=0 ; if (need_gradient) usegradient_=2*min(nspden,2)-1
312 :
313 : !Do we use the laplacian?
314 : need_laplacian=(ixc==32.or.ixc==35)
315 : if (ixc<0) need_laplacian=libxc_functionals_needs_laplacian()
316 : uselaplacian_=0 ; if (need_laplacian) uselaplacian_=min(nspden,2)
317 :
318 : !Do we use the kinetic energy density?
319 : need_kden=(ixc==31.or.ixc==34.or.ixc==35)
320 : if (ixc<0) need_kden=libxc_functionals_needs_tau()
321 : usekden_=0 ; if (need_kden) usekden_=min(nspden,2)
322 :
323 : !First derivative(s) of XC functional wrt gradient of density
324 : nvxcgrho_=0
325 : if (abs(order)>=1) then
326 : if (need_gradient) nvxcgrho_=3
327 : if (ixc==16.or.ixc==17.or.ixc==26.or.ixc==27) nvxcgrho_=2
328 : end if
329 :
330 : !First derivative(s) of XC functional wrt laplacian of density
331 : nvxclrho_=0
332 : if (abs(order)>=1) then
333 : if (need_laplacian) nvxclrho_=min(nspden,2)
334 : end if
335 :
336 : !First derivative(s) of XC functional wrt kinetic energy density
337 : nvxctau_=0
338 : if (abs(order)>=1) then
339 : if (need_kden) nvxctau_=min(nspden,2)
340 : end if
341 :
342 : !Second derivative(s) of XC functional wrt density
343 : ndvxc_=0
344 : if (abs(order)>=2) then
345 : if (ixc==1.or.ixc==7.or.ixc==8.or.ixc==9.or.ixc==10.or.ixc==13.or. &
346 : & ixc==21.or.ixc==22) then
347 : ndvxc_=min(nspden,2)+1
348 : else if ((ixc>=2.and.ixc<=6).or.(ixc>=31.and.ixc<=35).or.&
349 : & (ixc==50.or.ixc==51.or.ixc==60)) then
350 : ndvxc_=1
351 : else if (ixc==12.or.ixc==24) then
352 : ndvxc_=8
353 : else if (ixc==11.or.ixc==12.or.ixc==14.or.ixc==15.or. &
354 : & ixc==23.or.ixc==41.or.ixc==42.or.ixc==1402000) then
355 : ndvxc_=15
356 : else if (ixc<0) then
357 : if (libxc_functionals_has_kxc() then
358 : ndvxc_=2*min(nspden,2)+1 ; if (order==-2) ndvxc_=2
359 : if (need_gradient) ndvxc_=15
360 : end if
361 : end if
362 : end if
363 :
364 : !Third derivative(s) of XC functional wrt density
365 : nd2vxc_=0
366 : if (abs(order)>=3) then
367 : if (ixc==3.or.(ixc>=11.and.ixc<=15.and.ixc/=13).or. &
368 : & ixc==23.or.ixc==24.or.ixc==41.or.ixc==42) then
369 : nd2vxc_=1
370 : else if ((ixc>=7.and.ixc<=10).or.ixc==13.or.ixc==1402000) then
371 : nd2vxc_=3*min(nspden,2)-2
372 : else if (ixc<0) then
373 : if (libxc_functionals_has_k3xc() then
374 : if (.not.need_gradient) nd2vxc_=3*min(nspden,2)-2
375 : end if
376 : end if
377 : end if
378 :
379 : end subroutine pawxc_size_dvxc_local
380 : !!***
381 : #endif
382 :
383 234713 : end subroutine pawxc_size_dvxc_wrapper
384 : !!***
385 :
386 : !----------------------------------------------------------------------
387 :
388 : !!****f* m_pawxc/pawxc_xcmult_wrapper
389 : !! NAME
390 : !! pawxc_xcmult_wrapper
391 : !!
392 : !! FUNCTION
393 : !! In the case of GGA, multiply the different gradient of spin-density
394 : !! by the derivative of the XC functional with respect
395 : !! to the norm of the gradient, then divide it by the
396 : !! norm of the gradient
397 : !!
398 : !! INPUTS
399 : !! depsxc(nfft,nspgrad)=derivative of Exc with respect to the (spin-)density,
400 : !! or to the norm of the gradient of the (spin-)density,
401 : !! further divided by the norm of the gradient of the (spin-)density
402 : !! The different components of depsxc will be
403 : !! for nspden=1, depsxc(:,1)=d(rho.exc)/d(rho)
404 : !! and if ngrad=2, depsxc(:,2)=1/2*1/|grad rho_up|*d(rho.exc)/d(|grad rho_up|)
405 : !! + 1/|grad rho|*d(rho.exc)/d(|grad rho|)
406 : !! (do not forget : |grad rho| /= |grad rho_up| + |grad rho_down|
407 : !! for nspden=2, depsxc(:,1)=d(rho.exc)/d(rho_up)
408 : !! depsxc(:,2)=d(rho.exc)/d(rho_down)
409 : !! and if ngrad=2, depsxc(:,3)=1/|grad rho_up|*d(rho.exc)/d(|grad rho_up|)
410 : !! depsxc(:,4)=1/|grad rho_down|*d(rho.exc)/d(|grad rho_down|)
411 : !! depsxc(:,5)=1/|grad rho|*d(rho.exc)/d(|grad rho|)
412 : !! nfft=(effective) number of FFT grid points (for this processor)
413 : !! ngrad = must be 2
414 : !! nspden=number of spin-density components
415 : !! nspgrad=number of spin-density and spin-density-gradient components
416 : !!
417 : !! OUTPUT
418 : !! (see side effects)
419 : !!
420 : !! SIDE EFFECTS
421 : !! rhonow(nfft,nspden,ngrad*ngrad)=
422 : !! at input :
423 : !! electron (spin)-density in real space and its gradient,
424 : !! either on the unshifted grid (if ishift==0,
425 : !! then equal to rhor), or on the shifted grid
426 : !! rhonow(:,:,1)=electron density in electrons/bohr**3
427 : !! rhonow(:,:,2:4)=gradient of electron density in el./bohr**4
428 : !! at output :
429 : !! rhonow(:,:,2:4) has been multiplied by the proper factor,
430 : !! described above.
431 : !!
432 : !! SOURCE
433 :
434 189648 : subroutine pawxc_xcmult_wrapper(depsxc,nfft,ngrad,nspden,nspgrad,rhonow)
435 :
436 : !Arguments ------------------------------------
437 : !scalars
438 : integer,intent(in) :: nfft,ngrad,nspden,nspgrad
439 : !arrays
440 : real(dp),intent(in) :: depsxc(nfft,nspgrad)
441 : real(dp),intent(inout) :: rhonow(nfft,nspden,ngrad*ngrad)
442 :
443 : ! *************************************************************************
444 :
445 : #if defined HAVE_LIBPAW_ABINIT
446 189648 : call xcmult(depsxc,nfft,ngrad,nspden,nspgrad,rhonow)
447 : #else
448 : call pawxc_xcmult_local()
449 : #endif
450 : !!***
451 :
452 : #if ! defined HAVE_LIBPAW_ABINIT
453 : contains
454 : !!***
455 :
456 : !!****f* pawxc_xcmult_wrapper/pawxc_xcmult_local
457 : !! NAME
458 : !! pawxc_xcmult_local
459 : !!
460 : !! FUNCTION
461 : !! Local version of xcmult routine (to use outside ABINIT)
462 : !!
463 : !! SOURCE
464 :
465 : subroutine pawxc_xcmult_local()
466 :
467 : !Local variables-------------------------------
468 : !scalars
469 : integer :: idir,ifft
470 : real(dp) :: rho_tot,rho_up
471 :
472 : ! *************************************************************************
473 :
474 : do idir=1,3
475 :
476 : if(nspden==1)then
477 : !$OMP PARALLEL DO PRIVATE(ifft) SHARED(depsxc,idir,nfft,rhonow)
478 : do ifft=1,nfft
479 : rhonow(ifft,1,1+idir)=rhonow(ifft,1,1+idir)*depsxc(ifft,2)
480 : end do
481 : else
482 : ! In the spin-polarized case, there are more factors to take into account
483 : !$OMP PARALLEL DO PRIVATE(ifft,rho_tot,rho_up) SHARED(depsxc,idir,nfft,rhonow)
484 : do ifft=1,nfft
485 : rho_tot=rhonow(ifft,1,1+idir)
486 : rho_up =rhonow(ifft,2,1+idir)
487 : rhonow(ifft,1,1+idir)=rho_up *depsxc(ifft,3) + rho_tot*depsxc(ifft,5)
488 : rhonow(ifft,2,1+idir)=(rho_tot-rho_up)*depsxc(ifft,4)+ rho_tot*depsxc(ifft,5)
489 : end do
490 : end if ! nspden==1
491 : end do ! End loop on directions
492 :
493 : end subroutine pawxc_xcmult_local
494 : !!***
495 : #endif
496 :
497 : end subroutine pawxc_xcmult_wrapper
498 : !!***
499 :
500 : !----------------------------------------------------------------------
501 :
502 : !!****f* m_pawxc/pawxc_mkdenpos_wrapper
503 : !! NAME
504 : !! pawxc_mkdenpos_wrapper
505 : !!
506 : !! FUNCTION
507 : !! Make a density positive everywhere :
508 : !! when the density (or spin-density) is smaller than xc_denpos,
509 : !! set it to the value of xc_denpos
510 : !!
511 : !! INPUTS
512 : !! nfft=(effective) number of FFT grid points (for this processor)
513 : !! nspden=number of spin-density components (max. 2)
514 : !! option=0 if density rhonow is stored as (up,dn)
515 : !! 1 if density rhonow is stored as (up+dn,up)
516 : !! Active only when nspden=2
517 : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
518 : !!
519 : !! OUTPUT
520 : !!
521 : !! SIDE EFFECTS
522 : !! Input/output
523 : !! iwarn=At input: iwarn=0 a warning will be printed when rho is negative
524 : !! iwarn>0 no warning will be printed out
525 : !! At output: iwarn is increased by 1
526 : !! rhonow(nfft,nspden)=electron (spin)-density in real space,
527 : !! either on the unshifted grid (if ishift==0,
528 : !! then equal to rhor),or on the shifted grid
529 : !!
530 : !! SOURCE
531 :
532 527513 : subroutine pawxc_mkdenpos_wrapper(iwarn,nfft,nspden,option,rhonow,xc_denpos)
533 :
534 : !Arguments ------------------------------------
535 : !scalars
536 : integer,intent(in) :: nfft,nspden,option
537 : integer,intent(inout) :: iwarn
538 : real(dp),intent(in) :: xc_denpos
539 : !arrays
540 : real(dp),intent(inout) :: rhonow(nfft,nspden)
541 :
542 : ! *************************************************************************
543 :
544 : #if defined HAVE_LIBPAW_ABINIT
545 527513 : call mkdenpos(iwarn,nfft,nspden,option,rhonow,xc_denpos)
546 : #else
547 : call pawxc_mkdenpos_local()
548 : #endif
549 : !!***
550 :
551 : #if ! defined HAVE_LIBPAW_ABINIT
552 : contains
553 : !!***
554 :
555 : !!****f* pawxc_mkdenpos_wrapper/pawxc_mkdenpos_local
556 : !! NAME
557 : !! pawxc_mkdenpos_local
558 : !!
559 : !! FUNCTION
560 : !! Local version of mkdenpos routine (to use outside ABINIT)
561 : !!
562 : !! SOURCE
563 :
564 : subroutine pawxc_mkdenpos_local()
565 :
566 : !Local variables-------------------------------
567 : !scalars
568 : integer :: ifft,ispden,numneg
569 : real(dp) :: rhotmp,worst
570 : character(len=500) :: msg
571 : !arrays
572 : real(dp) :: rho(2)
573 :
574 : ! *************************************************************************
575 :
576 : numneg=0;worst=zero
577 :
578 : if(nspden==1)then
579 : ! Non spin-polarized
580 : !$OMP PARALLEL DO PRIVATE(ifft,rhotmp) REDUCTION(MIN:worst) REDUCTION(+:numneg) SHARED(nfft,rhonow)
581 : !$OMP&SHARED(nfft,rhonow)
582 : do ifft=1,nfft
583 : rhotmp=rhonow(ifft,1)
584 : if(rhotmp<xc_denpos)then
585 : if(rhotmp<-xc_denpos)then
586 : ! This case is probably beyond machine precision considerations
587 : worst=min(worst,rhotmp)
588 : numneg=numneg+1
589 : end if
590 : rhonow(ifft,1)=xc_denpos
591 : end if
592 : end do
593 :
594 : else if (nspden==2) then
595 : ! Spin-polarized
596 :
597 : ! rhonow is stored as (up,dn)
598 : if (option==0) then
599 : !$OMP PARALLEL DO PRIVATE(ifft,ispden,rho,rhotmp) REDUCTION(MIN:worst) REDUCTION(+:numneg) &
600 : !$OMP&SHARED(nfft,nspden,rhonow)
601 : do ifft=1,nfft
602 : ! For polarized case, rho(1) is spin-up density, rho(2) is spin-down density
603 : rho(1)=rhonow(ifft,1)
604 : rho(2)=rhonow(ifft,2)
605 : do ispden=1,nspden
606 : if (rho(ispden)<xc_denpos) then
607 : if (rho(ispden)<-xc_denpos) then
608 : ! This case is probably beyond machine precision considerations
609 : worst=min(worst,rho(ispden))
610 : numneg=numneg+1
611 : end if
612 : rhonow(ifft,ispden)=xc_denpos
613 : end if
614 : end do
615 : end do
616 :
617 : ! rhonow is stored as (up+dn,up)
618 : else if (option==1) then
619 : !$OMP PARALLEL DO PRIVATE(ifft,ispden,rho,rhotmp) &
620 : !$OMP&REDUCTION(MIN:worst) REDUCTION(+:numneg) &
621 : !$OMP&SHARED(nfft,nspden,rhonow)
622 : do ifft=1,nfft
623 : ! For polarized case, rho(1) is spin-up density, rho(2) is spin-down density
624 : rho(1)=rhonow(ifft,2)
625 : rho(2)=rhonow(ifft,1)-rho(1)
626 : do ispden=1,nspden
627 : if (rho(ispden)<xc_denpos) then
628 : if (rho(ispden)<-xc_denpos) then
629 : ! This case is probably beyond machine precision considerations
630 : worst=min(worst,rho(ispden))
631 : numneg=numneg+1
632 : end if
633 : rho(ispden)=xc_denpos
634 : rhonow(ifft,1)=rho(1)+rho(2)
635 : rhonow(ifft,2)=rho(1)
636 : end if
637 : end do
638 : end do
639 :
640 : end if ! option
641 : else
642 : msg='nspden>2 not allowed !'
643 : LIBPAW_BUG(msg)
644 : end if ! End choice between non-spin polarized and spin-polarized.
645 :
646 : if (numneg>0) then
647 : if (iwarn==0) then
648 : write(msg,'(a,i10,a,a,a,es10.2,a,e10.2,a,a,a,a)')&
649 : & 'Density went too small (lower than xc_denpos) at',numneg,' points',ch10,&
650 : & 'and was set to xc_denpos=',xc_denpos,'. Lowest was ',worst,'.',ch10,&
651 : & 'Likely due to too low boxcut or too low ecut for','pseudopotential core charge.'
652 : LIBPAW_WARNING(msg)
653 : end if
654 : iwarn=iwarn+1
655 : end if
656 :
657 : end subroutine pawxc_mkdenpos_local
658 : !!***
659 : #endif
660 :
661 155916 : end subroutine pawxc_mkdenpos_wrapper
662 : !!***
663 :
664 : !----------------------------------------------------------------------
665 :
666 : !!****f* m_pawxc/pawxc_get_xclevel
667 : !! NAME
668 : !! pawxc_get_xclevel
669 : !!
670 : !! FUNCTION
671 : !! Give the eXchange-Correlation "level" (1=LDA, 2=GGA/mGGA, 3=TDDFT)
672 : !!
673 : !! INPUTS
674 : !! ixc= choice of exchange-correlation scheme
675 : !!
676 : !! SOURCE
677 :
678 595 : function pawxc_get_xclevel(ixc)
679 : !Arguments ------------------------------------
680 : integer,intent(in) :: ixc
681 : integer :: pawxc_get_xclevel
682 :
683 : ! *************************************************************************
684 :
685 595 : pawxc_get_xclevel=0
686 :
687 : !ABINIT
688 595 : if ((1<=ixc.and.ixc<=10).or.(30<=ixc.and.ixc<=39).or.(ixc==50)) pawxc_get_xclevel=1 ! ABINIT LDA
689 595 : if ((11<=ixc.and.ixc<=19).or.(23<=ixc.and.ixc<=29).or.ixc==1402000) pawxc_get_xclevel=2 ! ABINIT GGA
690 595 : if (20<=ixc.and.ixc<=22) pawxc_get_xclevel=3 ! ABINIT TDDFT kernel tests
691 595 : if (ixc>=31.and.ixc<=35) pawxc_get_xclevel=2 ! ABINIT internal fake mGGA
692 595 : if (ixc>=41.and.ixc<=42) pawxc_get_xclevel=2 ! ABINIT internal hybrids using GGA
693 :
694 : !LibXC functionals
695 595 : if (ixc<0) then
696 234 : pawxc_get_xclevel=1
697 234 : if (libxc_functionals_isgga()) pawxc_get_xclevel=2
698 234 : if (libxc_functionals_ismgga()) pawxc_get_xclevel=2
699 234 : if (libxc_functionals_is_hybrid()) pawxc_get_xclevel=2
700 : end if
701 :
702 595 : end function pawxc_get_xclevel
703 : !!***
704 :
705 : !----------------------------------------------------------------------
706 :
707 : !!****f* m_pawxc/pawxc_get_usekden
708 : !! NAME
709 : !! pawxc_get_usekden
710 : !!
711 : !! FUNCTION
712 : !! Check if kinetic energy density is used in XC functional
713 : !!
714 : !! INPUTS
715 : !! ixc= choice of exchange-correlation scheme
716 : !!
717 : !! SOURCE
718 :
719 26748 : function pawxc_get_usekden(ixc)
720 : !Arguments ------------------------------------
721 : integer,intent(in) :: ixc
722 : integer :: pawxc_get_usekden
723 :
724 : ! *************************************************************************
725 :
726 26748 : pawxc_get_usekden=0
727 26748 : if (ixc<0) then
728 9782 : if (libxc_functionals_ismgga()) pawxc_get_usekden=1
729 16966 : else if (ixc==31.or.ixc==34.or.ixc==35) then
730 648 : pawxc_get_usekden=1
731 : end if
732 :
733 26748 : end function pawxc_get_usekden
734 : !!***
735 :
736 : !----------------------------------------------------------------------
737 :
738 : !!****f* m_pawxc/pawxc_get_uselaplacian
739 : !! NAME
740 : !! pawxc_get_uselaplacian
741 : !!
742 : !! FUNCTION
743 : !! Check if laplacian of density is used in XC functional
744 : !!
745 : !! INPUTS
746 : !! ixc= choice of exchange-correlation scheme
747 : !!
748 : !! SOURCE
749 :
750 592 : function pawxc_get_uselaplacian(ixc)
751 : !Arguments ------------------------------------
752 : integer,intent(in) :: ixc
753 : integer :: pawxc_get_uselaplacian
754 :
755 : ! *************************************************************************
756 :
757 592 : pawxc_get_uselaplacian=0
758 592 : if (ixc<0) then
759 232 : if (libxc_functionals_needs_laplacian()) pawxc_get_uselaplacian=1
760 360 : else if (ixc==32.or.ixc==35) then
761 2 : pawxc_get_uselaplacian=1
762 : end if
763 :
764 592 : end function pawxc_get_uselaplacian
765 : !!***
766 :
767 : !----------------------------------------------------------------------
768 :
769 : !!****f* m_pawxc/pawxc_is_tb09
770 : !! NAME
771 : !! pawxc_is_tb09
772 : !!
773 : !! FUNCTION
774 : !! Check if the XC functional is Tran-Blaha 09 (modified BJ)
775 : !!
776 : !! INPUTS
777 : !! ixc= choice of exchange-correlation scheme
778 : !!
779 : !! SOURCE
780 :
781 0 : function pawxc_is_tb09(ixc)
782 : !Arguments ------------------------------------
783 : integer,intent(in) :: ixc
784 : logical :: pawxc_is_tb09
785 :
786 : ! *************************************************************************
787 :
788 0 : pawxc_is_tb09=.false.
789 0 : if (ixc<0) then
790 0 : pawxc_is_tb09 = libxc_functionals_is_tb09()
791 : end if
792 :
793 0 : end function pawxc_is_tb09
794 : !!***
795 :
796 : !----------------------------------------------------------------------
797 :
798 : !!****f* m_pawxc/pawxc
799 : !! NAME
800 : !! pawxc
801 : !!
802 : !! FUNCTION
803 : !! Start from the density or spin-density, and compute xc correlation
804 : !! potential and energies inside a paw sphere.
805 : !! USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi)
806 : !! Driver of XC functionals.
807 : !!
808 : !! INPUTS
809 : !! corexc(nrad)=core density on radial grid
810 : !! ixc= choice of exchange-correlation scheme
811 : !! lm_size=size of density array rhor (see below)
812 : !! lmselect(lm_size)=select the non-zero LM-moments of input density rhor
813 : !! nhat(nrad,lm_size,nspden)=compensation density
814 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
815 : !! nkxc=second dimension of the kxc array. If /=0, the exchange-correlation kernel must be computed
816 : !! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
817 : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
818 : !! nspden=number of spin-density components
819 : !! option=0 compute both XC energies (direct+double-counting) and potential
820 : !! 1 compute only XC potential
821 : !! 2 compute only XC energies (direct+double-counting)
822 : !! 3 compute only XC energy by direct scheme
823 : !! 4 compute only XC energy by direct scheme for spherical part of the density
824 : !! 5 compute only XC potential for spherical part of the density
825 : !! pawang <type(pawang_type)>=paw angular mesh and related data
826 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
827 : !! rhor(nrad,lm_size,nspden)=electron density in real space in electrons/bohr**3
828 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
829 : !! usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise
830 : !! usexcnhat= 0 if compensation density does not have to be used
831 : !! 1 if compensation density has to be used in double counting energy term only
832 : !! 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
833 : !! xclevel= XC functional level
834 : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
835 : !! el_temp=electronic temperature (hartree)
836 : !! ----- Optional arguments -----
837 : !! [coretau(nrad*usekden)]= core kinetic energy density (optional)
838 : !! [taur(nrad,lm_size,nspden*usekden)]= kinetic energy density on radial mesh (optional)
839 : !! [xc_taupos]= lowest allowed kinetic energy density (for mGGA XC functionals)
840 : !!
841 : !! OUTPUT
842 : !! == if option=0, 2, 3, or 4 ==
843 : !! enxc=returned exchange and correlation energy (hartree)
844 : !! snxc=returned exchange and correlation entropy (for finite-temperature xc functionals)
845 : !! == if option=0 or 2 ==
846 : !! enxcdc=returned exchange-cor. contribution to double-counting energy
847 : !! == if option=0, 1 or 5 ==
848 : !! vxc(nrad,pawang%angl_size,nspden)=xc potential
849 : !! (spin up in 1st half and spin-down in 2nd half if nspden=2)
850 : !! == if option=0, 1 or 5 and usekden=1 ==
851 : !! [vxctau(nrad,pawang%angl_size,nspden*usekden)]=xc potential due to kinetic energy density
852 : !! (spin up in 1st half and spin-down in 2nd half if nspden=2) (optional)
853 : !! == if nkxc>0 ==
854 : !! kxc(nrad,pawang%angl_size,nkxc)=xc kernel
855 : !! (see notes below for nkxc)
856 : !! == if nk3xc>0 ==
857 : !! k3xc(nrad,pawang%angl_size,nk3xc)= derivative of xc kernel
858 : !! (see notes below for nk3xc)
859 : !! == For the TB09 XC functional (modified Becke-Johnson)
860 : !! [grho1_over_rho1]=Integral of |Grad(rho^1)|/rho^1 over the augmentation region
861 : !! Used to compute the c parameter of the TB09 XC functional
862 : !!
863 : !! NOTES
864 : !! Content of Kxc array:
865 : !! ===== if LDA
866 : !! if nspden==1: kxc(:,1)= d2Exc/drho2
867 : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
868 : !! if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
869 : !! kxc(:,2)= d2Exc/drho_up drho_dn
870 : !! kxc(:,3)= d2Exc/drho_dn drho_dn
871 : !! if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
872 : !! ===== if GGA or mGGA
873 : !! if nspden==1:
874 : !! kxc(:,1)= d2Exc/drho2
875 : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
876 : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
877 : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
878 : !! kxc(:,5)= gradx(rho)
879 : !! kxc(:,6)= grady(rho)
880 : !! kxc(:,7)= gradz(rho)
881 : !! if nspden>=2:
882 : !! kxc(:,1)= d2Exc/drho_up drho_up
883 : !! kxc(:,2)= d2Exc/drho_up drho_dn
884 : !! kxc(:,3)= d2Exc/drho_dn drho_dn
885 : !! kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
886 : !! kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
887 : !! kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
888 : !! kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
889 : !! kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
890 : !! kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
891 : !! kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
892 : !! kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
893 : !! kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
894 : !! kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
895 : !! kxc(:,14)=gradx(rho_up)
896 : !! kxc(:,15)=gradx(rho_dn)
897 : !! kxc(:,16)=grady(rho_up)
898 : !! kxc(:,17)=grady(rho_dn)
899 : !! kxc(:,18)=gradz(rho_up)
900 : !! kxc(:,19)=gradz(rho_dn)
901 : !! if nspden==4:
902 : !! kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
903 : !! Note about mGGA: 2nd derivatives involving Tau or Laplacian are not output
904 : !! Content of K3xc array:
905 : !! ===== if LDA (xclevel=1) :
906 : !! if nspden==1: return k3xc(:,1)=d3Exc/drho3
907 : !! if nspden>=2, return k3xc(:,1)=d3Exc/drho_up drho_up drho_up
908 : !! k3xc(:,2)=d3Exc/drho_up drho_up drho_dn
909 : !! k3xc(:,3)=d3Exc/drho_up drho_dn drho_dn
910 : !! k3xc(:,4)=d3Exc/drho_dn drho_dn drho_dn
911 : !!
912 : !! SOURCE
913 5973 : subroutine pawxc(corexc,enxc,enxcdc,snxc,hyb_mixing,ixc,kxc,k3xc,lm_size,lmselect,nhat,nkxc,nk3xc,non_magnetic_xc,&
914 3982 : & nrad,nspden,option,pawang,pawrad,rhor,usecore,usexcnhat,vxc,xclevel,xc_denpos,el_temp,&
915 1991 : & coretau,taur,vxctau,xc_taupos,grho1_over_rho1) ! optional arguments
916 :
917 : !Arguments ------------------------------------
918 : !scalars
919 : integer,intent(in) :: ixc,lm_size,nkxc,nk3xc,nrad,nspden,option,usecore,usexcnhat,xclevel
920 : logical,intent(in) :: non_magnetic_xc
921 : real(dp),intent(in) :: el_temp,hyb_mixing,xc_denpos
922 : real(dp),intent(in),optional :: xc_taupos
923 : real(dp),intent(out) :: enxc,enxcdc,snxc
924 : real(dp),intent(out),optional :: grho1_over_rho1
925 : type(pawang_type),intent(in) :: pawang
926 : type(pawrad_type),intent(in) :: pawrad
927 : !arrays
928 : logical,intent(in) :: lmselect(lm_size)
929 : real(dp),intent(in) :: corexc(nrad)
930 : real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2))
931 : real(dp),intent(in),target :: rhor(nrad,lm_size,nspden)
932 : real(dp),intent(in),target,optional:: coretau(:),taur(:,:,:)
933 : real(dp),intent(out) :: kxc(nrad,pawang%angl_size,nkxc)
934 : real(dp),intent(out) :: k3xc(nrad,pawang%angl_size,nk3xc)
935 : real(dp),intent(out),target :: vxc(nrad,pawang%angl_size,nspden)
936 : real(dp),intent(out),target,optional :: vxctau(:,:,:)
937 :
938 : !Local variables-------------------------------
939 : !scalars
940 : integer,parameter :: mu(3,3)=reshape([4,9,8,9,5,7,8,7,6],[3,3]) ! Voigt indices
941 : integer :: ii,ilm,ipts,ir,ispden,iwarn,jj,lm_size_eff,ndvxc,nd2vxc,ngrad
942 : integer :: nkxc_updn,npts,nspden_eff,nspden_updn,nspgrad,nu
943 : integer :: nvxcgrho,nvxclrho,nvxctau,order
944 : integer :: usecoretau,usegradient,usekden,uselaplacian
945 : logical :: need_vxctau,with_taur
946 : real(dp) :: enxcr,snxcr,factor,my_xc_taupos,rhotot,sumg,vxcrho
947 : character(len=500) :: msg
948 : !arrays
949 1991 : real(dp),allocatable :: dgxc(:),dlxc(:),d2lxc(:),dnexcdn(:,:),drho(:),d2rho(:),drhocore(:)
950 1991 : real(dp),allocatable :: vxci(:,:),vxci_grho(:,:),vxci_lrho(:,:),vxci_tau(:,:)
951 1991 : real(dp),allocatable :: dvxci(:,:),d2vxci(:,:),dylmdr(:,:,:)
952 1991 : real(dp),allocatable :: exci(:),tsxci(:),ff(:),grho2_updn(:,:),gxc(:,:,:,:),lxc(:,:,:)
953 1991 : real(dp),allocatable :: rhoarr(:,:),rho_updn(:,:),lrho_updn(:,:),lrhocore(:)
954 1991 : real(dp),allocatable :: tauarr(:,:),tau_updn(:,:),ylmlapl(:,:)
955 1991 : real(dp),allocatable,target :: mag(:,:,:),rhohat(:,:,:),rhonow(:,:,:)
956 1991 : real(dp),pointer :: mag_(:,:),rho_(:,:,:),tau_(:,:,:),vxctau_(:,:,:)
957 1991 : real(dp), LIBPAW_CONTIGUOUS pointer :: vxc_diag(:,:),vxc_nc(:,:),vxc_updn(:,:,:)
958 : #ifdef LIBPAW_ISO_C_BINDING
959 : type(C_PTR) :: cptr
960 : #endif
961 :
962 : ! *************************************************************************
963 :
964 : !----------------------------------------------------------------------
965 : !----- Check options
966 : !----------------------------------------------------------------------
967 :
968 : !Some dimensions
969 3982 : nkxc_updn=merge(nkxc-3,nkxc,nkxc==6.or.nkxc==22)
970 :
971 : !Compatibility tests
972 1991 : if(nspden==4.and.nk3xc>0) then
973 0 : msg='K3xc for nspden=4 not implemented!'
974 0 : LIBPAW_ERROR(msg)
975 : end if
976 1991 : if(nk3xc>0.and.nkxc_updn==0) then
977 0 : msg='nkxc must be non-zero if nk3xc is!'
978 0 : LIBPAW_ERROR(msg)
979 : end if
980 1991 : if(nspden==4.and.xclevel==2.and..not.non_magnetic_xc) then
981 0 : msg='GGA/mGGA for nspden=4 not fully implemented! (only works if usepawu=4 or pawxcdev/=0)'
982 0 : LIBPAW_ERROR(msg)
983 : end if
984 1991 : if(pawang%angl_size==0) then
985 0 : msg='pawang%angl_size=0!'
986 0 : LIBPAW_BUG(msg)
987 : end if
988 1991 : if(.not.allocated(pawang%ylmr)) then
989 0 : msg='pawang%ylmr must be allocated!'
990 0 : LIBPAW_BUG(msg)
991 : end if
992 1991 : if(xclevel==2.and.(.not.allocated(pawang%ylmrgr))) then
993 0 : msg='pawang%ylmrgr must be allocated!'
994 0 : LIBPAW_BUG(msg)
995 : end if
996 1991 : if(option==4.or.option==5) then
997 43 : if (pawang%angl_size/=1) then
998 0 : msg='When option=4 or 5, pawang%angl_size must be 1!'
999 0 : LIBPAW_BUG(msg)
1000 : end if
1001 43 : if (pawang%ylm_size/=1) then
1002 0 : msg='When option=4 or 5, pawang%ylm_size must be 1!'
1003 0 : LIBPAW_BUG(msg)
1004 : end if
1005 43 : if (abs(pawang%anginit(1,1)-one)>tol12.or.abs(pawang%anginit(2,1))>tol12.or. &
1006 : & abs(pawang%anginit(3,1))>tol12) then
1007 0 : msg='When option=4 or 5, pawang%anginit must be (1 0 0)!'
1008 0 : LIBPAW_BUG(msg)
1009 : end if
1010 : end if
1011 1991 : if (option/=1.and.option/=5) then
1012 1767 : if (nrad<pawrad%int_meshsz) then
1013 0 : msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!'
1014 0 : LIBPAW_BUG(msg)
1015 : end if
1016 : end if
1017 :
1018 :
1019 : !----------------------------------------------------------------------
1020 : !----- Initializations
1021 : !----------------------------------------------------------------------
1022 1991 : iwarn=0
1023 1991 : nspden_updn=min(nspden,2)
1024 1991 : nspden_eff=nspden_updn;if (nspden==4.and.xclevel==2) nspden_eff=4
1025 1991 : npts=pawang%angl_size
1026 1991 : lm_size_eff=min(lm_size,pawang%ylm_size)
1027 1991 : ngrad=1;if(xclevel==2)ngrad=2
1028 1991 : nspgrad=0;if (xclevel==2) nspgrad=3*nspden_updn-1
1029 1991 : if (option/=1.and.option/=5) then
1030 1767 : enxc=zero
1031 1767 : snxc=zero
1032 : end if
1033 1991 : if (option==0.or.option==2) enxcdc=zero
1034 547680069 : if (option/=3.and.option/=4) vxc(:,:,:)=zero
1035 216536575 : if (present(vxctau).and.option/=3.and.option/=4) vxctau(:,:,:)=zero
1036 44777967 : if (nkxc>0) kxc(:,:,:)=zero
1037 9987915 : if (nk3xc>0) k3xc(:,:,:)=zero
1038 1991 : order=1;if (nkxc_updn>0) order=2;if (nk3xc>0) order=3 ! to which der. of the energy the computation must be done
1039 1991 : if (present(grho1_over_rho1)) grho1_over_rho1=zero
1040 1991 : my_xc_taupos=xc_denpos;if(present(xc_taupos)) my_xc_taupos=xc_taupos
1041 :
1042 1991 : if (xclevel==0.or.ixc==0) then
1043 0 : msg='Note that no xc is applied (ixc=0).'
1044 0 : LIBPAW_WARNING(msg)
1045 :
1046 : else
1047 :
1048 : ! Determine several flags/sizes defining the XCfunctional
1049 : call pawxc_size_dvxc_wrapper(ixc,order,nspden_updn,&
1050 : & usegradient=usegradient,uselaplacian=uselaplacian,usekden=usekden,&
1051 1991 : & nvxcgrho=nvxcgrho,nvxclrho=nvxclrho,nvxctau=nvxctau,ndvxc=ndvxc,nd2vxc=nd2vxc)
1052 :
1053 : ! Allocation of temporary memory space
1054 9955 : LIBPAW_ALLOCATE(rhonow,(nrad,nspden,ngrad*ngrad+uselaplacian))
1055 7964 : LIBPAW_ALLOCATE(rhoarr,(nrad,nspden))
1056 1991 : if (usexcnhat>0) then
1057 525 : LIBPAW_ALLOCATE(rhohat,(nrad,lm_size,nspden))
1058 8322801 : rhohat(:,:,:)=rhor(:,:,:)+nhat(:,:,:)
1059 : end if
1060 1991 : if (usexcnhat< 2) rho_=> rhor
1061 1991 : if (usexcnhat==2) rho_=> rhohat
1062 1991 : if (option/=3.and.option/=4) then
1063 1948 : if (nspden/=4) then
1064 1750 : vxc_updn => vxc
1065 : else
1066 990 : LIBPAW_POINTER_ALLOCATE(vxc_updn,(nrad,npts,nspden_updn))
1067 990 : LIBPAW_ALLOCATE(mag,(nrad,npts,3))
1068 : end if
1069 : end if
1070 :
1071 : ! Meta-GGA: allocation of temporary space
1072 1991 : with_taur=.false. ; tau_ => null()
1073 1991 : usecoretau=0 ; need_vxctau=.false.
1074 7964 : LIBPAW_ALLOCATE(tauarr,(nrad,nspden*usekden))
1075 1991 : if (usekden==1) then
1076 982 : if (present(taur)) then
1077 968 : with_taur=.true. ; tau_=> taur
1078 3872 : if (size(taur)/=nrad*lm_size*nspden) then
1079 0 : msg='wrong size for taur!'
1080 0 : LIBPAW_BUG(msg)
1081 : end if
1082 : end if
1083 982 : if (present(vxctau)) then
1084 968 : need_vxctau=.true. ; vxctau_ => vxctau
1085 3872 : if (size(vxctau)/=nrad*pawang%angl_size*nspden) then
1086 0 : msg='wrong size for vxctau!'
1087 0 : LIBPAW_BUG(msg)
1088 : end if
1089 14 : else if (option==0.or.option==2) then
1090 : !Need to compute vxctau temporarily
1091 0 : need_vxctau=.true.
1092 0 : LIBPAW_ALLOCATE(vxctau_,(nrad,pawang%angl_size,nspden))
1093 : end if
1094 982 : if (present(coretau)) then
1095 982 : usecoretau=usecore
1096 982 : if (size(coretau)/=nrad) then
1097 0 : msg='wrong size for coretau!'
1098 0 : LIBPAW_BUG(msg)
1099 : end if
1100 : end if
1101 : end if
1102 :
1103 : ! Need derivative of core density for GGA/mGGA
1104 1991 : if (xclevel==2.and.usecore==1) then
1105 3561 : LIBPAW_ALLOCATE(drhocore,(nrad))
1106 1187 : call nderiv_gen(drhocore,corexc,pawrad)
1107 1187 : if (uselaplacian==1) then
1108 452 : LIBPAW_ALLOCATE(lrhocore,(nrad))
1109 452 : LIBPAW_ALLOCATE(d2rho,(nrad))
1110 226 : call nderiv_gen(d2rho,drhocore,pawrad)
1111 315362 : lrhocore(2:nrad)=d2rho(2:nrad)+two*drhocore(2:nrad)/pawrad%rad(2:nrad)
1112 226 : call pawrad_deducer0(lrhocore,nrad,pawrad)
1113 226 : LIBPAW_DEALLOCATE(d2rho)
1114 : end if
1115 : end if
1116 :
1117 : ! Allocation of mandatory arguments of drivexc
1118 5973 : LIBPAW_ALLOCATE(exci,(nrad))
1119 3982 : LIBPAW_ALLOCATE(tsxci,(nrad))
1120 7964 : LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn))
1121 5973 : LIBPAW_ALLOCATE(rho_updn,(nrad,nspden_updn))
1122 :
1123 : ! Allocation of optional arguments of drivexc
1124 7964 : LIBPAW_ALLOCATE(grho2_updn,(nrad,(2*nspden_updn-1)*usegradient))
1125 7964 : LIBPAW_ALLOCATE(lrho_updn,(nrad,nspden_updn*uselaplacian))
1126 7964 : LIBPAW_ALLOCATE(tau_updn,(nrad,nspden_updn*usekden))
1127 7964 : LIBPAW_ALLOCATE(vxci_grho,(nrad,nvxcgrho))
1128 7964 : LIBPAW_ALLOCATE(vxci_lrho,(nrad,nvxclrho))
1129 7964 : LIBPAW_ALLOCATE(vxci_tau,(nrad,nvxctau))
1130 7964 : LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc))
1131 7964 : LIBPAW_ALLOCATE(d2vxci,(nrad,nd2vxc))
1132 7964 : LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad))
1133 :
1134 : ! GGA/mGGA: convert Ylm derivatives from normalized (r_i^hat)
1135 : ! to standard cartesian coordinates (r_i)
1136 : ! dYlm/dr_i = { dYlm/dr_i^hat - r_i^hat * Sum_j[dYlm/dr_j^hat r_j^hat] } * (1/r)
1137 : ! Laplacian: convert Ylm second derivatives from normalized to standard cartesian coordinates
1138 : ! Sum_i[d^2Ylm/dr_i^2] = { Sum_j[dYlm/dr_j^hat r_j^hat]
1139 : ! - Sum_j>k[d^2Ylm/dr_j^hat.dr_k^hat r_j^hat r_k^hat] } * (-2/r^2)
1140 : ! Note that we consider here r=1 (r will be used later)...
1141 1991 : if (xclevel==2) then
1142 5188 : LIBPAW_ALLOCATE(dylmdr,(3,npts,pawang%ylm_size))
1143 38354 : do ilm=1,pawang%ylm_size
1144 5499147 : do ipts=1,npts
1145 21843172 : factor=sum(pawang%ylmrgr(1:3,ilm,ipts)*pawang%anginit(1:3,ipts))
1146 21880229 : dylmdr(1:3,ipts,ilm)=pawang%ylmrgr(1:3,ilm,ipts)-factor*pawang%anginit(1:3,ipts)
1147 : end do
1148 : end do
1149 6485 : LIBPAW_ALLOCATE(gxc,(nrad,3,pawang%ylm_size,nspden_updn))
1150 164423277 : gxc=zero
1151 1297 : if (uselaplacian==1) then
1152 904 : LIBPAW_ALLOCATE(ylmlapl,(npts,pawang%ylm_size))
1153 562918 : ylmlapl(:,:)=zero
1154 3812 : do ilm=1,pawang%ylm_size
1155 562918 : do ipts=1,npts
1156 2240010 : do ii=1,3
1157 : factor=zero
1158 5031954 : do jj=1,ii
1159 3354636 : nu=mu(jj,ii)
1160 5031954 : factor=factor+pawang%ylmrgr(nu,ilm,ipts)*pawang%anginit(jj,ipts)
1161 : end do
1162 : ylmlapl(ipts,ilm)=ylmlapl(ipts,ilm) &
1163 2236424 : & -two*(pawang%ylmrgr(ii,ilm,ipts)+factor)*pawang%anginit(ii,ipts)
1164 : end do
1165 : end do
1166 : end do
1167 1130 : LIBPAW_ALLOCATE(lxc,(nrad,pawang%ylm_size,nspden_updn))
1168 4989800 : lxc=zero
1169 : end if
1170 : end if
1171 :
1172 : ! ----------------------------------------------------------------------
1173 : ! ----- Loop on the angular part and inits
1174 : ! ----------------------------------------------------------------------
1175 :
1176 : ! Do loop on the angular part
1177 297138 : do ipts=1,npts
1178 :
1179 : ! Copy the input density for this (theta,phi)
1180 548043743 : rhoarr(:,:)=zero
1181 763679 : do ispden=1,nspden
1182 9992083 : do ilm=1,lm_size_eff
1183 9696936 : if (lmselect(ilm)) then
1184 : rhoarr(1:nrad,ispden)=rhoarr(1:nrad,ispden) &
1185 8233930068 : & +rho_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts)
1186 : end if
1187 : end do
1188 : end do
1189 295147 : if (usekden==1) then
1190 216712662 : tauarr(:,:)=zero
1191 151022 : if (with_taur) then
1192 302016 : do ispden=1,nspden
1193 3258528 : do ilm=1,lm_size_eff
1194 : tauarr(1:nrad,ispden)=tauarr(1:nrad,ispden) &
1195 4274826192 : & +tau_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts)
1196 : end do
1197 : end do
1198 : end if
1199 : end if
1200 295147 : if (usecore==1) then
1201 345092595 : rhoarr(1:nrad,1)=rhoarr(1:nrad,1)+corexc(1:nrad)
1202 76497759 : if (nspden==2) rhoarr(1:nrad,2)=rhoarr(1:nrad,2)+half*corexc(1:nrad)
1203 : end if
1204 295147 : if (usecoretau==1) then
1205 216561640 : tauarr(1:nrad,1)=tauarr(1:nrad,1)+coretau(1:nrad)
1206 151022 : if (nspden==2) tauarr(1:nrad,2)=tauarr(1:nrad,2)+half*coretau(1:nrad)
1207 : end if
1208 :
1209 : ! Optionally suppress magnetic part
1210 295147 : if (non_magnetic_xc) then
1211 18408 : if(nspden==2) rhoarr(:,2)=rhoarr(:,1)*half
1212 58840392 : if(nspden==4) rhoarr(:,2:4)=zero
1213 18408 : if (usekden==1) then
1214 0 : if(nspden==2) tauarr(:,2)=tauarr(:,1)*half
1215 0 : if(nspden==4) tauarr(:,2:4)=zero
1216 : end if
1217 : endif
1218 :
1219 548043743 : rhonow(1:nrad,1:nspden,1)=rhoarr(1:nrad,1:nspden)
1220 :
1221 : ! GGA: compute gradient (and possibly laplacian) of density
1222 295147 : if (xclevel==2) then
1223 379346 : LIBPAW_ALLOCATE(drho,(nrad))
1224 569019 : LIBPAW_ALLOCATE(d2rho,(nrad*uselaplacian))
1225 379346 : LIBPAW_ALLOCATE(ff,(nrad))
1226 934293872 : rhonow(:,:,2:4+uselaplacian)=zero
1227 418571 : do ispden=1,nspden
1228 5034349 : do ilm=1,lm_size_eff
1229 4844676 : if (lmselect(ilm)) then
1230 4966128770 : ff(1:nrad)=rho_(1:nrad,ilm,ispden)
1231 3777186 : call nderiv_gen(drho,ff,pawrad)
1232 4962351584 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
1233 3777186 : call pawrad_deducer0(ff,nrad,pawrad)
1234 15108744 : do ii=1,3
1235 : rhonow(1:nrad,ispden,1+ii)=rhonow(1:nrad,ispden,1+ii) &
1236 : & +drho(1:nrad)*pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts) &
1237 14902163496 : & +ff(1:nrad)*dylmdr(ii,ipts,ilm)
1238 : end do
1239 3777186 : if (uselaplacian==1) then
1240 115442 : call nderiv_gen(d2rho,drho,pawrad)
1241 160465602 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
1242 115442 : call pawrad_deducer0(ff,nrad,pawrad)
1243 160465602 : drho(2:nrad)=drho(2:nrad)/pawrad%rad(2:nrad)
1244 115442 : call pawrad_deducer0(drho,nrad,pawrad)
1245 : rhonow(1:nrad,ispden,5)=rhonow(1:nrad,ispden,5) &
1246 : & +ff(1:nrad)*ylmlapl(ipts,ilm) &
1247 160581044 : & +(d2rho(1:nrad)+two*drho(1:nrad))*pawang%ylmr(ilm,ipts)
1248 : end if
1249 : end if
1250 : end do
1251 : end do
1252 189673 : LIBPAW_DEALLOCATE(d2rho)
1253 189673 : LIBPAW_DEALLOCATE(drho)
1254 189673 : LIBPAW_DEALLOCATE(ff)
1255 189673 : if (non_magnetic_xc) then
1256 38688 : do ii=1,3
1257 29016 : if(nspden==2) rhonow(1:nrad,2,1+ii)=rhonow(1:nrad,1,1+ii)*half
1258 93005952 : if(nspden==4) rhonow(1:nrad,2:4,1+ii)=zero
1259 : end do
1260 9672 : if (uselaplacian==1) then
1261 0 : if(nspden==2) rhonow(1:nrad,2,5)=rhonow(1:nrad,1,5)*half
1262 0 : if(nspden==4) rhonow(1:nrad,2:4,5)=zero
1263 : end if
1264 : end if
1265 189673 : if (usecore==1) then
1266 705828 : do ii=1,3
1267 : rhonow(1:nrad,1,1+ii)=rhonow(1:nrad,1,1+ii) &
1268 732276252 : & +drhocore(1:nrad)*pawang%anginit(ii,ipts)
1269 : end do
1270 176457 : if (nspden==2) then
1271 20420 : do ii=1,3
1272 : rhonow(1:nrad,2,1+ii)=rhonow(1:nrad,2,1+ii) &
1273 10312208 : & +half*drhocore(1:nrad)*pawang%anginit(ii,ipts)
1274 : end do
1275 : end if
1276 176457 : if (uselaplacian==1) then
1277 48611108 : rhonow(1:nrad,1,5)=rhonow(1:nrad,1,5)+lrhocore(1:nrad)
1278 34946 : if (nspden==2) rhonow(1:nrad,2,5)=rhonow(1:nrad,2,5)+half*lrhocore(1:nrad)
1279 : end if
1280 : end if
1281 : end if
1282 :
1283 : ! Storage of density (and gradient) in (up,dn) format
1284 295147 : if (nspden==1) then
1285 256831738 : rho_updn(1:nrad,1)=rhonow(1:nrad,1,1)*half
1286 183538 : if (xclevel==2) grho2_updn(1:nrad,1)= &
1287 239904456 : & quarter*(rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2)
1288 216594156 : if (usekden==1) tau_updn(1:nrad,1)=tauarr(1:nrad,1)*half
1289 48759700 : if (uselaplacian==1) lrho_updn(1:nrad,1)=rhonow(1:nrad,1,5)*half
1290 111609 : else if (nspden==2) then
1291 79736253 : rho_updn(1:nrad,1)=rhonow(1:nrad,2,1)
1292 79736253 : rho_updn(1:nrad,2)=rhonow(1:nrad,1,1)-rhonow(1:nrad,2,1)
1293 80721 : if (xclevel==2) then
1294 6869901 : grho2_updn(1:nrad,1)=rhonow(1:nrad,2,2)**2+rhonow(1:nrad,2,3)**2+rhonow(1:nrad,2,4)**2
1295 : grho2_updn(1:nrad,2)=(rhonow(1:nrad,1,2)-rhonow(1:nrad,2,2))**2 + &
1296 : & (rhonow(1:nrad,1,3)-rhonow(1:nrad,2,3))**2 + &
1297 6869901 : & (rhonow(1:nrad,1,4)-rhonow(1:nrad,2,4))**2
1298 6869901 : grho2_updn(1:nrad,3)=rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2
1299 : end if
1300 80721 : if (usekden==1) then
1301 0 : tau_updn(1:nrad,1)=tauarr(1:nrad,2)
1302 0 : tau_updn(1:nrad,2)=tauarr(1:nrad,1)-tauarr(1:nrad,2)
1303 : end if
1304 80721 : if (uselaplacian==1) then
1305 0 : lrho_updn(1:nrad,1)=rhonow(1:nrad,2,5)
1306 0 : lrho_updn(1:nrad,2)=rhonow(1:nrad,1,5)-rhonow(1:nrad,2,5)
1307 : end if
1308 30888 : else if (nspden==4) then
1309 30888 : mag_ => rhonow(1:nrad,2:4,1)
1310 197197416 : mag(1:nrad,ipts,1:3)=mag_(1:nrad,1:3)
1311 30888 : call pawxc_rotate_mag(rhonow(:,:,1),rho_updn,mag_,nrad) ! Note : gradients are not computed there
1312 30888 : if (non_magnetic_xc.and.xclevel==2) then ! In this case grho2_updn is easy to compute
1313 10329696 : grho2_updn(1:nrad,1)=quarter*(rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2)
1314 10329696 : grho2_updn(1:nrad,2)=grho2_updn(1:nrad,1)
1315 10329696 : grho2_updn(1:nrad,3)=rhonow(1:nrad,1,2)**2+rhonow(1:nrad,1,3)**2+rhonow(1:nrad,1,4)**2
1316 : end if
1317 : end if
1318 :
1319 : ! Make the density positive everywhere (but do not care about gradients)
1320 295147 : call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rho_updn,xc_denpos)
1321 295147 : if (usekden==1) then
1322 151022 : call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,tau_updn,my_xc_taupos)
1323 : end if
1324 :
1325 : ! Call to main XC driver
1326 : call pawxc_drivexc_wrapper(hyb_mixing,ixc,order,nrad,nspden_updn,&
1327 : & usegradient,uselaplacian,usekden,rho_updn,exci,tsxci,vxci,&
1328 : & nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp,&
1329 : & grho2=grho2_updn,vxcgrho=vxci_grho,&
1330 : & lrho=lrho_updn,vxclrho=vxci_lrho,&
1331 : & tau=tau_updn,vxctau=vxci_tau,&
1332 590294 : & dvxc=dvxci,d2vxc=d2vxci)
1333 :
1334 : ! If fake meta-GGA, has to remove the core contribution
1335 : ! when electronic effective mass has been modified
1336 295147 : if (usecoretau==1.and.(ixc==31.or.ixc==35)) then
1337 : if (ixc==31.or.ixc==35) then
1338 0 : factor=one-(one/1.01_dp)
1339 0 : if (nspden_updn==1) then
1340 0 : factor=factor*half
1341 0 : do ii=1,nrad
1342 0 : exci(ii)=exci(ii)-factor*coretau(ii)/rho_updn(ii,1)
1343 : end do
1344 : else
1345 0 : do ii=1,nrad
1346 0 : exci(ii)=exci(ii)-factor*coretau(ii)/(rho_updn(ii,1)+rho_updn(ii,2))
1347 : end do
1348 : end if
1349 : else
1350 : msg='MetaGGA ixc=34 is not yet allowed with a core kinetic energy density!'
1351 : LIBPAW_ERROR(msg)
1352 : end if
1353 : end if
1354 :
1355 : ! ----------------------------------------------------------------------
1356 : ! ----- Store XC kernel and its derivative
1357 : ! ----------------------------------------------------------------------
1358 295147 : if (nkxc_updn>0.and.ndvxc>0) then
1359 9520 : if (nkxc_updn==1.and.ndvxc==15) then
1360 0 : kxc(1:nrad,ipts,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10))
1361 9520 : else if (nkxc_updn==3.and.ndvxc==15) then
1362 0 : kxc(1:nrad,ipts,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9)
1363 0 : kxc(1:nrad,ipts,2)=dvxci(1:nrad,10)
1364 0 : kxc(1:nrad,ipts,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11)
1365 9520 : else if (nkxc_updn==7.and.ndvxc==8) then
1366 0 : kxc(1:nrad,ipts,1)=half*dvxci(1:nrad,1)
1367 0 : kxc(1:nrad,ipts,2)=half*dvxci(1:nrad,3)
1368 0 : kxc(1:nrad,ipts,3)=quarter*dvxci(1:nrad,5)
1369 0 : kxc(1:nrad,ipts,4)=eighth*dvxci(1:nrad,7)
1370 2496 : else if (nkxc_updn==7.and.ndvxc==15) then
1371 3072576 : kxc(1:nrad,ipts,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10))
1372 3072576 : kxc(1:nrad,ipts,2)=half*dvxci(1:nrad,3)+dvxci(1:nrad,12)
1373 3072576 : kxc(1:nrad,ipts,3)=quarter*dvxci(1:nrad,5)+dvxci(1:nrad,13)
1374 3072576 : kxc(1:nrad,ipts,4)=eighth*dvxci(1:nrad,7)+dvxci(1:nrad,15)
1375 7024 : else if (nkxc_updn==19.and.ndvxc==15) then
1376 133040 : kxc(1:nrad,ipts,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9)
1377 133040 : kxc(1:nrad,ipts,2)=dvxci(1:nrad,10)
1378 133040 : kxc(1:nrad,ipts,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11)
1379 133040 : kxc(1:nrad,ipts,4)=dvxci(1:nrad,3)
1380 133040 : kxc(1:nrad,ipts,5)=dvxci(1:nrad,4)
1381 133040 : kxc(1:nrad,ipts,6)=dvxci(1:nrad,5)
1382 133040 : kxc(1:nrad,ipts,7)=dvxci(1:nrad,6)
1383 133040 : kxc(1:nrad,ipts,8)=dvxci(1:nrad,7)
1384 133040 : kxc(1:nrad,ipts,9)=dvxci(1:nrad,8)
1385 133040 : kxc(1:nrad,ipts,10)=dvxci(1:nrad,12)
1386 133040 : kxc(1:nrad,ipts,11)=dvxci(1:nrad,13)
1387 133040 : kxc(1:nrad,ipts,12)=dvxci(1:nrad,14)
1388 133040 : kxc(1:nrad,ipts,13)=dvxci(1:nrad,15)
1389 : else ! Other cases
1390 20746752 : kxc(1:nrad,ipts,1:nkxc)=zero
1391 20746752 : kxc(1:nrad,ipts,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc))
1392 : end if
1393 9520 : if (nkxc_updn==7) then
1394 3072576 : kxc(1:nrad,ipts,5)=rhonow(1:nrad,1,2)
1395 3072576 : kxc(1:nrad,ipts,6)=rhonow(1:nrad,1,3)
1396 3072576 : kxc(1:nrad,ipts,7)=rhonow(1:nrad,1,4)
1397 7024 : else if (nkxc_updn==19) then
1398 133040 : kxc(1:nrad,ipts,14)=rhonow(1:nrad,1,2)
1399 133040 : kxc(1:nrad,ipts,15)=rhonow(1:nrad,2,2)
1400 133040 : kxc(1:nrad,ipts,16)=rhonow(1:nrad,1,3)
1401 133040 : kxc(1:nrad,ipts,17)=rhonow(1:nrad,2,3)
1402 133040 : kxc(1:nrad,ipts,18)=rhonow(1:nrad,1,4)
1403 133040 : kxc(1:nrad,ipts,19)=rhonow(1:nrad,2,4)
1404 : end if
1405 : end if
1406 295147 : if (nkxc>=nkxc_updn+3) then
1407 0 : kxc(1:nrad,ipts,nkxc_updn+1)=rhonow(1:nrad,2,1)
1408 0 : kxc(1:nrad,ipts,nkxc_updn+2)=rhonow(1:nrad,3,1)
1409 0 : kxc(1:nrad,ipts,nkxc_updn+3)=rhonow(1:nrad,4,1)
1410 : end if
1411 :
1412 : ! kernel derivative :
1413 295147 : if (nk3xc>0.and.nd2vxc>0) then
1414 9988368 : k3xc(1:nrad,ipts,1:min(nk3xc,nd2vxc))=d2vxci(1:nrad,1:min(nk3xc,nd2vxc))
1415 : end if
1416 :
1417 : ! ----------------------------------------------------------------------
1418 : ! ----- Store derivative of Exc wrt kinetic energy density
1419 : ! ----------------------------------------------------------------------
1420 295147 : if (need_vxctau) then
1421 302016 : do ispden=1,nspden_updn
1422 216684624 : vxctau_(1:nrad,ipts,ispden)=vxci_tau(1:nrad,ispden)
1423 : end do
1424 : end if
1425 :
1426 : ! ----------------------------------------------------------------------
1427 : ! ----- Accumulate and store XC potential
1428 : ! ----------------------------------------------------------------------
1429 :
1430 295147 : if (option/=3.and.option/=4) then
1431 :
1432 701816 : do ispden=1,nspden_updn
1433 482247896 : vxc_updn(1:nrad,ipts,ispden)=vxci(1:nrad,ispden)
1434 : end do
1435 :
1436 : ! For GGAs, additional terms appear
1437 295104 : if (xclevel==2.and.ixc/=13)then
1438 274447784 : dnexcdn(1:nrad,1:nspden_updn)=vxci(1:nrad,1:nspden_updn)
1439 : ! Treat explicitely spin up, spin down and total spin for spin-polarized
1440 419056 : do ii=1,3
1441 399176 : if(nspden_updn==1.and.ii>=2)exit !exit when ii=1 is finished if non-spin-polarized
1442 291645880 : do ir=1,nrad
1443 : ! If the norm of the gradient vanishes, then the different terms vanishes
1444 291226824 : if(grho2_updn(ir,ii)<1.0d-24) then
1445 0 : dnexcdn(ir,ii+nspden_updn)=zero;cycle
1446 : end if
1447 : ! Compute the derivative of n.e_xc wrt spin up, spin down, or total density
1448 291456232 : if(nspden_updn==1)then
1449 239692176 : dnexcdn(ir,ii+nspden_updn)=half*vxci_grho(ir,1) !Definition of vxci_grho changed in v3.3
1450 239692176 : if (nvxcgrho==3) dnexcdn(ir,ii+nspden_updn)=dnexcdn(ir,ii+nspden_updn)+vxci_grho(ir,3)
1451 51534648 : else if(nspden_updn==2)then
1452 51534648 : if (nvxcgrho==3) then
1453 51534648 : dnexcdn(ir,ii+nspden_updn)=vxci_grho(ir,ii)
1454 0 : else if (ii/=3) then
1455 0 : dnexcdn(ir,ii+nspden_updn)=vxci_grho(ir,ii)
1456 : else if (ii==3) then
1457 0 : dnexcdn(ir,ii+nspden_updn)=zero
1458 : end if
1459 : end if
1460 : end do
1461 : end do
1462 189648 : call pawxc_xcmult_wrapper(dnexcdn,nrad,ngrad,nspden_eff,nspgrad,rhonow)
1463 189648 : factor=one;if (nspden_updn==1) factor=half
1464 189648 : if (option/=4.and.option/=5) then
1465 189648 : factor=factor*four_pi
1466 : ! Accumulate moments of gxc=1/grad(rho).dVxc/dgrad(rho)
1467 399176 : do ispden=1,nspden_updn
1468 6575624 : do ilm=1,pawang%ylm_size
1469 24915320 : do ii=1,3
1470 : gxc(1:nrad,ii,ilm,ispden)=gxc(1:nrad,ii,ilm,ispden)+rhonow(1:nrad,ispden,1+ii) &
1471 24035944896 : & *pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor
1472 : end do
1473 : end do
1474 : end do
1475 : else
1476 0 : do ispden=1,nspden_updn
1477 0 : gxc(1:nrad,1,1,ispden)=factor*rhonow(1:nrad,ispden,2)
1478 : end do
1479 : end if
1480 : end if
1481 :
1482 : ! For laplacian-dependent functionals, additional terms appear
1483 295104 : if (xclevel==2.and.uselaplacian==1) then
1484 34944 : factor=one;if (nspden_updn==1) factor=half
1485 34944 : if (option/=4.and.option/=5) then
1486 34944 : factor=factor*four_pi
1487 : ! Accumulate moments of lxc=dVxc/dlaplacian(rho)
1488 69888 : do ispden=1,nspden_updn
1489 628992 : do ilm=1,pawang%ylm_size
1490 : lxc(1:nrad,ilm,ispden)=lxc(1:nrad,ilm,ispden)+vxci_lrho(1:nrad,ispden) &
1491 777748608 : & *pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor
1492 : end do
1493 : end do
1494 : else
1495 0 : do ispden=1,nspden_updn
1496 0 : lxc(1:nrad,1,ispden)=factor*vxci_lrho(1:nrad,ispden)
1497 : end do
1498 : end if
1499 : end if
1500 :
1501 : end if !option
1502 :
1503 : ! ----------------------------------------------------------------------
1504 : ! ----- Accumulate and store XC energy
1505 : ! ----------------------------------------------------------------------
1506 295147 : if (option/=1.and.option/=5) then
1507 521334 : LIBPAW_ALLOCATE(ff,(nrad))
1508 324607031 : ff(1:nrad)=rhoarr(1:nrad,1)*exci(1:nrad)*pawrad%rad(1:nrad)**2
1509 260667 : call simp_gen(enxcr,ff,pawrad)
1510 260667 : if (option/=4) enxc=enxc+enxcr*pawang%angwgth(ipts)
1511 260667 : if (option==4) enxc=enxc+enxcr
1512 521334 : LIBPAW_DEALLOCATE(ff)
1513 : end if
1514 :
1515 : ! ----------------------------------------------------------------------
1516 : ! ----- Accumulate and store XC entropy (for finite-temperature xc functionals)
1517 : ! ----------------------------------------------------------------------
1518 295147 : if (option/=1.and.option/=5) then
1519 521334 : LIBPAW_ALLOCATE(ff,(nrad))
1520 324607031 : ff(1:nrad)=rhoarr(1:nrad,1)*tsxci(1:nrad)*pawrad%rad(1:nrad)**2
1521 260667 : call simp_gen(snxcr,ff,pawrad)
1522 260667 : if (option/=4) snxc=snxc+snxcr*pawang%angwgth(ipts)/el_temp
1523 260667 : if (option==4) snxc=snxc+snxcr/el_temp
1524 521334 : LIBPAW_DEALLOCATE(ff)
1525 : end if
1526 :
1527 : ! ----------------------------------------------------------------------
1528 : ! ----- Accumulate integral of |Grad_rho|/Rho (to be used for TB09 XC)
1529 : ! ----------------------------------------------------------------------
1530 297138 : if (present(grho1_over_rho1).and.pawxc_is_tb09(ixc).and.option<4) then
1531 0 : LIBPAW_ALLOCATE(ff,(nrad))
1532 0 : if (nspden_updn==1) then
1533 0 : do ir=1,nrad
1534 0 : rhotot=two*rho_updn(ir,1)
1535 0 : if (abs(rhotot)>tol10) ff(ir)=sqrt(four*grho2_updn(ir,1))/rhotot
1536 : end do
1537 : else ! nspden_updn=2
1538 0 : do ir=1,nrad
1539 0 : rhotot=rho_updn(ir,1)+rho_updn(ir,2)
1540 0 : if (abs(rhotot)>tol10) ff(ir)=sqrt(grho2_updn(ir,3))/rhotot
1541 : end do
1542 : end if
1543 0 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
1544 0 : call simp_gen(sumg,ff,pawrad)
1545 0 : grho1_over_rho1=grho1_over_rho1+sumg*four_pi*pawang%angwgth(ipts)
1546 0 : LIBPAW_DEALLOCATE(ff)
1547 : end if
1548 :
1549 : ! ----------------------------------------------------------------------
1550 : ! ----- End of the loop on npts (angular part)
1551 : ! ----------------------------------------------------------------------
1552 : end do
1553 :
1554 : ! Deallocate temporary memory space
1555 1991 : LIBPAW_DEALLOCATE(exci)
1556 1991 : LIBPAW_DEALLOCATE(tsxci)
1557 1991 : LIBPAW_DEALLOCATE(vxci)
1558 1991 : LIBPAW_DEALLOCATE(rho_updn)
1559 1991 : LIBPAW_DEALLOCATE(tau_updn)
1560 1991 : LIBPAW_DEALLOCATE(lrho_updn)
1561 1991 : LIBPAW_DEALLOCATE(dvxci)
1562 1991 : LIBPAW_DEALLOCATE(d2vxci)
1563 1991 : LIBPAW_DEALLOCATE(vxci_grho)
1564 1991 : LIBPAW_DEALLOCATE(vxci_lrho)
1565 1991 : LIBPAW_DEALLOCATE(vxci_tau)
1566 1991 : LIBPAW_DEALLOCATE(grho2_updn)
1567 1991 : LIBPAW_DEALLOCATE(dnexcdn)
1568 1991 : LIBPAW_DEALLOCATE(rhonow)
1569 1991 : if (allocated(drhocore)) then
1570 1187 : LIBPAW_DEALLOCATE(drhocore)
1571 : end if
1572 1991 : if (allocated(lrhocore)) then
1573 226 : LIBPAW_DEALLOCATE(lrhocore)
1574 : end if
1575 :
1576 : ! ----------------------------------------------------------------------
1577 : ! ----- If GGA, modify potential with term from density gradient
1578 : ! ----------------------------------------------------------------------
1579 1991 : if (option/=3.and.option/=4.and.xclevel==2.and.ixc/=13) then
1580 : ! Compute divergence of gxc and substract it from Vxc
1581 2544 : LIBPAW_ALLOCATE(dgxc,(nrad))
1582 : ! Need to multiply gxc by 2 in the non-polarised case
1583 1272 : factor=one;if (nspden_updn==1) factor=two
1584 1272 : if (option/=4.and.option/=5) then
1585 2544 : LIBPAW_ALLOCATE(ff,(nrad))
1586 2722 : do ispden=1,nspden_updn
1587 46162 : do ilm=1,pawang%ylm_size
1588 175210 : do ii=1,3
1589 164240496 : ff(1:nrad)=gxc(1:nrad,ii,ilm,ispden)
1590 130320 : call nderiv_gen(dgxc,ff,pawrad)
1591 164110176 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
1592 130320 : call pawrad_deducer0(ff,nrad,pawrad)
1593 18703104 : do ipts=1,npts
1594 : vxc_updn(1:nrad,ipts,ispden)=vxc_updn(1:nrad,ipts,ispden) &
1595 : & -factor*(dgxc(1:nrad)*pawang%anginit(ii,ipts)*pawang%ylmr(ilm,ipts) &
1596 24029898768 : & +ff(1:nrad)*dylmdr(ii,ipts,ilm))
1597 : end do
1598 : end do
1599 : end do
1600 : end do
1601 1272 : LIBPAW_DEALLOCATE(ff)
1602 : else ! option==4 or option==5
1603 0 : do ispden=1,nspden_updn
1604 0 : call nderiv_gen(dgxc,gxc(:,1,1,ispden),pawrad)
1605 : vxc_updn(2:nrad,1,ispden)=vxc_updn(2:nrad,1,ispden) &
1606 0 : & -factor*(dgxc(2:nrad)+two*gxc(2:nrad,1,1,ispden)/pawrad%rad(2:nrad))
1607 0 : call pawrad_deducer0(vxc(:,1,ispden),nrad,pawrad)
1608 : end do
1609 : end if
1610 1272 : LIBPAW_DEALLOCATE(dgxc)
1611 : end if ! GGA
1612 :
1613 : ! ----------------------------------------------------------------------
1614 : ! ----- If mGGA, modify potential with term from density laplacian
1615 : ! ----------------------------------------------------------------------
1616 1991 : if (option/=3.and.option/=4.and.xclevel==2.and.uselaplacian==1.and.ixc/=13) then
1617 : ! Compute laplacian of lxc and add it to Vxc
1618 448 : LIBPAW_ALLOCATE(dlxc,(nrad))
1619 448 : LIBPAW_ALLOCATE(d2lxc,(nrad))
1620 : ! Need to multiply lxc by 2 in the non-polarised case
1621 224 : factor=one;if (nspden_updn==1) factor=two
1622 224 : if (option/=4.and.option/=5) then
1623 672 : LIBPAW_ALLOCATE(ff,(nrad))
1624 448 : do ispden=1,nspden_updn
1625 4032 : do ilm=1,pawang%ylm_size
1626 4985344 : ff(1:nrad)=lxc(1:nrad,ilm,ispden)
1627 3584 : call nderiv_gen(dlxc,ff,pawrad)
1628 3584 : call nderiv_gen(d2lxc,dlxc,pawrad)
1629 4981760 : ff(2:nrad)=ff(2:nrad)/(pawrad%rad(2:nrad)**2)
1630 3584 : call pawrad_deducer0(ff,nrad,pawrad)
1631 4981760 : dlxc(2:nrad)=dlxc(2:nrad)/pawrad%rad(2:nrad)
1632 3584 : call pawrad_deducer0(dlxc,nrad,pawrad)
1633 562912 : do ipts=1,npts
1634 : vxc_updn(1:nrad,ipts,ispden)=vxc_updn(1:nrad,ipts,ispden) &
1635 : & +factor*(ff(1:nrad)*ylmlapl(ipts,ilm) &
1636 777717248 : & +(d2lxc(1:nrad)+two*dlxc(1:nrad))*pawang%ylmr(ilm,ipts))
1637 : end do
1638 : end do
1639 : end do
1640 224 : LIBPAW_DEALLOCATE(ff)
1641 : else ! option==4 or option==5
1642 0 : do ispden=1,nspden_updn
1643 0 : call nderiv_gen(dlxc,lxc(:,1,ispden),pawrad)
1644 0 : call nderiv_gen(d2lxc,dlxc,pawrad)
1645 : vxc_updn(2:nrad,1,ispden)=vxc_updn(2:nrad,1,ispden) &
1646 0 : & +factor*(d2lxc(2:nrad)+two*dlxc(2:nrad)/pawrad%rad(2:nrad))
1647 0 : call pawrad_deducer0(vxc(:,1,ispden),nrad,pawrad)
1648 : end do
1649 : end if
1650 224 : LIBPAW_DEALLOCATE(dlxc)
1651 224 : LIBPAW_DEALLOCATE(d2lxc)
1652 : end if ! mGGA
1653 :
1654 : ! ----------------------------------------------------------------------
1655 : ! ----- If non-collinear, rotate back potential according to magnetization
1656 : ! ----------------------------------------------------------------------
1657 1991 : if (option/=3.and.option/=4.and.nspden==4) then
1658 : ! Use of C pointers to avoid copies (when ISO C bindings are available)
1659 : ! %@1$ xlf v15 compiler requires a auxilliary cptr variable
1660 : #ifdef LIBPAW_ISO_C_BINDING
1661 198 : cptr=c_loc(vxc_updn(1,1,1))
1662 198 : call c_f_pointer(cptr,vxc_diag,shape=[nrad*npts,nspden_updn])
1663 198 : cptr=c_loc(vxc(1,1,1))
1664 198 : call c_f_pointer(cptr,vxc_nc,shape=[nrad*npts,nspden])
1665 198 : cptr=c_loc(mag(1,1,1))
1666 594 : call c_f_pointer(cptr,mag_,shape=[nrad*npts,3])
1667 : #else
1668 : LIBPAW_ALLOCATE(vxc_diag,(nrad*npts,nspden_updn))
1669 : LIBPAW_ALLOCATE(vxc_nc,(nrad*npts,nspden))
1670 : LIBPAW_ALLOCATE(mag_,(nrad*npts,3))
1671 : vxc_diag=reshape(vxc_updn,[nrad*npts,nspden_updn])
1672 : mag_=reshape(mag,[nrad*npts,3])
1673 : #endif
1674 396 : call pawxc_rotate_back_mag(vxc_diag,vxc_nc,mag_,nrad*npts)
1675 : #ifndef LIBPAW_ISO_C_BINDING
1676 : vxc=reshape(vxc_nc,[nrad,npts,nspden])
1677 : LIBPAW_DEALLOCATE(vxc_diag)
1678 : LIBPAW_DEALLOCATE(mag_)
1679 : LIBPAW_DEALLOCATE(vxc_nc)
1680 : #endif
1681 198 : LIBPAW_POINTER_DEALLOCATE(vxc_updn)
1682 198 : LIBPAW_DEALLOCATE(mag)
1683 : end if
1684 :
1685 : ! ----------------------------------------------------------------------
1686 : ! ----- Accumulate and store XC double-counting energy
1687 : ! ----------------------------------------------------------------------
1688 1991 : if (option==0.or.option==2) then
1689 5172 : LIBPAW_ALLOCATE(ff,(nrad))
1690 262348 : do ipts=1,npts ! Do loop on the angular part
1691 : ! Compute density for this (theta,phi)
1692 492437712 : rhoarr(:,:)=zero
1693 260624 : if (usexcnhat==0) rho_=>rhor
1694 260624 : if (usexcnhat/=0) rho_=>rhohat
1695 685424 : do ispden=1,nspden
1696 9485520 : do ilm=1,lm_size_eff
1697 9224896 : if (lmselect(ilm)) then
1698 7978199920 : rhoarr(1:nrad,ispden)=rhoarr(1:nrad,ispden)+rho_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts)
1699 : end if
1700 : end do
1701 : end do
1702 : ! Compute kinetic energy density for this (theta,phi)
1703 260624 : if (with_taur.and.need_vxctau) then
1704 190627008 : tauarr(:,:)=zero
1705 264576 : do ispden=1,nspden
1706 3052608 : do ilm=1,lm_size_eff
1707 : tauarr(1:nrad,ispden)=tauarr(1:nrad,ispden) &
1708 4040457408 : & +tau_(1:nrad,ilm,ispden)*pawang%ylmr(ilm,ipts)
1709 : end do
1710 : end do
1711 : end if
1712 : ! Compute integral of Vxc*rho
1713 260624 : if (nspden/=4) then
1714 291673816 : ff(:)=vxc(:,ipts,1)*rhoarr(:,nspden)
1715 69217144 : if (nspden==2) ff(:)=ff(:)+vxc(:,ipts,2)*(rhoarr(:,1)-rhoarr(:,2))
1716 : else
1717 : ff(:)=half*(vxc(:,ipts,1)*(rhoarr(:,1)+rhoarr(:,4)) &
1718 : +vxc(:,ipts,2)*(rhoarr(:,1)-rhoarr(:,4))) &
1719 32861088 : & +vxc(:,ipts,3)*rhoarr(:,2)-vxc(:,ipts,4)*rhoarr(:,3)
1720 : end if
1721 : ! Possibly add integral of Vxctau*tau
1722 260624 : if (with_taur.and.need_vxctau) then
1723 190494720 : ff(:)=ff(:)+vxctau_(:,ipts,1)*tauarr(:,nspden)
1724 132288 : if (nspden==2) ff(:)=ff(:)+vxctau_(:,ipts,2)*(tauarr(:,1)-tauarr(:,2))
1725 : end if
1726 324534904 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
1727 260624 : call simp_gen(vxcrho,ff,pawrad)
1728 262348 : enxcdc=enxcdc+vxcrho*pawang%angwgth(ipts)
1729 : end do ! End of the loop on npts (angular part)
1730 1724 : LIBPAW_DEALLOCATE(ff)
1731 : end if ! option
1732 :
1733 : ! ----------------------------------------------------------------------
1734 : ! ----- End
1735 : ! ----------------------------------------------------------------------
1736 : ! Add the four*pi factor of the Exc, Sxc and Excdc angular integration
1737 1991 : if (option/=1.and.option/=5) enxc=enxc*four_pi
1738 1991 : if (option/=1.and.option/=5) snxc=snxc*four_pi
1739 1991 : if (option==0.or.option==2) enxcdc=enxcdc*four_pi
1740 :
1741 : !TESTDEBUG
1742 : ! Compute difference between fake mGGA=32 Exc=Int[Grad[rho]**2.dr]
1743 : ! and mGGA=33 Exc=-Int[Laplacian[rho]*rho.dr]
1744 : ! i.e. contour integral Int_contour[rho.Grad[rho].DS]=rc^2.Sum_L[rho_L(rc)*drho_L(rc)]
1745 : ! if (option<4) then
1746 : ! enxcr=zero
1747 : ! ir=pawrad%int_meshsz
1748 : ! LIBPAW_ALLOCATE(drho,(nrad))
1749 : ! LIBPAW_ALLOCATE(ff,(nrad))
1750 : ! enxcr=zero
1751 : ! do ilm=1,lm_size_eff
1752 : ! ff(1:nrad)=rho_(1:nrad,ilm,1)
1753 : ! call nderiv_gen(drho,ff,pawrad)
1754 : ! enxcr=enxcr+ff(ir)*drho(ir)
1755 : ! end do
1756 : ! LIBPAW_DEALLOCATE(drho)
1757 : ! LIBPAW_DEALLOCATE(ff)
1758 : ! enxcr=enxcr*0.01_dp*pawrad%rad(ir)**2
1759 : ! write(100,*) "Contour integral=",enxcr
1760 : ! end if
1761 :
1762 : ! Final memory deallocation
1763 1991 : LIBPAW_DEALLOCATE(rhoarr)
1764 1991 : LIBPAW_DEALLOCATE(tauarr)
1765 1991 : if (usexcnhat>0) then
1766 105 : LIBPAW_DEALLOCATE(rhohat)
1767 : end if
1768 1991 : if (xclevel==2) then
1769 1297 : LIBPAW_DEALLOCATE(gxc)
1770 1297 : LIBPAW_DEALLOCATE(dylmdr)
1771 1297 : if (uselaplacian==1) then
1772 226 : LIBPAW_DEALLOCATE(lxc)
1773 226 : LIBPAW_DEALLOCATE(ylmlapl)
1774 : end if
1775 : end if
1776 3982 : if (usekden==1.and.(.not.present(vxctau)).and.(option==0.or.option==2)) then
1777 0 : LIBPAW_DEALLOCATE(vxctau_)
1778 : end if
1779 :
1780 : ! ------------------------------------
1781 : ! End IF a xc part has to be computed
1782 : end if
1783 :
1784 3982 : end subroutine pawxc
1785 : !!***
1786 :
1787 : !----------------------------------------------------------------------
1788 :
1789 : !!****f* m_pawxc/pawxcpositron
1790 : !! NAME
1791 : !! pawxcpositron
1792 : !!
1793 : !! FUNCTION
1794 : !! Compute electron-positron correlation potential and energies inside a PAW sphere
1795 : !! LDA ONLY - USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi)
1796 : !! Driver of XC functionals.
1797 : !!
1798 : !! INPUTS
1799 : !! calctype=type of electronpositron calculation:
1800 : !! calctype=1 : positron in electronic density
1801 : !! calctype=2 : electrons in positronic density
1802 : !! corexc(nrad)=electron core density on radial grid
1803 : !! ixcpositron=choice of electron-positron XC scheme
1804 : !! lm_size=size of density array rhor (see below)
1805 : !! lmselect (lm_size)=select the non-zero LM-moments of input density rhor (see below)
1806 : !! lmselect_ep(lm_size)=select the non-zero LM-moments of input density rhor_ep (see below)
1807 : !! nhat (nrad,lm_size,nspden)=compensation density corresponding to rhor
1808 : !! nhat_ep(nrad,lm_size,nspden)=compensation density corresponding to rhor_ep
1809 : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
1810 : !! nspden=number of spin-density components
1811 : !! option=0 compute both XC energies (direct+double-counting) and potential
1812 : !! 1 compute only XC potential
1813 : !! 2 compute only XC energies (direct+double-counting)
1814 : !! 3 compute only XC energy by direct scheme
1815 : !! 4 compute only XC energy by direct scheme for spherical part of the density
1816 : !! pawang <type(pawang_type)>=paw angular mesh and related data
1817 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
1818 : !! posdensity0_limit=True if we are in the zero positron density limit
1819 : !! rhor(nrad,lm_size,nspden)=electron (or positron) density in real space
1820 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
1821 : !! Contents depends on calctype value:
1822 : !! calctype=1: rhor is the positronic density
1823 : !! calctype=2: rhor is the electronic density
1824 : !! rhor_ep(nrad,lm_size,nspden)=electron (or positron) density in real space
1825 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
1826 : !! Contents depends on calctype value:
1827 : !! calctype=1: rhor_ep is the electronic density
1828 : !! calctype=2: rhor_ep is the positronic density
1829 : !! usecore= 1 if core density has to be used in Exc/Vxc for the electronic density ; 0 otherwise
1830 : !! usexcnhat= 0 if compensation density does not have to be used
1831 : !! 1 if compensation density has to be used in double counting energy term only
1832 : !! 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
1833 : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
1834 : !!
1835 : !! OUTPUT
1836 : !! == if option==0, 2, 3, or 4 ==
1837 : !! enxc=returned exchange and correlation energy (hartree)
1838 : !! == if option==0 or 2 ==
1839 : !! enxcdc=returned exchange-cor. contribution to double-counting energy
1840 : !! == if option==0 or 1 ==
1841 : !! vxc(nrad,pawang%angl_size,nspden)=xc potential
1842 : !! (spin up in 1st half and spin-down in 2nd half if nspden=2)
1843 : !!
1844 : !! SIDE EFFECTS
1845 : !! electronpositron <type(electronpositron_type)>=quantities for the electron-positron annihilation
1846 : !!
1847 : !! SOURCE
1848 :
1849 0 : subroutine pawxcpositron(calctype,corexc,enxc,enxcdc,ixcpositron,lm_size,lmselect,lmselect_ep,&
1850 0 : & nhat,nhat_ep,nrad,nspden,option,pawang,pawrad,posdensity0_limit,&
1851 0 : & rhor,rhor_ep,usecore,usexcnhat,vxc,xc_denpos)
1852 :
1853 : !Arguments ------------------------------------
1854 : !scalars
1855 : integer,intent(in) :: calctype,ixcpositron,lm_size,nrad,nspden,option,usecore,usexcnhat
1856 : logical,intent(in) :: posdensity0_limit
1857 : real(dp),intent(in) :: xc_denpos
1858 : real(dp),intent(out) :: enxc,enxcdc
1859 : type(pawang_type),intent(in) :: pawang
1860 : type(pawrad_type),intent(in) :: pawrad
1861 : !arrays
1862 : logical,intent(in) :: lmselect(lm_size),lmselect_ep(lm_size)
1863 : real(dp),intent(in) :: corexc(nrad)
1864 : real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2))
1865 : real(dp),intent(in) :: nhat_ep(nrad,lm_size,nspden*((usexcnhat+1)/2))
1866 : real(dp),intent(in) :: rhor(nrad,lm_size,nspden)
1867 : real(dp),intent(in) :: rhor_ep(nrad,lm_size,nspden)
1868 : real(dp),intent(out) :: vxc(nrad,pawang%angl_size,nspden)
1869 :
1870 : !Local variables-------------------------------
1871 : !scalars
1872 : integer :: ilm,ipts,iwarn,iwarnp,ngr,ngrad,npts,order
1873 : real(dp) :: enxcr,vxcrho
1874 : character(len=500) :: msg
1875 : !arrays
1876 0 : real(dp),allocatable :: ff(:),fxci(:),grho2(:),rhoarr(:),rhoarr_ep(:),rhoarrdc(:),vxci(:),vxci_ep(:),vxcigr(:)
1877 :
1878 : ! *************************************************************************
1879 :
1880 : !----- Check options
1881 0 : if(ixcpositron==3.or.ixcpositron==31) then
1882 0 : msg='GGA is not implemented (use pawxcdev/=0)!'
1883 0 : LIBPAW_ERROR(msg)
1884 : end if
1885 0 : if(calctype/=1.and.calctype/=2) then
1886 0 : msg='Invalid value for calctype!'
1887 0 : LIBPAW_BUG(msg)
1888 : end if
1889 0 : if(pawang%angl_size==0) then
1890 0 : msg='pawang%angl_size=0!'
1891 0 : LIBPAW_BUG(msg)
1892 : end if
1893 0 : if(.not.allocated(pawang%ylmr)) then
1894 0 : msg='pawang%ylmr must be allocated!'
1895 0 : LIBPAW_BUG(msg)
1896 : end if
1897 0 : if (option/=1) then
1898 0 : if (nrad<pawrad%int_meshsz) then
1899 0 : msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!'
1900 0 : LIBPAW_BUG(msg)
1901 : end if
1902 : end if
1903 :
1904 : !----------------------------------------------------------------------
1905 : !----- Initializations
1906 : !----------------------------------------------------------------------
1907 :
1908 : !Initialization and constants
1909 0 : iwarn=0;iwarnp=1
1910 0 : npts=pawang%angl_size
1911 0 : order=1;ngr=0;ngrad=1 ! only LDA here !
1912 :
1913 : !Initializations of output arrays
1914 0 : if (option/=1) enxc=zero
1915 0 : if (option==0.or.option==2) enxcdc=zero
1916 0 : if (option<3) vxc(:,:,:)=zero
1917 :
1918 0 : if (ixcpositron==0) then ! No xc at all is applied (usually for testing)
1919 0 : msg = 'Note that no xc is applied (ixcpositron=0). Returning'
1920 0 : LIBPAW_WARNING(msg)
1921 0 : return
1922 : end if
1923 :
1924 : !Allocations
1925 0 : LIBPAW_ALLOCATE(fxci,(nrad))
1926 0 : LIBPAW_ALLOCATE(vxci,(nrad))
1927 0 : LIBPAW_ALLOCATE(rhoarr,(nrad))
1928 0 : LIBPAW_ALLOCATE(rhoarr_ep,(nrad))
1929 0 : if (option==0.or.option==2) then
1930 0 : LIBPAW_ALLOCATE(rhoarrdc,(nrad))
1931 : end if
1932 :
1933 : !----------------------------------------------------------------------
1934 : !----- Loop on the angular part
1935 0 : do ipts=1,npts
1936 :
1937 : ! ----------------------------------------------------------------------
1938 : ! ----- Build several densities
1939 : ! ----------------------------------------------------------------------
1940 :
1941 : ! Eventually add compensation density to input density
1942 0 : rhoarr=zero;rhoarr_ep=zero
1943 0 : if (usexcnhat==2) then
1944 0 : do ilm=1,lm_size
1945 0 : if (lmselect(ilm)) &
1946 0 : & rhoarr(:)=rhoarr(:)+(rhor(:,ilm,1)+nhat(:,ilm,1))*pawang%ylmr(ilm,ipts)
1947 : end do
1948 0 : do ilm=1,lm_size
1949 0 : if (lmselect_ep(ilm)) &
1950 0 : & rhoarr_ep(:)=rhoarr_ep(:)+(rhor_ep(:,ilm,1)+nhat_ep(:,ilm,1))*pawang%ylmr(ilm,ipts)
1951 : end do
1952 : else
1953 0 : do ilm=1,lm_size
1954 0 : if (lmselect(ilm)) rhoarr(:)=rhoarr(:)+rhor(:,ilm,1)*pawang%ylmr(ilm,ipts)
1955 : end do
1956 0 : do ilm=1,lm_size
1957 0 : if (lmselect_ep(ilm)) rhoarr_ep(:)=rhoarr_ep(:)+rhor_ep(:,ilm,1)*pawang%ylmr(ilm,ipts)
1958 : end do
1959 : end if
1960 :
1961 : ! Store density for use in double-counting term
1962 0 : if (option==0.or.option==2) rhoarrdc(:)=rhoarr(:)
1963 :
1964 : ! Eventually add core density
1965 0 : if (usecore==1) then
1966 0 : if (calctype==1) rhoarr_ep(:)=rhoarr_ep(:)+corexc(:)
1967 0 : if (calctype==2) rhoarr (:)=rhoarr (:)+corexc(:)
1968 : end if
1969 :
1970 : ! Make the densities positive
1971 0 : if (calctype==1) then
1972 0 : if (.not.posdensity0_limit) then
1973 0 : call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhoarr,xc_denpos)
1974 : end if
1975 0 : call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhoarr_ep,xc_denpos)
1976 0 : else if (calctype==2) then
1977 0 : call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhoarr,xc_denpos)
1978 0 : if (.not.posdensity0_limit) then
1979 0 : call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhoarr_ep,xc_denpos)
1980 : end if
1981 : end if
1982 :
1983 : ! ----------------------------------------------------------------------
1984 : ! ----- Compute XC data
1985 : ! ----------------------------------------------------------------------
1986 :
1987 : ! electron-positron correlation for the positron
1988 0 : LIBPAW_ALLOCATE(vxci_ep,(nrad))
1989 0 : LIBPAW_ALLOCATE(vxcigr,(ngr))
1990 0 : LIBPAW_ALLOCATE(grho2,(ngr))
1991 0 : if (calctype==1) then
1992 0 : call pawxc_xcpositron_wrapper(fxci,grho2,ixcpositron,ngr,nrad,posdensity0_limit,rhoarr_ep,rhoarr,vxci_ep,vxcigr,vxci)
1993 0 : else if (calctype==2) then
1994 0 : call pawxc_xcpositron_wrapper(fxci,grho2,ixcpositron,ngr,nrad,posdensity0_limit,rhoarr,rhoarr_ep,vxci,vxcigr,vxci_ep)
1995 : end if
1996 0 : LIBPAW_DEALLOCATE(vxci_ep)
1997 0 : LIBPAW_DEALLOCATE(vxcigr)
1998 0 : LIBPAW_DEALLOCATE(grho2)
1999 :
2000 : ! ----------------------------------------------------------------------
2001 : ! ----- Accumulate and store XC potential
2002 : ! ----------------------------------------------------------------------
2003 0 : if (option<3) then
2004 0 : vxc(:,ipts,1)=vxci(:)
2005 0 : if (nspden>=2) vxc(:,ipts,2)=vxci(:)
2006 0 : if (nspden==4) vxc(:,ipts,3:4)=zero
2007 : end if
2008 :
2009 : ! ----------------------------------------------------------------------
2010 : ! ----- Accumulate and store XC energies
2011 : ! ----------------------------------------------------------------------
2012 :
2013 : ! ----- Calculate Exc term
2014 0 : if (option/=1) then
2015 0 : LIBPAW_ALLOCATE(ff,(nrad))
2016 0 : ff(1:nrad)=fxci(1:nrad)*pawrad%rad(1:nrad)**2
2017 0 : call simp_gen(enxcr,ff,pawrad)
2018 0 : LIBPAW_DEALLOCATE(ff)
2019 0 : if (option/=4) enxc=enxc+enxcr*pawang%angwgth(ipts)
2020 0 : if (option==4) enxc=enxc+enxcr
2021 : end if
2022 :
2023 : ! ----- Calculate Excdc double counting term
2024 0 : if (option==0.or.option==2) then
2025 0 : if (usexcnhat==1) then
2026 0 : do ilm=1,lm_size
2027 0 : if (lmselect(ilm)) then
2028 0 : rhoarrdc(:)=rhoarrdc(:)+nhat(:,ilm,1)*pawang%ylmr(ilm,ipts)
2029 : end if
2030 : end do
2031 : end if
2032 0 : LIBPAW_ALLOCATE(ff,(nrad))
2033 0 : ff(1:nrad)=vxci(1:nrad)*rhoarrdc(1:nrad)*pawrad%rad(1:nrad)**2
2034 0 : call simp_gen(vxcrho,ff,pawrad)
2035 0 : LIBPAW_DEALLOCATE(ff)
2036 0 : enxcdc=enxcdc+vxcrho*pawang%angwgth(ipts)
2037 : end if
2038 :
2039 : ! ---------------------------------------------------
2040 : ! ----- End of the loop on npts (angular part)
2041 : end do
2042 :
2043 : !Add the four*pi factor of the angular integration
2044 0 : if (option/=1) enxc=enxc*four_pi
2045 0 : if (option==0.or.option==2) enxcdc=enxcdc*four_pi
2046 :
2047 : !Deallocations
2048 0 : LIBPAW_DEALLOCATE(fxci)
2049 0 : LIBPAW_DEALLOCATE(vxci)
2050 0 : LIBPAW_DEALLOCATE(rhoarr)
2051 0 : LIBPAW_DEALLOCATE(rhoarr_ep)
2052 0 : if (option==0.or.option==2) then
2053 0 : LIBPAW_DEALLOCATE(rhoarrdc)
2054 : end if
2055 :
2056 0 : end subroutine pawxcpositron
2057 : !!***
2058 :
2059 : !----------------------------------------------------------------------
2060 :
2061 : !!****f* m_pawxc/pawxc_dfpt
2062 : !! NAME
2063 : !! pawxc_dfpt
2064 : !!
2065 : !! FUNCTION
2066 : !! Compute first-order change of XC potential and contribution to
2067 : !! 2nd-order change of XC energy inside a PAW sphere.
2068 : !! LDA+GGA - USE THE DENSITY OVER A WHOLE SPHERICAL GRID (r,theta,phi)
2069 : !!
2070 : !! INPUTS
2071 : !! corexc1(cplex_den*nrad)=first-order change of core density on radial grid
2072 : !! cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX
2073 : !! cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX
2074 : !! ixc= choice of exchange-correlation scheme
2075 : !! kxc(nrad,pawang%angl_size,nkxc)=GS xc kernel
2076 : !! lm_size=size of density array rhor (see below)
2077 : !! lmselect(lm_size)=select the non-zero LM-moments of input density rhor1
2078 : !! nhat1(cplex_den*nrad,lm_size,nspden)=first-order change of compensation density
2079 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
2080 : !! nkxc=second dimension of the kxc array
2081 : !! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
2082 : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
2083 : !! nspden=number of spin-density components
2084 : !! option=0 compute both 2nd-order XC energy and 1st-order potential
2085 : !! 1 compute only 1st-order XC potential
2086 : !! 2 compute only 2nd-order XC energy, XC potential is temporary computed here
2087 : !! 3 compute only 2nd-order XC energy, XC potential is input in vxc1(:)
2088 : !! pawang <type(pawang_type)>=paw angular mesh and related data
2089 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
2090 : !! rhor1(cplex_den*nrad,lm_size,nspden)=first-order change of density
2091 : !! usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise
2092 : !! usexcnhat= 0 if compensation density does not have to be used
2093 : !! 1 if compensation density has to be used in d2Exc only
2094 : !! 2 if compensation density (nhat) has to be used in d2Exc and Vxc1
2095 : !! vxc(nrad,pawang%angl_size,nspden)=GS xc potential
2096 : !! xclevel= XC functional level
2097 : !!
2098 : !! OUTPUT
2099 : !! == if option=0 or 2 or 3 ==
2100 : !! d2enxc =returned exchange-cor. contribution to 2nd-order XC energy
2101 : !! d2enxc_im=returned IMAGINARY PART of exchange-cor. contribution to 2nd-order XC energy
2102 : !! (optional argument)
2103 : !!
2104 : !! SIDE EFFECTS
2105 : !! vxc1(cplex_vxc*nrad,pawang%angl_size,nspden)=1st-order XC potential
2106 : !! Output if option==0 or 1
2107 : !! Unused if option==2
2108 : !! Input if option==3
2109 : !!
2110 : !! NOTES
2111 : !! Content of Kxc array:
2112 : !! ===== if LDA
2113 : !! if nspden==1: kxc(:,1)= d2Exc/drho2
2114 : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
2115 : !! if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
2116 : !! kxc(:,2)= d2Exc/drho_up drho_dn
2117 : !! kxc(:,3)= d2Exc/drho_dn drho_dn
2118 : !! if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
2119 : !! ===== if GGA
2120 : !! if nspden==1:
2121 : !! kxc(:,1)= d2Exc/drho2
2122 : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
2123 : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
2124 : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
2125 : !! kxc(:,5)= gradx(rho)
2126 : !! kxc(:,6)= grady(rho)
2127 : !! kxc(:,7)= gradz(rho)
2128 : !! if nspden>=2:
2129 : !! kxc(:,1)= d2Exc/drho_up drho_up
2130 : !! kxc(:,2)= d2Exc/drho_up drho_dn
2131 : !! kxc(:,3)= d2Exc/drho_dn drho_dn
2132 : !! kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
2133 : !! kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
2134 : !! kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
2135 : !! kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
2136 : !! kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
2137 : !! kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
2138 : !! kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
2139 : !! kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
2140 : !! kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
2141 : !! kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
2142 : !! kxc(:,14)=gradx(rho_up)
2143 : !! kxc(:,15)=gradx(rho_dn)
2144 : !! kxc(:,16)=grady(rho_up)
2145 : !! kxc(:,17)=grady(rho_dn)
2146 : !! kxc(:,18)=gradz(rho_up)
2147 : !! kxc(:,19)=gradz(rho_dn)
2148 : !! if nspden==4:
2149 : !! kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
2150 : !!
2151 : !! SOURCE
2152 :
2153 7752 : subroutine pawxc_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,&
2154 7752 : & nkxc,non_magnetic_xc,nrad,nspden,option,pawang,pawrad,rhor1,&
2155 7752 : & usecore,usexcnhat,vxc,vxc1,xclevel,&
2156 : & d2enxc_im) ! optional
2157 :
2158 : !Arguments ------------------------------------
2159 : !scalars
2160 : integer,intent(in) :: cplex_den,cplex_vxc,ixc,lm_size,nkxc,nrad,nspden,option
2161 : integer,intent(in) :: usecore,usexcnhat,xclevel
2162 : logical,intent(in) :: non_magnetic_xc
2163 : real(dp),intent(out) :: d2enxc
2164 : real(dp),intent(out),optional :: d2enxc_im
2165 : type(pawang_type),intent(in) :: pawang
2166 : type(pawrad_type),intent(in) :: pawrad
2167 : !arrays
2168 : logical,intent(in) :: lmselect(lm_size)
2169 : real(dp),intent(in) :: corexc1(cplex_den*nrad)
2170 : real(dp),intent(in) :: nhat1(cplex_den*nrad,lm_size,nspden*((usexcnhat+1)/2))
2171 : real(dp),intent(in),target :: kxc(nrad,pawang%angl_size,nkxc)
2172 : real(dp),intent(in),target :: vxc(nrad,pawang%angl_size,nspden)
2173 : real(dp),intent(in),target :: rhor1(cplex_den*nrad,lm_size,nspden)
2174 : real(dp),intent(inout),target :: vxc1(cplex_vxc*nrad,pawang%angl_size,nspden)
2175 :
2176 : !Local variables-------------------------------
2177 : !scalars
2178 : integer :: ii,ilm,ipts,ir,ispden,jr,kr,lm_size_eff,nkxc_cur,npts,nspden_updn
2179 : logical :: need_impart
2180 : real(dp),parameter :: tol24=tol12*tol12
2181 : real(dp) :: coeff_grho,coeff_grho_corr,coeff_grho_dn,coeff_grho_up
2182 : real(dp) :: coeff_grhoim,coeff_grhoim_corr,coeff_grhoim_dn,coeff_grhoim_up
2183 : real(dp) :: dylmdr_ii,factor,factor_ang_intg,ylm_ii
2184 : real(dp) :: grho_grho1,grho_grho1_up,grho_grho1_dn
2185 : real(dp) :: grho_grho1im,grho_grho1im_up,grho_grho1im_dn
2186 : real(dp) :: rho1_dn,rho1_up,rho1im_dn,rho1im_up
2187 : real(dp) :: ro11i,ro11r,ro12i,ro12r,ro21i,ro21r,ro22i,ro22r
2188 : real(dp) :: v11i,v11r,v12i,v12r,v21i,v21r,v22i,v22r,vxcrho
2189 : character(len=500) :: msg
2190 : !arrays
2191 : real(dp) :: g0(3),g0_dn(3),g0_up(3),g1(3),g1_dn(3),g1_up(3)
2192 : real(dp) :: g1im(3),g1im_dn(3),g1im_up(3)
2193 : real(dp) :: gxc1i(3,2),gxc1r(3,2)
2194 7752 : real(dp),allocatable :: dgxc1(:),drho1(:,:),drho1core(:,:),dylmdr(:,:,:)
2195 7752 : real(dp),allocatable :: ff(:),gg(:),grho1arr(:,:,:),gxc1(:,:,:,:)
2196 7752 : real(dp),allocatable,target :: rhohat1(:,:,:),rho1arr(:,:)
2197 7752 : real(dp), LIBPAW_CONTIGUOUS pointer :: kxc_(:,:),mag(:,:)
2198 7752 : real(dp), LIBPAW_CONTIGUOUS pointer :: rho1_(:,:,:),rho1_nc(:,:),rho1_updn(:,:)
2199 7752 : real(dp), LIBPAW_CONTIGUOUS pointer :: vxc_(:,:),vxc1_(:,:,:),vxc1_diag(:,:)
2200 7752 : real(dp), LIBPAW_CONTIGUOUS pointer :: vxc1_nc(:,:),vxc1_updn(:,:,:)
2201 : #ifdef LIBPAW_ISO_C_BINDING
2202 : type(C_PTR) :: cptr
2203 : #endif
2204 :
2205 : ! *************************************************************************
2206 :
2207 : !----------------------------------------------------------------------
2208 : !----- Check options
2209 : !----------------------------------------------------------------------
2210 :
2211 7752 : if(option<0.or.option>3) then
2212 0 : msg='wrong option!'
2213 0 : LIBPAW_BUG(msg)
2214 : end if
2215 7752 : if(option/=3) then
2216 6288 : call pawxc_get_nkxc(nkxc_cur,nspden,xclevel)
2217 6288 : if (nkxc/=nkxc_cur) then
2218 0 : msg='Wrong dimension for array kxc!'
2219 0 : LIBPAW_BUG(msg)
2220 : end if
2221 6288 : if(xclevel==2.and.nspden==4) then
2222 0 : msg='PAW non-collinear magnetism not compatible with GGA!'
2223 0 : LIBPAW_ERROR(msg)
2224 : end if
2225 : end if
2226 7752 : if(pawang%angl_size==0) then
2227 0 : msg='pawang%angl_size=0!'
2228 0 : LIBPAW_BUG(msg)
2229 : end if
2230 7752 : if(.not.allocated(pawang%ylmr)) then
2231 0 : msg='pawang%ylmr must be allocated!'
2232 0 : LIBPAW_BUG(msg)
2233 : end if
2234 7752 : if(xclevel==2.and.(.not.allocated(pawang%ylmrgr))) then
2235 0 : msg='pawang%ylmrgr must be allocated!'
2236 0 : LIBPAW_BUG(msg)
2237 : end if
2238 7752 : if (option/=1) then
2239 4052 : if (nrad<pawrad%int_meshsz) then
2240 0 : msg='When option=0,2, nrad must be greater than pawrad%int_meshsz!'
2241 0 : LIBPAW_BUG(msg)
2242 : end if
2243 : end if
2244 :
2245 : !----------------------------------------------------------------------
2246 : !----- Initializations / allocations
2247 : !----------------------------------------------------------------------
2248 :
2249 7752 : npts=pawang%angl_size
2250 7752 : lm_size_eff=min(lm_size,pawang%ylm_size)
2251 7752 : nspden_updn=min(nspden,2)
2252 :
2253 7752 : need_impart=present(d2enxc_im)
2254 7752 : if (option/=1) then
2255 4052 : d2enxc=zero
2256 4052 : if (need_impart) d2enxc_im=zero
2257 : end if
2258 1304662996 : if (option<=1) vxc1(:,:,:)=zero
2259 :
2260 : !Special case: no XC applied
2261 7752 : if (ixc==0.or.(nkxc==0.and.option/=3)) then
2262 0 : msg='Note that no xc is applied (ixc=0). Returning'
2263 0 : LIBPAW_WARNING(msg)
2264 0 : return
2265 : end if
2266 :
2267 31008 : LIBPAW_ALLOCATE(rho1arr,(cplex_den*nrad,nspden))
2268 7752 : if (usexcnhat>0) then
2269 100 : LIBPAW_ALLOCATE(rhohat1,(cplex_den*nrad,lm_size,nspden))
2270 1189060 : rhohat1(:,:,:)=rhor1(:,:,:)+nhat1(:,:,:)
2271 : end if
2272 :
2273 7752 : if (option==2) then
2274 12940 : LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,npts,nspden))
2275 : else
2276 5164 : vxc1_ => vxc1
2277 : end if
2278 :
2279 : !Need gradients and additional allocations in case of GGA
2280 7752 : if (xclevel==2.and.option/=3) then
2281 6420 : LIBPAW_ALLOCATE(gxc1,(cplex_vxc*nrad,3,pawang%ylm_size,nspden))
2282 146534400 : gxc1=zero
2283 1284 : if (usecore==1) then
2284 0 : LIBPAW_ALLOCATE(drho1core,(nrad,cplex_den))
2285 0 : if (cplex_den==1) then
2286 0 : call nderiv_gen(drho1core(:,1),corexc1,pawrad)
2287 : else
2288 0 : LIBPAW_ALLOCATE(ff,(nrad))
2289 0 : LIBPAW_ALLOCATE(gg,(nrad))
2290 0 : do ir=1,nrad
2291 0 : ff(ir)=corexc1(2*ir-1)
2292 0 : gg(ir)=corexc1(2*ir )
2293 : end do
2294 0 : call nderiv_gen(drho1core(:,1),ff,pawrad)
2295 0 : call nderiv_gen(drho1core(:,2),gg,pawrad)
2296 0 : LIBPAW_DEALLOCATE(ff)
2297 0 : LIBPAW_DEALLOCATE(gg)
2298 : end if
2299 : end if
2300 : ! Convert Ylm derivatives from normalized to standard cartesian coordinates
2301 : ! dYlm/dr_i = { dYlm/dr_i^hat - Sum_j[ dYlm/dr_j^hat (r_j/r)] } * (1/r)
2302 5136 : LIBPAW_ALLOCATE(dylmdr,(3,npts,pawang%ylm_size))
2303 22948 : do ilm=1,pawang%ylm_size
2304 3168676 : do ipts=1,npts
2305 12582912 : factor=sum(pawang%ylmrgr(1:3,ilm,ipts)*pawang%anginit(1:3,ipts))
2306 12604576 : dylmdr(1:3,ipts,ilm)=pawang%ylmrgr(1:3,ilm,ipts)-factor*pawang%anginit(1:3,ipts)
2307 : end do
2308 : end do
2309 : end if
2310 :
2311 : !----------------------------------------------------------------------
2312 : !----- Accumulate and store 1st-order change of XC potential
2313 : !----------------------------------------------------------------------
2314 :
2315 7752 : if (option/=3) then
2316 :
2317 6288 : if (nspden/=4) then
2318 6288 : rho1_updn => rho1arr
2319 6288 : vxc1_updn => vxc1_
2320 : else
2321 0 : LIBPAW_POINTER_ALLOCATE(rho1_updn,(cplex_den*nrad,nspden_updn))
2322 0 : LIBPAW_POINTER_ALLOCATE(vxc1_updn,(cplex_vxc*nrad,npts,nspden_updn))
2323 0 : LIBPAW_POINTER_ALLOCATE(rho1_nc,(cplex_den*nrad*npts,nspden))
2324 0 : LIBPAW_POINTER_ALLOCATE(mag,(nrad,3))
2325 : end if
2326 :
2327 : ! Do loop on the angular part (theta,phi)
2328 980720 : do ipts=1,npts
2329 :
2330 : ! Copy the input 1st-order density for this (theta,phi)
2331 2202865328 : rho1arr(:,:)=zero
2332 974432 : if (usexcnhat< 2) rho1_=>rhor1
2333 974432 : if (usexcnhat==2) rho1_=>rhohat1
2334 2619408 : do ispden=1,nspden
2335 17495872 : do ilm=1,lm_size_eff
2336 14876464 : if (lmselect(ilm)) rho1arr(:,ispden)=rho1arr(:,ispden) &
2337 39810599856 : & +rho1_(:,ilm,ispden)*pawang%ylmr(ilm,ipts)
2338 : end do
2339 : end do
2340 974432 : if (usecore==1) then
2341 0 : rho1arr(:,1)=rho1arr(:,1)+corexc1(:)
2342 0 : if (nspden==2) rho1arr(:,2)=rho1arr(:,2)+half*corexc1(:)
2343 : end if
2344 :
2345 : ! Optionally suppress magnetic part
2346 974432 : if(non_magnetic_xc) then
2347 0 : if(nspden==2) rho1arr(:,2)=rho1arr(:,1)*half
2348 0 : if(nspden==4) rho1arr(:,2:4)=zero
2349 : endif
2350 :
2351 : ! Non-collinear magnetism: rotate magnetization and get a collinear density
2352 974432 : if (nspden==4) then
2353 : !Store non rotated rho^(1) for future use
2354 0 : ii=(ipts-1)*cplex_den*nrad
2355 0 : do ispden=1,nspden
2356 0 : rho1_nc(ii+1:ii+cplex_den*nrad,ispden)=rho1arr(1:cplex_den*nrad,ispden)
2357 : end do
2358 : !Extract magnetization from kxc
2359 0 : do ii=1,3
2360 0 : mag(1:nrad,ii)=kxc(:,ipts,ii)
2361 : end do
2362 : !Rotate rhoarr1 -> rhoarr1_
2363 : !Should use cplex_den
2364 0 : call pawxc_rotate_mag(rho1arr,rho1_updn,mag,nrad,rho_out_format=2)
2365 : end if
2366 :
2367 : ! =======================================================================
2368 : ! ======================= LDA ===========================================
2369 : ! =======================================================================
2370 980720 : if (xclevel==1.or.ixc==13) then
2371 :
2372 : ! Non-spin-polarized
2373 780624 : if (nspden_updn==1) then
2374 112320 : if (cplex_vxc==1) then
2375 112320 : if (cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
2376 276419520 : vxc1_updn(1:nrad,ipts,1)=kxc(1:nrad,ipts,1)*rho1_updn(1:nrad,1)
2377 : else ! cplex_vxc==1 and cplex_den==2
2378 0 : do ir=1,nrad
2379 0 : vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir-1,1)
2380 : end do
2381 : end if
2382 : else
2383 0 : if (cplex_den==1) then ! cplex_vxc==2 and cplex_den==1
2384 0 : do ir=1,nrad
2385 0 : vxc1_updn(2*ir-1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(ir,1)
2386 0 : vxc1_updn(2*ir ,ipts,1)=zero
2387 : end do
2388 : else ! cplex_vxc==2 and cplex_den==2
2389 0 : do ir=1,nrad
2390 0 : vxc1_updn(2*ir-1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir-1,1)
2391 0 : vxc1_updn(2*ir ,ipts,1)=kxc(ir,ipts,1)*rho1_updn(2*ir ,1)
2392 : end do
2393 : end if
2394 : end if
2395 :
2396 : ! Spin-polarized
2397 : else
2398 668304 : if (cplex_vxc==1) then
2399 668304 : if (cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
2400 822682224 : do ir=1,nrad
2401 822013920 : rho1_up=rho1_updn(ir,2);rho1_dn=rho1_updn(ir,1)-rho1_up
2402 822013920 : vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn
2403 822682224 : vxc1_updn(ir,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn
2404 : end do
2405 : else ! cplex_vxc==1 and cplex_den==2
2406 0 : do ir=1,nrad
2407 0 : jr=2*ir-1
2408 0 : rho1_up=rho1_updn(jr,2);rho1_dn=rho1_updn(jr,1)-rho1_up
2409 0 : vxc1_updn(ir,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn
2410 0 : vxc1_updn(ir,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn
2411 : end do
2412 : end if
2413 : else
2414 0 : if (cplex_den==1) then ! cplex_vxc==2 and cplex_den==1
2415 0 : do ir=1,nrad
2416 0 : jr=2*ir-1
2417 0 : rho1_up=rho1_updn(ir,2);rho1_dn=rho1_updn(ir,1)-rho1_up
2418 0 : vxc1_updn(jr,ipts,1)=kxc(ir,ipts,1)*rho1_up+kxc(ir,ipts,2)*rho1_dn
2419 0 : vxc1_updn(jr,ipts,2)=kxc(ir,ipts,2)*rho1_up+kxc(ir,ipts,3)*rho1_dn
2420 : end do
2421 : else ! cplex_vxc==2 and cplex_den==2
2422 0 : do ir=1,nrad
2423 0 : jr=2*ir
2424 0 : rho1_up =rho1_updn(jr-1,2);rho1_dn =rho1_updn(jr-1,1)-rho1_up
2425 0 : rho1im_up=rho1_updn(jr ,2);rho1im_dn=rho1_updn(jr ,1)-rho1im_up
2426 0 : vxc1_updn(jr-1,ipts,1)=kxc(ir,ipts,1)*rho1_up +kxc(ir,ipts,2)*rho1_dn
2427 0 : vxc1_updn(jr ,ipts,1)=kxc(ir,ipts,1)*rho1im_up+kxc(ir,ipts,2)*rho1im_dn
2428 0 : vxc1_updn(jr-1,ipts,2)=kxc(ir,ipts,2)*rho1_up +kxc(ir,ipts,3)*rho1_dn
2429 0 : vxc1_updn(jr ,ipts,2)=kxc(ir,ipts,2)*rho1im_up+kxc(ir,ipts,3)*rho1im_dn
2430 : end do
2431 : end if
2432 : end if
2433 : end if
2434 :
2435 : else
2436 : ! =======================================================================
2437 : ! ======================= GGA ===========================================
2438 : ! =======================================================================
2439 :
2440 : ! Compute the gradient of the first-order density
2441 775232 : LIBPAW_ALLOCATE(drho1,(nrad,cplex_den))
2442 969040 : LIBPAW_ALLOCATE(grho1arr,(cplex_den*nrad,nspden,3))
2443 1255556816 : grho1arr(:,:,1:3)=zero
2444 193808 : if (cplex_den==1) then
2445 147888 : LIBPAW_ALLOCATE(ff,(nrad))
2446 98592 : do ispden=1,nspden_updn
2447 542256 : do ilm=1,lm_size_eff
2448 492960 : if (lmselect(ilm)) then
2449 546150384 : ff(1:nrad)=rho1_(1:nrad,ilm,ispden)
2450 443664 : call nderiv_gen(drho1(:,1),ff,pawrad)
2451 545706720 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
2452 443664 : call pawrad_deducer0(ff,nrad,pawrad)
2453 1774656 : do ii=1,3
2454 1330992 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts)
2455 1330992 : dylmdr_ii=dylmdr(ii,ipts,ilm)
2456 : grho1arr(1:nrad,ispden,ii)=grho1arr(1:nrad,ispden,ii) &
2457 1638894816 : & +drho1(1:nrad,1)*ylm_ii+ff(1:nrad)*dylmdr_ii
2458 : end do
2459 : end if
2460 : end do
2461 : end do
2462 49296 : LIBPAW_DEALLOCATE(ff)
2463 : else
2464 433536 : LIBPAW_ALLOCATE(ff,(nrad))
2465 289024 : LIBPAW_ALLOCATE(gg,(nrad))
2466 291264 : do ispden=1,nspden_updn
2467 1683712 : do ilm=1,lm_size_eff
2468 1539200 : if (lmselect(ilm)) then
2469 1664570048 : do ir=1,nrad
2470 1663183360 : ff(ir)=rho1_(2*ir-1,ilm,ispden)
2471 1664570048 : gg(ir)=rho1_(2*ir ,ilm,ispden)
2472 : end do
2473 1386688 : call nderiv_gen(drho1(:,1),ff,pawrad)
2474 1386688 : call nderiv_gen(drho1(:,2),gg,pawrad)
2475 1663183360 : ff(2:nrad)=ff(2:nrad)/pawrad%rad(2:nrad)
2476 1663183360 : gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad)
2477 1386688 : call pawrad_deducer0(ff,nrad,pawrad)
2478 1386688 : call pawrad_deducer0(gg,nrad,pawrad)
2479 5546752 : do ii=1,3
2480 4160064 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts)
2481 4160064 : dylmdr_ii=dylmdr(ii,ipts,ilm)
2482 4990936768 : do ir=2,nrad
2483 4985390016 : jr=2*ir
2484 : grho1arr(jr-1,ispden,ii)=grho1arr(jr-1,ispden,ii) &
2485 4985390016 : & +drho1(ir,1)*ylm_ii+ff(ir)*dylmdr_ii
2486 : grho1arr(jr ,ispden,ii)=grho1arr(jr ,ispden,ii) &
2487 4989550080 : & +drho1(ir,2)*ylm_ii+gg(ir)*dylmdr_ii
2488 : end do
2489 : end do
2490 : end if
2491 : end do
2492 : end do
2493 144512 : LIBPAW_DEALLOCATE(ff)
2494 144512 : LIBPAW_DEALLOCATE(gg)
2495 : end if
2496 193808 : if (usecore==1) then
2497 0 : factor=one;if (nspden_updn==2) factor=half
2498 0 : if (cplex_den==1) then
2499 0 : do ispden=1,nspden_updn
2500 0 : do ii=1,3
2501 : grho1arr(1:nrad,ispden,ii)=grho1arr(1:nrad,ispden,ii) &
2502 0 : & +factor*drho1core(1:nrad,1)*pawang%anginit(ii,ipts)
2503 : end do
2504 : end do
2505 : else
2506 0 : do ispden=1,nspden_updn
2507 0 : do ii=1,3
2508 0 : do ir=1,nrad
2509 0 : jr=2*ir
2510 : grho1arr(jr-1,ispden,ii)=grho1arr(jr-1,ispden,ii) &
2511 0 : & +factor*drho1core(ir,1)*pawang%anginit(ii,ipts)
2512 : grho1arr(jr ,ispden,ii)=grho1arr(jr ,ispden,ii) &
2513 0 : & +factor*drho1core(ir,2)*pawang%anginit(ii,ipts)
2514 : end do
2515 : end do
2516 : end do
2517 : end if
2518 : end if
2519 193808 : LIBPAW_DEALLOCATE(drho1)
2520 :
2521 : ! Optionally suppress magnetic part
2522 193808 : if(non_magnetic_xc) then
2523 0 : do ii=1,3
2524 0 : if(nspden==2) grho1arr(:,2,ii)=grho1arr(:,1,ii)*half
2525 0 : if(nspden==4) grho1arr(:,2:4,ii)=zero
2526 : end do
2527 : endif
2528 :
2529 : ! Apply XC kernel
2530 : ! Will compute Vxc^(1) as: vxc1 - Nabla .dot. gxc1
2531 :
2532 : ! Scaling factor for angular integrals: four_pi x spin_factor
2533 193808 : factor_ang_intg=four_pi;if (nspden_updn==1) factor_ang_intg=two_pi
2534 :
2535 : ! A- NON POLARIZED SYSTEMS
2536 : if (nspden_updn==1) then
2537 :
2538 235820208 : do ir=1,nrad
2539 235628640 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
2540 :
2541 1649400480 : g0(:)=kxc(ir,ipts,5:7) ; g1(:)=grho1arr(jr,1,1:3)
2542 942514560 : grho_grho1=dot_product(g0,g1)
2543 235628640 : coeff_grho=kxc(ir,ipts,3)*rho1_updn(jr,1)+kxc(ir,ipts,4)*grho_grho1
2544 235628640 : vxc1_updn(kr,ipts,1)=kxc(ir,ipts,1)*rho1_updn(jr,1)+kxc(ir,ipts,3)*grho_grho1
2545 942514560 : gxc1r(:,1)=g1(:)*kxc(ir,ipts,2)+g0(:)*coeff_grho
2546 : !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega]
2547 4005686880 : do ilm=1,pawang%ylm_size
2548 3770058240 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg
2549 15315861600 : do ii=1,3
2550 15080232960 : gxc1(kr,ii,ilm,1)=gxc1(ir,ii,ilm,1)+gxc1r(ii,1)*ylm_ii
2551 : end do
2552 : end do
2553 235820208 : if (cplex_vxc==2) then
2554 174994560 : if (cplex_den==2) then
2555 699978240 : g1im(:)=grho1arr(jr+1,1,1:3)
2556 699978240 : grho_grho1im=dot_product(g0,g1im)
2557 174994560 : coeff_grhoim=kxc(ir,ipts,3)*rho1_updn(jr+1,1)+kxc(ir,ipts,4)*grho_grho1im
2558 174994560 : vxc1_updn(kr+1,ipts,1)=kxc(ir,ipts,1)*rho1_updn(jr+1,1)+kxc(ir,ipts,3)*grho_grho1im
2559 699978240 : gxc1i(:,1)=g1im(:)*kxc(ir,ipts,2)+g0(:)*coeff_grhoim
2560 : !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega]
2561 2974907520 : do ilm=1,pawang%ylm_size
2562 2799912960 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg
2563 11374646400 : do ii=1,3
2564 11199651840 : gxc1(kr+1,ii,ilm,1)=gxc1(kr+1,ii,ilm,1)+gxc1i(ii,1)*ylm_ii
2565 : end do
2566 : end do
2567 : else
2568 0 : vxc1_updn(kr+1,ipts,1)=zero ; gxc1i(:,1)=zero
2569 : end if
2570 : end if
2571 : end do ! ir
2572 :
2573 : ! B- POLARIZED SYSTEMS (COLLINEAR)
2574 : else ! nspden_updn==2
2575 :
2576 1862560 : do ir=1,nrad
2577 1860320 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
2578 :
2579 1860320 : rho1_up=rho1_updn(jr,2);rho1_dn=rho1_updn(jr,1)-rho1_up
2580 1860320 : g0_up(1)=kxc(ir,ipts,15);g0_dn(1)=kxc(ir,ipts,14)-kxc(ir,ipts,15)
2581 1860320 : g0_up(2)=kxc(ir,ipts,17);g0_dn(2)=kxc(ir,ipts,16)-kxc(ir,ipts,17)
2582 1860320 : g0_up(3)=kxc(ir,ipts,19);g0_dn(3)=kxc(ir,ipts,18)-kxc(ir,ipts,19)
2583 13022240 : g1_up(:)=grho1arr(jr,2,:);g1_dn(:)=grho1arr(jr,1,:)-grho1arr(jr,2,:)
2584 13022240 : g0(:)=g0_up(:)+g0_dn(:);g1(:)=g1_up(:)+g1_dn(:)
2585 7441280 : grho_grho1_up=dot_product(g0_up,g1_up)
2586 7441280 : grho_grho1_dn=dot_product(g0_dn,g1_dn)
2587 7441280 : grho_grho1 =dot_product(g0,g1)
2588 : coeff_grho_corr=kxc(ir,ipts,11)*rho1_up &
2589 : & +kxc(ir,ipts,12)*rho1_dn &
2590 1860320 : & +kxc(ir,ipts,13)*grho_grho1
2591 : coeff_grho_up=kxc(ir,ipts,6)*rho1_up &
2592 1860320 : & +kxc(ir,ipts,8)*grho_grho1_up
2593 : coeff_grho_dn=kxc(ir,ipts,7)*rho1_dn &
2594 1860320 : & +kxc(ir,ipts,9)*grho_grho1_dn
2595 : vxc1_updn(kr,ipts,1)=kxc(ir,ipts, 1)*rho1_up &
2596 : & +kxc(ir,ipts, 2)*rho1_dn &
2597 : & +kxc(ir,ipts, 6)*grho_grho1_up &
2598 1860320 : & +kxc(ir,ipts,11)*grho_grho1
2599 : vxc1_updn(kr,ipts,2)=kxc(ir,ipts, 3)*rho1_dn &
2600 : & +kxc(ir,ipts, 2)*rho1_up &
2601 : & +kxc(ir,ipts, 7)*grho_grho1_dn &
2602 1860320 : & +kxc(ir,ipts,12)*grho_grho1
2603 : gxc1r(:,1)=(kxc(ir,ipts,4)+kxc(ir,ipts,10))*g1_up(:) &
2604 : & +kxc(ir,ipts,10) *g1_dn(:) &
2605 : & +coeff_grho_up *g0_up(:) &
2606 7441280 : & +coeff_grho_corr *g0(:)
2607 : gxc1r(:,2)=(kxc(ir,ipts,5)+kxc(ir,ipts,10))*g1_dn(:) &
2608 : & +kxc(ir,ipts,10) *g1_up(:) &
2609 : & +coeff_grho_dn *g0_dn(:) &
2610 7441280 : & +coeff_grho_corr *g0(:)
2611 : !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega]
2612 5580960 : do ispden=1,nspden_updn
2613 139524000 : do ilm=1,pawang%ylm_size
2614 133943040 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg
2615 539492800 : do ii=1,3
2616 535772160 : gxc1(kr,ii,ilm,ispden)=gxc1(kr,ii,ilm,ispden)+gxc1r(ii,ispden)*ylm_ii
2617 : end do
2618 : end do
2619 : end do
2620 :
2621 1862560 : if (cplex_vxc==2) then
2622 1860320 : if (cplex_den==2) then
2623 1860320 : rho1im_up=rho1_updn(jr+1,2);rho1im_dn=rho1_updn(jr+1,1)-rho1im_up
2624 13022240 : g1im_up(:)=grho1arr(jr+1,2,:);g1im_dn(:)=grho1arr(jr+1,1,:)-grho1arr(jr+1,2,:)
2625 7441280 : g1im(:)=g1im_up(:)+g1im_dn(:)
2626 7441280 : grho_grho1im_up=dot_product(g0_up,g1im_up)
2627 7441280 : grho_grho1im_dn=dot_product(g0_dn,g1im_dn)
2628 7441280 : grho_grho1im =dot_product(g0,g1im)
2629 : coeff_grhoim_corr=kxc(ir,ipts,11)*rho1im_up &
2630 : & +kxc(ir,ipts,12)*rho1im_dn &
2631 1860320 : & +kxc(ir,ipts,13)*grho_grho1im
2632 : coeff_grhoim_up=kxc(ir,ipts,6)*rho1im_up &
2633 1860320 : & +kxc(ir,ipts,8)*grho_grho1im_up
2634 : coeff_grhoim_dn=kxc(ir,ipts,7)*rho1im_dn &
2635 1860320 : & +kxc(ir,ipts,9)*grho_grho1im_dn
2636 : vxc1_updn(kr+1,ipts,1)=kxc(ir,ipts, 1)*rho1im_up &
2637 : & +kxc(ir,ipts, 2)*rho1im_dn &
2638 : & +kxc(ir,ipts, 6)*grho_grho1im_up &
2639 1860320 : & +kxc(ir,ipts,11)*grho_grho1im
2640 : vxc1_updn(kr+1,ipts,2)=kxc(ir,ipts, 3)*rho1im_dn &
2641 : & +kxc(ir,ipts, 2)*rho1im_up &
2642 : & +kxc(ir,ipts, 7)*grho_grho1im_dn &
2643 1860320 : & +kxc(ir,ipts,12)*grho_grho1im
2644 : gxc1i(:,1)=(kxc(ir,ipts,4)+kxc(ir,ipts,10))*g1im_up(:) &
2645 : & +kxc(ir,ipts,10) *g1im_dn(:) &
2646 : & +coeff_grhoim_up *g0_up(:) &
2647 7441280 : & +coeff_grhoim_corr *g0(:)
2648 : gxc1i(:,2)=(kxc(ir,ipts,5)+kxc(ir,ipts,10))*g1im_dn(:) &
2649 : & +kxc(ir,ipts,10) *g1im_up(:) &
2650 : & +coeff_grhoim_dn *g0_dn(:) &
2651 7441280 : & +coeff_grhoim_corr *g0(:)
2652 : !Accumulate gxc1_lm moments as Intg[gxc1(omega).Ylm(omega).d_omega]
2653 5580960 : do ispden=1,nspden_updn
2654 139524000 : do ilm=1,pawang%ylm_size
2655 133943040 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%angwgth(ipts)*factor_ang_intg
2656 539492800 : do ii=1,3
2657 535772160 : gxc1(kr+1,ii,ilm,ispden)=gxc1(kr+1,ii,ilm,ispden)+gxc1i(ii,ispden)*ylm_ii
2658 : end do
2659 : end do
2660 : end do
2661 : else
2662 0 : vxc1_updn(kr+1,ipts,1:2)=zero ; gxc1i(:,1:2)=zero
2663 : end if
2664 : end if
2665 :
2666 : end do ! ir
2667 :
2668 : end if ! nspden_updn
2669 :
2670 193808 : LIBPAW_DEALLOCATE(grho1arr)
2671 :
2672 : end if ! LDA or GGA
2673 :
2674 : ! ----- End of the loop on npts (angular part)
2675 : end do
2676 :
2677 : ! Deallocate memory
2678 6288 : if (xclevel==2.and.usecore==1) then
2679 0 : LIBPAW_DEALLOCATE(drho1core)
2680 : end if
2681 6288 : if (nspden==4) then
2682 0 : LIBPAW_POINTER_DEALLOCATE(rho1_updn)
2683 0 : LIBPAW_POINTER_DEALLOCATE(mag)
2684 : end if
2685 :
2686 : end if ! option/=3
2687 :
2688 : !----------------------------------------------------------------------
2689 : !----- If GGA, modify 1st-order potential with term from density gradient
2690 : !----------------------------------------------------------------------
2691 7752 : if (xclevel==2.and.ixc/=13.and.option/=3) then
2692 : ! Compute divergence of gxc1 and substract it from Vxc1
2693 :
2694 : ! Need to multiply gxc1 by 2 in the non-polarised case
2695 1284 : factor=one;if (nspden_updn==1) factor=two
2696 :
2697 3852 : LIBPAW_ALLOCATE(dgxc1,(nrad))
2698 2568 : LIBPAW_ALLOCATE(gg,(nrad))
2699 2624 : do ispden=1,nspden_updn
2700 26304 : do ilm=1,pawang%ylm_size
2701 96060 : do ii=1,3
2702 82617888 : do ir=1,nrad
2703 82546848 : jr=cplex_vxc*(ir-1)+1
2704 82617888 : gg(ir)=gxc1(jr,ii,ilm,ispden)
2705 : end do
2706 71040 : call nderiv_gen(dgxc1,gg,pawrad)
2707 82546848 : gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad)
2708 71040 : call pawrad_deducer0(gg,nrad,pawrad)
2709 9773824 : do ipts=1,npts
2710 9679104 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts)
2711 9679104 : dylmdr_ii=dylmdr(ii,ipts,ilm)
2712 11721753984 : do ir=1,nrad
2713 11712003840 : jr=cplex_vxc*(ir-1)+1
2714 : vxc1_(jr,ipts,ispden)=vxc1_(jr,ipts,ispden) &
2715 11721682944 : & -factor*(dgxc1(ir)*ylm_ii+gg(ir)*dylmdr_ii)
2716 : end do
2717 : end do ! ipts
2718 : end do ! ii
2719 : end do ! ilm
2720 : end do ! ispden
2721 1284 : if (cplex_vxc==2) then
2722 1992 : do ispden=1,nspden_updn
2723 20616 : do ilm=1,pawang%ylm_size
2724 75520 : do ii=1,3
2725 63946080 : do ir=1,nrad
2726 63946080 : gg(ir)=gxc1(2*ir,ii,ilm,ispden)
2727 : end do
2728 55872 : call nderiv_gen(dgxc1,gg,pawrad)
2729 63890208 : gg(2:nrad)=gg(2:nrad)/pawrad%rad(2:nrad)
2730 55872 : call pawrad_deducer0(gg,nrad,pawrad)
2731 7387392 : do ipts=1,npts
2732 7312896 : ylm_ii=pawang%ylmr(ilm,ipts)*pawang%anginit(ii,ipts)
2733 7312896 : dylmdr_ii=dylmdr(ii,ipts,ilm)
2734 8808936768 : do ir=1,nrad
2735 : vxc1_(2*ir,ipts,ispden)=vxc1_(2*ir,ipts,ispden) &
2736 8808880896 : & -factor*(dgxc1(ir)*ylm_ii+gg(ir)*dylmdr_ii)
2737 : end do
2738 : end do ! ipts
2739 : end do ! ii
2740 : end do ! ilm
2741 : end do ! ispden
2742 : end if ! cplex_vxc
2743 1284 : LIBPAW_DEALLOCATE(dgxc1)
2744 1284 : LIBPAW_DEALLOCATE(gg)
2745 :
2746 : end if ! GGA
2747 :
2748 : ! ----------------------------------------------------------------------
2749 : ! ----- If non-collinear, rotate back potential according to magnetization
2750 : ! ----------------------------------------------------------------------
2751 7752 : if (option/=3.and.nspden==4) then
2752 : ! Use of C pointers to avoid copies (when ISO C bindings are available)
2753 : ! %@1$ xlf v15 compiler requires a auxilliary cptr variable
2754 : #ifdef LIBPAW_ISO_C_BINDING
2755 0 : cptr=c_loc(vxc1_updn(1,1,1))
2756 0 : call c_f_pointer(cptr,vxc1_diag,shape=[cplex_vxc*nrad*npts,nspden_updn])
2757 0 : cptr=c_loc(vxc1_(1,1,1))
2758 0 : call c_f_pointer(cptr,vxc1_nc,shape=[cplex_vxc*nrad*npts,nspden])
2759 0 : cptr=c_loc(vxc(1,1,1))
2760 0 : call c_f_pointer(cptr,vxc_,shape=[nrad*npts,nspden])
2761 0 : cptr=c_loc(kxc(1,1,1))
2762 0 : call c_f_pointer(cptr,kxc_,shape=[nrad*npts,3])
2763 0 : cptr=c_loc(kxc(1,1,nkxc-2))
2764 0 : call c_f_pointer(cptr,mag,shape=[nrad*npts,3])
2765 : #else
2766 : LIBPAW_ALLOCATE(vxc1_diag,(cplex_vxc*nrad*npts,nspden_updn))
2767 : LIBPAW_ALLOCATE(vxc1_nc,(cplex_vxc*nrad*npts,nspden))
2768 : LIBPAW_ALLOCATE(vxc_,(nrad*npts,nspden))
2769 : LIBPAW_ALLOCATE(kxc_,(nrad*npts,3))
2770 : LIBPAW_ALLOCATE(mag,(nrad*npts,3))
2771 : vxc1_diag=reshape(vxc1_updn,[cplex_vxc*nrad*npts,nspden_updn])
2772 : vxc_=reshape(vxc(1:cplex_vxc*nrad,1:npts,1:nspden),[cplex_vxc*nrad*npts,nspden])
2773 : kxc_=reshape(kxc(1:nrad,1:npts,1:3),[nrad*npts,3])
2774 : mag=reshape(kxc(1:nrad,1:npts,nkxc-2:nkxc),[nrad*npts,3])
2775 : #endif
2776 : !Should use cplex_den and cplex_vxc
2777 0 : call pawxc_rotate_back_mag_dfpt(vxc1_diag,vxc1_nc,vxc_,kxc_,rho1_nc,mag,nrad*npts)
2778 : #ifndef LIBPAW_ISO_C_BINDING
2779 : vxc1_=reshape(vxc1_nc,[cplex_vxc*nrad,npts,nspden])
2780 : LIBPAW_DEALLOCATE(vxc1_diag)
2781 : LIBPAW_DEALLOCATE(vxc1_nc)
2782 : LIBPAW_DEALLOCATE(vxc_)
2783 : LIBPAW_DEALLOCATE(kxc_)
2784 : LIBPAW_DEALLOCATE(mag)
2785 : #endif
2786 0 : LIBPAW_POINTER_DEALLOCATE(rho1_nc)
2787 0 : LIBPAW_POINTER_DEALLOCATE(vxc1_updn)
2788 : end if
2789 :
2790 : !----------------------------------------------------------------------
2791 : !----- Accumulate and store 2nd-order change of XC energy
2792 : !----------------------------------------------------------------------
2793 7752 : if (option/=1) then
2794 :
2795 : ! Do loop on the angular part (theta,phi)
2796 630596 : do ipts=1,npts
2797 :
2798 : ! Copy the input 1st-order density for this (theta,phi)
2799 1394178096 : rho1arr(:,:)=zero
2800 626544 : if (usexcnhat< 1) rho1_=>rhor1
2801 626544 : if (usexcnhat>=1) rho1_=>rhohat1
2802 1658736 : do ispden=1,nspden
2803 11009904 : do ilm=1,lm_size_eff
2804 9351168 : if (lmselect(ilm)) rho1arr(:,ispden)=rho1arr(:,ispden) &
2805 23941433616 : & +rho1_(:,ilm,ispden)*pawang%ylmr(ilm,ipts)
2806 : end do
2807 : end do
2808 626544 : if (usecore==1) then
2809 0 : rho1arr(:,1)=rho1arr(:,1)+corexc1(:)
2810 0 : if (nspden==2) rho1arr(:,2)=rho1arr(:,2)+half*corexc1(:)
2811 : end if
2812 :
2813 : ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr]
2814 1879632 : LIBPAW_ALLOCATE(ff,(nrad))
2815 626544 : if (need_impart) then
2816 451200 : LIBPAW_ALLOCATE(gg,(nrad))
2817 : end if
2818 :
2819 : ! COLLINEAR MAGNETISM
2820 626544 : if (nspden/=4) then
2821 626544 : if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
2822 647545392 : ff(:)=vxc1_(:,ipts,1)*rho1arr(:,nspden)
2823 497111472 : if (nspden==2) ff(:)=ff(:)+vxc1_(:,ipts,2)*(rho1arr(:,1)-rho1arr(:,2))
2824 239992272 : if (need_impart) gg(:)=zero
2825 100512 : else if (cplex_vxc==2.and.cplex_den==2) then ! cplex_vxc==2 and cplex_den==2
2826 100512 : if (.not.need_impart) then ! Real part only
2827 85294080 : do ir=1,nrad
2828 85224480 : jr=2*ir;v11r=vxc1_(jr-1,ipts,1);v11i=vxc1_(jr,ipts,1)
2829 85224480 : ro11r=rho1arr(jr-1,nspden);ro11i=rho1arr(jr,nspden)
2830 85294080 : ff(ir)=v11r*ro11r+v11i*ro11i
2831 : end do
2832 69600 : if (nspden==2) then
2833 798240 : do ir=1,nrad
2834 797280 : jr=2*ir;v22r=vxc1_(jr-1,ipts,2);v22i=vxc1_(jr,ipts,2)
2835 797280 : ro22r=rho1arr(jr-1,1)-rho1arr(jr-1,2)
2836 797280 : ro22i=rho1arr(jr ,1)-rho1arr(jr ,2)
2837 798240 : ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i
2838 : end do
2839 : end if
2840 : else
2841 37669152 : do ir=1,nrad ! Real and imaginary parts
2842 37638240 : jr=2*ir;v11r=vxc1_(jr-1,ipts,1);v11i=vxc1_(jr,ipts,1)
2843 37638240 : ro11r=rho1arr(jr-1,nspden);ro11i=rho1arr(jr,nspden)
2844 37638240 : ff(ir)=v11r*ro11r+v11i*ro11i
2845 37669152 : gg(ir)=v11r*ro11i-v11i*ro11r
2846 : end do
2847 30912 : if (nspden==2) then
2848 798240 : do ir=1,nrad
2849 797280 : jr=2*ir;v22r=vxc1_(jr-1,ipts,2);v22i=vxc1_(jr,ipts,2)
2850 797280 : ro22r=rho1arr(jr-1,1)-rho1arr(jr-1,2)
2851 797280 : ro22i=rho1arr(jr ,1)-rho1arr(jr ,2)
2852 797280 : ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i
2853 798240 : gg(ir)=gg(ir)+v22r*ro22i-v22i*ro22r
2854 : end do
2855 : end if
2856 : end if
2857 : else ! other cases for cplex_vxc and cplex_den
2858 : v11i=zero;ro11i=zero
2859 0 : do ir=1,nrad
2860 0 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
2861 0 : ro11r=rho1arr(jr,nspden);if (cplex_den==2) ro11i=rho1arr(jr+1,nspden)
2862 0 : v11r=vxc1_(kr,ipts,1);if (cplex_vxc==2) v11i=vxc1_(kr+1,ipts,1)
2863 0 : ff(ir)=v11r*ro11r+v11i*ro11i
2864 0 : if (need_impart) gg(ir)=v11r*ro11i-v11i*ro11r
2865 : end do
2866 0 : if (nspden==2) then
2867 : v22i=zero;ro22i=zero
2868 0 : do ir=1,nrad
2869 0 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
2870 0 : ro22r=rho1arr(jr,1)-rho1arr(jr,2)
2871 0 : if (cplex_den==2) ro22i=rho1arr(jr+1,1)-rho1arr(jr+1,2)
2872 0 : v22r=vxc1_(kr,ipts,2);if (cplex_vxc==2) v22i=vxc1_(kr+1,ipts,2)
2873 0 : ff(ir)=ff(ir)+v22r*ro22r+v22i*ro22i
2874 0 : gg(ir)=gg(ir)+v22r*ro22i-v22i*ro22r
2875 : end do
2876 : end if
2877 : end if ! cplex_vxc and cplex_den
2878 :
2879 : ! NON-COLLINEAR MAGNETISM
2880 : else
2881 0 : if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
2882 : ff(:)=half*(vxc1_(:,ipts,1)*(rho1arr(:,1)+rho1arr(:,4)) &
2883 : & +vxc1_(:,ipts,2)*(rho1arr(:,1)-rho1arr(:,4))) &
2884 : & +vxc1_(:,ipts,3)*rho1arr(:,2) &
2885 0 : & -vxc1_(:,ipts,4)*rho1arr(:,3)
2886 0 : if (need_impart) gg(:)=zero
2887 : else ! other cases for cplex_vxc and cplex_den
2888 :
2889 : ! V is stored as : v^11, v^22, V^12, i.V^21 (each are complex)
2890 : ! N is stored as : n, m_x, m_y, mZ (each are complex)
2891 0 : do ir=1,nrad
2892 0 : jr=cplex_den*(ir-1)+1 ; kr=cplex_vxc*(ir-1)+1
2893 0 : ro11r= rho1arr(jr,1)+rho1arr(jr,4)
2894 0 : ro22r= rho1arr(jr,1)-rho1arr(jr,4)
2895 0 : ro12r= rho1arr(jr,2);ro12i=-rho1arr(jr,3)
2896 0 : ro21r= rho1arr(jr,2);ro21i= rho1arr(jr,3)
2897 0 : if (cplex_den==2) then
2898 0 : ro11i=rho1arr(jr+1,1)+rho1arr(jr+1,4)
2899 0 : ro22i=rho1arr(jr+1,1)-rho1arr(jr+1,4)
2900 0 : ro12r=ro12r+rho1arr(jr+1,3);ro12i=ro12i+rho1arr(jr+1,2)
2901 0 : ro21r=ro21r-rho1arr(jr+1,3);ro21i=ro21i+rho1arr(jr+1,2)
2902 : else
2903 : ro11i=zero;ro22i=zero
2904 : end if
2905 0 : v11r= vxc1_(kr,ipts,1);v22r= vxc1_(kr,ipts,2)
2906 0 : v12r= vxc1_(kr,ipts,3);v21i=-vxc1_(kr,ipts,1)
2907 0 : if (cplex_vxc==2) then
2908 0 : v11i= vxc1_(kr+1,ipts,1);v22i= vxc1_(kr+1,ipts,2)
2909 0 : v12i= vxc1_(kr+1,ipts,3);v21r= vxc1_(kr+1,ipts,1)
2910 : else
2911 : v11i=zero;v22i=zero
2912 : v12i=zero;v21i=zero
2913 : end if
2914 : ! Real part
2915 : ff(ir)=half*(v11r*ro11r+v11i*ro11i+v22r*ro22r+v22i*ro22i &
2916 0 : & +v12r*ro12r+v12i*ro12i+v21r*ro21r+v21i*ro21i)
2917 : ! Imaginary part
2918 0 : if (need_impart) &
2919 : & gg(ir)=half*(v11r*ro11i-v11i*ro11r+v22r*ro22i-v22i*ro22r &
2920 0 : & +v12r*ro12i-v12i*ro12r+v21r*ro21i-v21i*ro21r)
2921 : end do
2922 : end if ! cplex_vxc and cplex_den
2923 : end if ! nspden
2924 :
2925 770508624 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
2926 626544 : call simp_gen(vxcrho,ff,pawrad)
2927 626544 : d2enxc=d2enxc+vxcrho*pawang%angwgth(ipts)
2928 626544 : LIBPAW_DEALLOCATE(ff)
2929 :
2930 1257140 : if (need_impart) then
2931 277330080 : gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2
2932 225600 : call simp_gen(vxcrho,gg,pawrad)
2933 225600 : d2enxc_im=d2enxc_im+vxcrho*pawang%angwgth(ipts)
2934 225600 : LIBPAW_DEALLOCATE(gg)
2935 : end if
2936 :
2937 : ! ----- End of the loop on npts (angular part)
2938 : end do
2939 :
2940 : end if ! option/=1
2941 :
2942 : !Add the four*pi factor of the angular integration
2943 7752 : if (option/=1) then
2944 4052 : d2enxc=d2enxc*four_pi
2945 4052 : if (need_impart) d2enxc_im=d2enxc_im*four_pi
2946 : end if
2947 :
2948 : !Free memory
2949 7752 : if (usexcnhat>0) then
2950 20 : LIBPAW_DEALLOCATE(rhohat1)
2951 : end if
2952 7752 : LIBPAW_DEALLOCATE(rho1arr)
2953 7752 : if (option==2) then
2954 2588 : LIBPAW_POINTER_DEALLOCATE(vxc1_)
2955 : end if
2956 7752 : if (xclevel==2.and.option/=3) then
2957 1284 : LIBPAW_DEALLOCATE(gxc1)
2958 1284 : LIBPAW_DEALLOCATE(dylmdr)
2959 : end if
2960 :
2961 15504 : end subroutine pawxc_dfpt
2962 : !!***
2963 :
2964 : !----------------------------------------------------------------------
2965 :
2966 : !!****f* m_pawxc/pawxcsph
2967 : !! NAME
2968 : !! pawxcsph
2969 : !!
2970 : !! FUNCTION
2971 : !! Compute XC energy and potential for a spherical density rho(r) given as (up,dn)
2972 : !! Driver of XC functionals. Only treat collinear spins. LDA and GGA
2973 : !!
2974 : !! INPUTS
2975 : !! exexch= choice of <<<local>>> exact exchange. Active if exexch>0 (only for GGA)
2976 : !! el_temp=electronic temperature (hartree)
2977 : !! ixc= choice of exchange-correlation scheme (see above and below)
2978 : !! nkxc= size of kxc(nrad,nkxc) (XC kernel)
2979 : !! nrad= dimension of the radial mesh
2980 : !! nspden=number of spin-density components
2981 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
2982 : !! rho_updn(nrad,lm_size,nspden)=electron density in real space
2983 : !! up (ispden=1) and down (ispden=2) parts
2984 : !! If nspden=1, rho_updn(:,:,1) contains (1/2).rho_total
2985 : !! xclevel= XC functional level
2986 : !!
2987 : !! OUTPUT
2988 : !! exc(nrad)= XC energy density
2989 : !! tsxc(nrad)= XC entropy energy density
2990 : !! vxc((nrad,nspden)= XC potential
2991 : !! === Only if nkxc>0 ===
2992 : !! kxc(nrad,nkxc)=exchange and correlation kernel (returned only if nkxc/=0)
2993 : !! Content of Kxc array:
2994 : !! ===== if LDA
2995 : !! if nspden==1: kxc(:,1)= d2Exc/drho2
2996 : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
2997 : !! if nspden>=2: kxc(:,1)=d2Exc/drho_up drho_up
2998 : !! kxc(:,2)=d2Exc/drho_up drho_dn
2999 : !! kxc(:,3)=d2Exc/drho_dn drho_dn
3000 : !!
3001 : !! SOURCE
3002 :
3003 232722 : subroutine pawxcsph(exc,tsxc,exexch,el_temp,hyb_mixing,ixc,kxc,nkxc,nrad,nspden,pawrad,rho_updn,vxc,xclevel)
3004 :
3005 : !Arguments ------------------------------------
3006 : !scalars
3007 : integer,intent(in) :: exexch,ixc,nkxc,nrad,nspden,xclevel
3008 : real(dp),intent(in) :: el_temp,hyb_mixing
3009 : type(pawrad_type),intent(in) :: pawrad
3010 : !arrays
3011 : real(dp),intent(in) :: rho_updn(nrad,nspden)
3012 : real(dp),intent(out) :: exc(nrad),tsxc(nrad),kxc(nrad,nkxc),vxc(nrad,nspden)
3013 :
3014 : !Local variables-------------------------------
3015 : !scalars
3016 : integer :: ir,ispden,ndvxc,nspgrad,nvxcdgr,order
3017 : integer :: usegradient,uselaplacian,usekden
3018 : real(dp),parameter :: tol24=tol12*tol12
3019 : real(dp) :: coeff,grho_tot,grho_up,fact
3020 : character(len=500) :: msg
3021 : !arrays
3022 : real(dp) :: d2vxc(1,1)
3023 232722 : real(dp),allocatable :: dff(:),dnexcdn(:,:),dvxcdgr(:,:),dvxci(:,:)
3024 232722 : real(dp),allocatable :: grho2(:,:),grho_updn(:,:)
3025 :
3026 : ! *************************************************************************
3027 :
3028 232722 : if(nspden>2)then
3029 : write(msg, '(a,a,a,i0)' )&
3030 0 : & 'Only non-spin-polarised or collinear spin-densities are allowed,',ch10,&
3031 0 : & 'while the argument nspden=',nspden
3032 0 : LIBPAW_BUG(msg)
3033 : end if
3034 232722 : if(nkxc>3)then
3035 0 : msg='nkxc>3 not allowed (GGA)!'
3036 0 : LIBPAW_ERROR(msg)
3037 : end if
3038 232722 : if(nrad>pawrad%mesh_size)then
3039 0 : msg='nrad > mesh size!'
3040 0 : LIBPAW_BUG(msg)
3041 : end if
3042 :
3043 : !Compute sizes of arrays and flags
3044 232722 : order=1;if (nkxc>0) order=2
3045 232722 : nspgrad=0;if (xclevel==2) nspgrad=3*nspden-1
3046 : call pawxc_size_dvxc_wrapper(ixc,order,nspden,&
3047 232722 : & usegradient=usegradient,nvxcgrho=nvxcdgr,ndvxc=ndvxc)
3048 232722 : uselaplacian=0 ; usekden=0 !metaGGA contributions are not taken into account here
3049 :
3050 : !--------------------------------------------------------------------------
3051 : !-------------- GGA: computation of the gradient of the density
3052 : !--------------------------------------------------------------------------
3053 :
3054 930888 : LIBPAW_ALLOCATE(grho2,(nrad,(2*nspden-1)*usegradient))
3055 232722 : if (xclevel==2) then
3056 :
3057 : ! grho_updn contains the gradient of the radial part
3058 : ! grho2(:,1:3) contains the squared norm of this gradient (up, dn and total)
3059 284604 : LIBPAW_ALLOCATE(grho_updn,(nrad,nspden))
3060 :
3061 : ! Gradient of radial part of density
3062 213453 : LIBPAW_ALLOCATE(dff,(nrad))
3063 176388 : do ispden=1,nspden
3064 105237 : call nderiv_gen(dff,rho_updn(:,ispden),pawrad)
3065 108468293 : grho_updn(:,ispden)=dff(:)
3066 : end do
3067 71151 : LIBPAW_DEALLOCATE(dff)
3068 :
3069 : ! Squared norm of the gradient
3070 75540803 : grho2(:,1)=grho_updn(:,1)**2
3071 71151 : if (nspden==2) then
3072 32856339 : grho2(:,2)=grho_updn(:,2)**2
3073 32856339 : grho2(:,3)=(grho_updn(:,1)+grho_updn(:,2))**2
3074 : end if
3075 :
3076 : end if
3077 :
3078 : !--------------------------------------------------------------------------
3079 : !-------------- Computation of Exc, Vxc (and Kxc)
3080 : !--------------------------------------------------------------------------
3081 :
3082 : !Allocate arrays
3083 930888 : LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc))
3084 930888 : LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr))
3085 :
3086 : !Call to main XC driver
3087 : call pawxc_drivexc_wrapper(hyb_mixing,ixc,order,nrad,nspden,&
3088 : & usegradient,uselaplacian,usekden,rho_updn,exc,tsxc,vxc,&
3089 : & nvxcdgr,0,0,ndvxc,0,el_temp,grho2=grho2,vxcgrho=dvxcdgr,&
3090 465444 : & dvxc=dvxci,d2vxc=d2vxc,exexch=exexch)
3091 :
3092 : !Transfer the XC kernel
3093 232722 : if (nkxc>0.and.ndvxc>0) then
3094 378 : if (nkxc==1.and.ndvxc==15) then
3095 0 : kxc(1:nrad,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10))
3096 378 : else if (nkxc==3.and.ndvxc==15) then
3097 0 : kxc(1:nrad,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9)
3098 0 : kxc(1:nrad,2)=dvxci(1:nrad,10)
3099 0 : kxc(1:nrad,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11)
3100 378 : else if (nkxc==7.and.ndvxc==8) then
3101 0 : kxc(1:nrad,1)=half*dvxci(1:nrad,1)
3102 0 : kxc(1:nrad,2)=half*dvxci(1:nrad,3)
3103 0 : kxc(1:nrad,3)=quarter*dvxci(1:nrad,5)
3104 0 : kxc(1:nrad,4)=eighth*dvxci(1:nrad,7)
3105 378 : else if (nkxc==7.and.ndvxc==15) then
3106 0 : kxc(1:nrad,1)=half*(dvxci(1:nrad,1)+dvxci(1:nrad,9)+dvxci(1:nrad,10))
3107 0 : kxc(1:nrad,2)=half*dvxci(1:nrad,3)+dvxci(1:nrad,12)
3108 0 : kxc(1:nrad,3)=quarter*dvxci(1:nrad,5)+dvxci(1:nrad,13)
3109 0 : kxc(1:nrad,4)=eighth*dvxci(1:nrad,7)+dvxci(1:nrad,15)
3110 378 : else if (nkxc==19.and.ndvxc==15) then
3111 0 : kxc(1:nrad,1)=dvxci(1:nrad,1)+dvxci(1:nrad,9)
3112 0 : kxc(1:nrad,2)=dvxci(1:nrad,10)
3113 0 : kxc(1:nrad,3)=dvxci(1:nrad,2)+dvxci(1:nrad,11)
3114 0 : kxc(1:nrad,4)=dvxci(1:nrad,3)
3115 0 : kxc(1:nrad,5)=dvxci(1:nrad,4)
3116 0 : kxc(1:nrad,6)=dvxci(1:nrad,5)
3117 0 : kxc(1:nrad,7)=dvxci(1:nrad,6)
3118 0 : kxc(1:nrad,8)=dvxci(1:nrad,7)
3119 0 : kxc(1:nrad,9)=dvxci(1:nrad,8)
3120 0 : kxc(1:nrad,10)=dvxci(1:nrad,12)
3121 0 : kxc(1:nrad,11)=dvxci(1:nrad,13)
3122 0 : kxc(1:nrad,12)=dvxci(1:nrad,14)
3123 0 : kxc(1:nrad,13)=dvxci(1:nrad,15)
3124 : else ! Other cases
3125 257436 : kxc(1:nrad,1:nkxc)=zero
3126 257436 : kxc(1:nrad,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc))
3127 : end if
3128 378 : if (nkxc==7) then
3129 0 : kxc(1:nrad,5)=grho_updn(1:nrad,1) ! Not correct
3130 0 : kxc(1:nrad,6)=grho_updn(1:nrad,1) ! Not correct
3131 0 : kxc(1:nrad,7)=grho_updn(1:nrad,1) ! Not correct
3132 378 : else if (nkxc==19) then
3133 0 : kxc(1:nrad,14)=grho_updn(1:nrad,1) ! Not correct
3134 0 : kxc(1:nrad,15)=grho_updn(1:nrad,2) ! Not correct
3135 0 : kxc(1:nrad,16)=grho_updn(1:nrad,1) ! Not correct
3136 0 : kxc(1:nrad,17)=grho_updn(1:nrad,2) ! Not correct
3137 0 : kxc(1:nrad,18)=grho_updn(1:nrad,1) ! Not correct
3138 0 : kxc(1:nrad,19)=grho_updn(1:nrad,2) ! Not correct
3139 : end if
3140 : end if
3141 232722 : LIBPAW_DEALLOCATE(dvxci)
3142 :
3143 : !--------------------------------------------------------------------------
3144 : !-------------- GGA: gardient corrections
3145 : !--------------------------------------------------------------------------
3146 :
3147 232722 : if (xclevel==2.and.ixc/=13) then
3148 :
3149 : ! Compute the derivative of Exc with respect to the (spin-)density,
3150 : ! or to the norm of the gradient of the (spin-)density,
3151 : ! Further divided by the norm of the gradient of the (spin-)density
3152 : ! The different components of dnexcdn will be
3153 : ! for nspden=1, dnexcdn(:,1)=d(n.exc)/d(n)
3154 : ! and if xclevel=2, dnexcdn(:,2)=1/2*1/|grad n_up|*d(n.exc)/d(|grad n_up|)
3155 : ! + 1/|grad n|*d(n.exc)/d(|grad n|)
3156 : ! (do not forget : |grad n| /= |grad n_up| + |grad n_down|
3157 : ! for nspden=2, dnexcdn(:,1)=d(n.exc)/d(n_up)
3158 : ! dnexcdn(:,2)=d(n.exc)/d(n_down)
3159 : ! and if xclevel=2, dnexcdn(:,3)=1/|grad n_up|*d(n.exc)/d(|grad n_up|)
3160 : ! dnexcdn(:,4)=1/|grad n_down|*d(n.exc)/d(|grad n_down|)
3161 : ! dnexcdn(:,5)=1/|grad n|*d(n.exc)/d(|grad n|)
3162 284604 : LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad))
3163 : ! LDA term
3164 108468293 : dnexcdn(:,1:nspden)=vxc(:,1:nspden)
3165 : ! Additional GGA terms
3166 75540803 : do ir=1,nrad
3167 216654961 : do ispden=1,3 ! spin_up, spin_down and total spin density
3168 183761557 : if (nspden==1.and.ispden>=2) exit
3169 : ! If the norm of the gradient vanishes, then the different terms
3170 : ! vanishes, but the inverse of the gradient diverges,
3171 : ! so skip the update.
3172 141114158 : if(grho2(ir,ispden)<tol24) then
3173 127992 : dnexcdn(ir,ispden+nspden)=zero;cycle
3174 : end if
3175 : ! Compute the derivative of n.e_xc wrt the spin up, spin down,
3176 : ! or total density. In the non-spin-polarized case take the coeff.
3177 : ! that will be multiplied by the gradient of the total density.
3178 140986166 : if (nvxcdgr/=0) then
3179 140986166 : if (nspden==1) then
3180 : ! Definition of dvxcdgr changed in v3.3
3181 42582704 : if (nvxcdgr==3) then
3182 42582704 : coeff=half*dvxcdgr(ir,1)+dvxcdgr(ir,3)
3183 : else
3184 0 : coeff=half*dvxcdgr(ir,1)
3185 : end if
3186 98403462 : else if (nspden==2)then
3187 98403462 : if (nvxcdgr==3) then
3188 98403462 : coeff=dvxcdgr(ir,ispden)
3189 0 : else if (ispden/=3) then
3190 0 : coeff=dvxcdgr(ir,ispden)
3191 : else if (ispden==3) then
3192 : coeff=zero
3193 : end if
3194 : end if
3195 : end if
3196 216455818 : dnexcdn(ir,ispden+nspden)=coeff
3197 : end do
3198 : end do
3199 :
3200 : ! Calculate grad(rho)*dnexcdn and put it in grho_updn(:,:)
3201 71151 : if (nvxcdgr/=0) then
3202 71151 : if(nspden==1)then
3203 42684464 : grho_updn(:,1)=grho_updn(:,1)*dnexcdn(:,2)
3204 : else
3205 32856339 : do ir=1,nrad
3206 32822253 : grho_up=grho_updn(ir,1);grho_tot=grho_up+grho_updn(ir,2)
3207 32822253 : grho_updn(ir,1)=grho_up*dnexcdn(ir,3)+grho_tot*dnexcdn(ir,5)
3208 32856339 : grho_updn(ir,2)=(grho_tot-grho_up)*dnexcdn(ir,4)+grho_tot*dnexcdn(ir,5)
3209 : end do
3210 : end if
3211 : end if
3212 71151 : LIBPAW_DEALLOCATE(dnexcdn)
3213 :
3214 : ! Compute Vxc
3215 213453 : LIBPAW_ALLOCATE(dff,(nrad))
3216 71151 : fact=one;if (nspden==1) fact=two
3217 176388 : do ispden=1,nspden
3218 105237 : call nderiv_gen(dff,grho_updn(:,ispden),pawrad)
3219 108291905 : vxc(2:nrad,ispden)=vxc(2:nrad,ispden)-fact*(dff(2:nrad)+two*grho_updn(2:nrad,ispden)/pawrad%rad(2:nrad))
3220 176388 : call pawrad_deducer0(vxc(:,ispden),nrad,pawrad)
3221 : end do
3222 71151 : LIBPAW_DEALLOCATE(dff)
3223 :
3224 : end if ! xclevel==2
3225 :
3226 : !--------------------------------------------------------------------------
3227 : !-------------- Deallocations
3228 : !--------------------------------------------------------------------------
3229 :
3230 232722 : LIBPAW_DEALLOCATE(grho2)
3231 232722 : LIBPAW_DEALLOCATE(dvxcdgr)
3232 232722 : if (xclevel==2) then
3233 71151 : LIBPAW_DEALLOCATE(grho_updn)
3234 : end if
3235 :
3236 465444 : end subroutine pawxcsph
3237 : !!***
3238 :
3239 : !----------------------------------------------------------------------
3240 :
3241 : !!****f* m_pawxc/pawxcsph_dfpt
3242 : !! NAME
3243 : !! pawxcsph_dfpt
3244 : !!
3245 : !! FUNCTION
3246 : !! Compute XC 1st-order potential for a 1st-order spherical density rho1(r)
3247 : !! associated to a spherical density, both given as (up,dn)
3248 : !! Driver of XC functionals. Only treat collinear spins. LDA and GGA
3249 : !!
3250 : !! INPUTS
3251 : !! cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX
3252 : !! cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX
3253 : !! el_temp=electronic temperature (hartree)
3254 : !! ixc= choice of exchange-correlation scheme (see above and below)
3255 : !! nrad= dimension of the radial mesh
3256 : !! nspden=number of spin-density components
3257 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
3258 : !! rho_updn(nrad,lm_size,nspden)=electron density in real space
3259 : !! up (ispden=1) and down (ispden=2) parts
3260 : !! If nspden=1, rho_updn(:,:,1) contains (1/2).rho_total
3261 : !! rho1_updn(nrad,lm_size,nspden)=electron 1st-order density in real space
3262 : !! up (ispden=1) and down (ispden=2) parts
3263 : !! If nspden=1, rho_updn(:,:,1) contains (1/2).rho1_total
3264 : !! xclevel= XC functional level
3265 : !!
3266 : !! OUTPUT
3267 : !! vxc1((nrad,nspden)= XC 1st-order potential
3268 : !!
3269 : !! SOURCE
3270 :
3271 :
3272 : subroutine pawxcsph_dfpt(cplex_den,cplex_vxc,el_temp,ixc,nrad,nspden,pawrad,rho_updn,rho1_updn,vxc1,xclevel)
3273 :
3274 : !Arguments ------------------------------------
3275 : !scalars
3276 : integer,intent(in) :: cplex_den,cplex_vxc,ixc,nrad,nspden,xclevel
3277 : type(pawrad_type),intent(in) :: pawrad
3278 : real(dp),intent(in) :: el_temp
3279 : !arrays
3280 : real(dp),intent(in) :: rho_updn(nrad,nspden),rho1_updn(cplex_den*nrad,nspden)
3281 : real(dp),intent(out) :: vxc1(cplex_vxc*nrad,nspden)
3282 :
3283 : !Local variables-------------------------------
3284 : !scalars
3285 : integer :: ii,ir,ispden,ivxc,jr,kr,ndvxc,ngrad,nkxc,nvxcdgr,order,usegradient
3286 : real(dp),parameter :: tol24=tol12*tol12
3287 : !real(dp) :: coeff_grho_corr,coeff_grho_dn,coeff_grho_up,fact
3288 : !real(dp) :: grho_grho1,grho_grho1_dn,grho_grho1_up
3289 : character(len=500) :: msg
3290 : real(dp),parameter :: hyb_mixing_ = 0.0_dp
3291 : !arrays
3292 : integer,parameter :: ikxc(4)=(/1,2,2,3/),irho(4)=(/1,2,1,2/)
3293 : real(dp),allocatable :: dff(:),dgg(:),dvxcdgr(:,:),dvxc(:,:),exc(:),tsxc(:),ff(:),gg(:)
3294 : real(dp),allocatable :: grho_updn(:,:),grho1_updn(:,:),grho2(:,:)
3295 : real(dp),allocatable :: kxc(:,:),vxc(:,:)
3296 : !real(dp),allocatable :: gxc1i(:,:),gxc1r(:,:),vxc1i(:,:),vxc1r(:,:)
3297 :
3298 : ! *************************************************************************
3299 :
3300 : if(nspden>2)then
3301 : write(msg, '(a,a,a,i0)' )&
3302 : & 'Only non-spin-polarised or collinear spin-densities are allowed,',ch10,&
3303 : & 'while the argument nspden=',nspden
3304 : LIBPAW_BUG(msg)
3305 : end if
3306 : if(nrad>pawrad%mesh_size)then
3307 : msg='nrad > mesh size!'
3308 : LIBPAW_BUG(msg)
3309 : end if
3310 :
3311 : !Compute sizes of arrays and flags
3312 : order=2 ! We need Kxc
3313 : ngrad=1;if (xclevel==2) ngrad=2 ! ngrad=1 is for LDAs or LSDs; ngrad=2 is for GGAs
3314 : nkxc=2*nspden-1;if (xclevel==2) nkxc=15 ! Not correct for nspden=1
3315 : call pawxc_size_dvxc_wrapper(ixc,order,nspden,usegradient=usegradient,nvxcgrho=nvxcdgr,ndvxc=ndvxc)
3316 :
3317 : !--------------------------------------------------------------------------
3318 : !-------------- GGA: computation of the gradients of the densities
3319 : !--------------------------------------------------------------------------
3320 :
3321 : LIBPAW_ALLOCATE(grho2,(nrad,(2*nspden-1)*usegradient))
3322 : if (ngrad==2) then
3323 :
3324 : LIBPAW_ALLOCATE(grho_updn,(nrad,nspden))
3325 : LIBPAW_ALLOCATE(grho1_updn,(cplex_den*nrad,nspden))
3326 :
3327 : ! Gradient of density
3328 : LIBPAW_ALLOCATE(dff,(nrad))
3329 : do ispden=1,nspden
3330 : call nderiv_gen(dff,rho_updn(:,ispden),pawrad)
3331 : grho_updn(:,ispden)=dff(:)
3332 : end do
3333 : ! Gradient of 1st-order density
3334 : if (cplex_den==1) then
3335 : do ispden=1,nspden
3336 : call nderiv_gen(dff,rho1_updn(:,ispden),pawrad)
3337 : grho1_updn(:,ispden)=dff(:)
3338 : end do
3339 : else
3340 : LIBPAW_ALLOCATE(ff,(nrad))
3341 : LIBPAW_ALLOCATE(gg,(nrad))
3342 : LIBPAW_ALLOCATE(dgg,(nrad))
3343 : do ispden=1,nspden
3344 : do ir=1,nrad
3345 : ff(ir)=rho1_updn(2*ir-1,ispden)
3346 : gg(ir)=rho1_updn(2*ir ,ispden)
3347 : end do
3348 : call nderiv_gen(dff,ff,pawrad)
3349 : call nderiv_gen(dgg,gg,pawrad)
3350 : do ir=1,nrad
3351 : grho1_updn(2*ir-1,ispden)=dff(ir)
3352 : grho1_updn(2*ir ,ispden)=dgg(ir)
3353 : end do
3354 : end do
3355 : LIBPAW_DEALLOCATE(ff)
3356 : LIBPAW_DEALLOCATE(gg)
3357 : LIBPAW_DEALLOCATE(dgg)
3358 : end if
3359 : LIBPAW_DEALLOCATE(dff)
3360 :
3361 : ! Squared norm of the gradient
3362 : grho2(:,1)=grho_updn(:,1)**2
3363 : if (nspden==2) then
3364 : grho2(:,2)=grho_updn(:,2)**2
3365 : grho2(:,3)=(grho_updn(:,1)+grho_updn(:,2))**2
3366 : end if
3367 :
3368 : end if
3369 :
3370 : !--------------------------------------------------------------------------
3371 : !-------------- Computation of Kxc (and Exc, Vxc)
3372 : !--------------------------------------------------------------------------
3373 :
3374 : LIBPAW_ALLOCATE(exc,(nrad))
3375 : LIBPAW_ALLOCATE(tsxc,(nrad))
3376 : LIBPAW_ALLOCATE(vxc,(nrad,nspden))
3377 : LIBPAW_ALLOCATE(dvxc,(nrad,ndvxc))
3378 : LIBPAW_ALLOCATE(dvxcdgr,(nrad,nvxcdgr))
3379 :
3380 : !Call to main XC driver
3381 : call pawxc_drivexc_wrapper(hyb_mixing_,ixc,order,nrad,nspden,usegradient,0,0,&
3382 : & rho_updn,exc,tsxc,vxc,nvxcdgr,0,0,ndvxc,0,el_temp,&
3383 : & grho2=grho2,vxcgrho=dvxcdgr,dvxc=dvxc)
3384 :
3385 : !Transfer the XC kernel
3386 : LIBPAW_ALLOCATE(kxc,(nrad,nkxc))
3387 : if (nkxc>0.and.ndvxc>0) then
3388 : if (nkxc==1.and.ndvxc==15) then
3389 : kxc(1:nrad,1)=half*(dvxc(1:nrad,1)+dvxc(1:nrad,9)+dvxc(1:nrad,10))
3390 : else if (nkxc==3.and.ndvxc==15) then
3391 : kxc(1:nrad,1)=dvxc(1:nrad,1)+dvxc(1:nrad,9)
3392 : kxc(1:nrad,2)=dvxc(1:nrad,10)
3393 : kxc(1:nrad,3)=dvxc(1:nrad,2)+dvxc(1:nrad,11)
3394 : else if (nkxc==7.and.ndvxc==8) then
3395 : kxc(1:nrad,1)=half*dvxc(1:nrad,1)
3396 : kxc(1:nrad,2)=half*dvxc(1:nrad,3)
3397 : kxc(1:nrad,3)=quarter*dvxc(1:nrad,5)
3398 : kxc(1:nrad,4)=eighth*dvxc(1:nrad,7)
3399 : else if (nkxc==7.and.ndvxc==15) then
3400 : kxc(1:nrad,1)=half*(dvxc(1:nrad,1)+dvxc(1:nrad,9)+dvxc(1:nrad,10))
3401 : kxc(1:nrad,2)=half*dvxc(1:nrad,3)+dvxc(1:nrad,12)
3402 : kxc(1:nrad,3)=quarter*dvxc(1:nrad,5)+dvxc(1:nrad,13)
3403 : kxc(1:nrad,4)=eighth*dvxc(1:nrad,7)+dvxc(1:nrad,15)
3404 : else if (nkxc==19.and.ndvxc==15) then
3405 : kxc(1:nrad,1)=dvxc(1:nrad,1)+dvxc(1:nrad,9)
3406 : kxc(1:nrad,2)=dvxc(1:nrad,10)
3407 : kxc(1:nrad,3)=dvxc(1:nrad,2)+dvxc(1:nrad,11)
3408 : kxc(1:nrad,4)=dvxc(1:nrad,3)
3409 : kxc(1:nrad,5)=dvxc(1:nrad,4)
3410 : kxc(1:nrad,6)=dvxc(1:nrad,5)
3411 : kxc(1:nrad,7)=dvxc(1:nrad,6)
3412 : kxc(1:nrad,8)=dvxc(1:nrad,7)
3413 : kxc(1:nrad,9)=dvxc(1:nrad,8)
3414 : kxc(1:nrad,10)=dvxc(1:nrad,12)
3415 : kxc(1:nrad,11)=dvxc(1:nrad,13)
3416 : kxc(1:nrad,12)=dvxc(1:nrad,14)
3417 : kxc(1:nrad,13)=dvxc(1:nrad,15)
3418 : else ! Other cases
3419 : kxc(1:nrad,1:nkxc)=zero
3420 : kxc(1:nrad,1:min(nkxc,ndvxc))=dvxc(1:nrad,1:min(nkxc,ndvxc))
3421 : end if
3422 : if (nkxc==7) then
3423 : kxc(1:nrad,5)=zero ! Not correct
3424 : kxc(1:nrad,6)=zero ! Not correct
3425 : kxc(1:nrad,7)=zero ! Not correct
3426 : else if (nkxc==19) then
3427 : kxc(1:nrad,14)=zero ! Not correct
3428 : kxc(1:nrad,15)=zero ! Not correct
3429 : kxc(1:nrad,16)=zero ! Not correct
3430 : kxc(1:nrad,17)=zero ! Not correct
3431 : kxc(1:nrad,18)=zero ! Not correct
3432 : kxc(1:nrad,19)=zero ! Not correct
3433 : end if
3434 : end if
3435 :
3436 : LIBPAW_DEALLOCATE(exc)
3437 : LIBPAW_DEALLOCATE(tsxc)
3438 : LIBPAW_DEALLOCATE(vxc)
3439 : LIBPAW_DEALLOCATE(dvxc)
3440 : LIBPAW_DEALLOCATE(dvxcdgr)
3441 :
3442 : !--------------------------------------------------------------------------
3443 : !-------------- LDA
3444 : !--------------------------------------------------------------------------
3445 : if (ngrad==1.or.ixc==13) then
3446 :
3447 : do ispden=1,3*nspden-2
3448 : ivxc=1;if (ispden>2) ivxc=2
3449 : if (cplex_vxc==1.and.cplex_den==1) then
3450 : vxc1(:,ivxc)=vxc1(:,ivxc)+kxc(:,ikxc(ii))*rho1_updn(:,irho(ii))
3451 : else
3452 : do ir=1,nrad
3453 : jr=cplex_den*(ir-1);kr=cplex_vxc*(ir-1)
3454 : do ii=1,1+(cplex_den*cplex_vxc)/4
3455 : jr=jr+1;kr=kr+1
3456 : vxc1(kr,ivxc)=vxc1(kr,ivxc)+kxc(ir,ikxc(ii))*rho1_updn(jr,irho(ii))
3457 : end do
3458 : end do
3459 : end if
3460 : end do
3461 :
3462 : ! --------------------------------------------------------------------------
3463 : ! -------------- GGA
3464 : ! --------------------------------------------------------------------------
3465 : else
3466 :
3467 : ! FOR NSPDEN=1, should eliminate computation of gxc1i(...), vxc1i(...)
3468 :
3469 : ! LIBPAW_ALLOCATE(vxc1r,(nrad,2))
3470 : ! LIBPAW_ALLOCATE(vxc1i,(nrad,2))
3471 : ! LIBPAW_ALLOCATE(gxc1r,(nrad,2))
3472 : ! LIBPAW_ALLOCATE(gxc1i,(nrad,2))
3473 : ! do ir=1,nrad
3474 : ! if (cplex_vxc==1) then ! cplex_vxc==1 and (cplex_den==1 or cplex_den=2)
3475 : ! jr=cplex_den*(ir-1)+1
3476 : ! grho_grho1_up=grho_updn(ir,1)*grho1_updn(jr,1)
3477 : ! grho_grho1_dn=grho_updn(ir,2)*grho1_updn(jr,2)
3478 : ! vxc1r(ir,1)=(kxc(ir, 1)+kxc(ir, 9))*rho1_updn(jr,1)+kxc(ir,10)*rho1_updn(jr,2) &
3479 : ! & +kxc(ir, 5)*grho_grho1_up+kxc(ir,13)*grho_grho1
3480 : ! vxc1r(ir,2)=(kxc(ir, 2)+kxc(ir,11))*rho1_updn(jr,2)+kxc(ir,10)*rho1_updn(jr,1) &
3481 : ! & +kxc(ir, 6)*grho_grho1_dn+kxc(ir,14)*grho_grho1
3482 : ! coeff_grho_corr=kxc(ir,13)*rho1_updn(jr,1)+kxc(ir,14)*rho1_updn(jr,2)+kxc(ir,15)*grho_grho1
3483 : ! coeff_grho_up =kxc(ir, 5)*rho1_updn(jr,1)+kxc(ir, 7)*grho_grho1_up
3484 : ! coeff_grho_dn =kxc(ir, 6)*rho1_updn(jr,2)+kxc(ir, 8)*grho_grho1_dn
3485 : ! gxc1r(ir,1)=(kxc(ir, 3)+kxc(ir,12))*grho1_updn(jr,1)+kxc(ir,12)*grho1_updn(jr,2) &
3486 : ! & +coeff_grho_up*grho_updn(jr,1)+coeff_grho_corr*(grho_updn(jr,1)+grho_updn(jr,2))
3487 : ! gxc1r(ir,2)=(kxc(ir, 4)+kxc(ir,12))*grho1_updn(jr,2)+kxc(ir,12)*grho1_updn(jr,1) &
3488 : ! & +coeff_grho_dn*grho_updn(jr,2)+coeff_grho_corr*(grho_updn(jr,1)+grho_updn(jr,2))
3489 : ! end if
3490 : ! if (grho2(ir,1)<tol24) gxc1r(ir,:)=zero ! ???
3491 : ! end do
3492 : !
3493 : ! ! Apply divergence
3494 : ! fact=one;if (nspden==1) fact=two ! Is it true ? we force nspden=2 for gxc...
3495 : ! if (cplex_vxc==1) then
3496 : ! LIBPAW_ALLOCATE(dff,(nrad))
3497 : ! do ispden=1,nspden
3498 : ! call nderiv_gen(dff,gxc1r(:,ispden),pawrad)
3499 : ! vxc1(2:nrad,ispden)=vxc1r(2:nrad,ispden)-fact*(dff(2:nrad)+two*gxc1r(2:nrad,ispden)/pawrad%rad(2:nrad))
3500 : ! call pawrad_deducer0(vxc1(:,ispden),nrad,pawrad)
3501 : ! end do
3502 : ! LIBPAW_DEALLOCATE(dff)
3503 : ! else
3504 : ! LIBPAW_ALLOCATE(dff,(nrad))
3505 : ! LIBPAW_ALLOCATE(dgg,(nrad))
3506 : ! LIBPAW_ALLOCATE(ff,(nrad))
3507 : ! LIBPAW_ALLOCATE(gg,(nrad))
3508 : ! do ispden=1,nspden
3509 : ! call nderiv_gen(dff,gxc1r(:,ispden),pawrad)
3510 : ! call nderiv_gen(dgg,gxc1i(:,ispden),pawrad)
3511 : ! ff(2:nrad)=vxc1r(2:nrad,ispden)-fact*(dff(2:nrad)+two*gxc1r(2:nrad,ispden)/pawrad%rad(2:nrad))
3512 : ! gg(2:nrad)=vxc1i(2:nrad,ispden)-fact*(dgg(2:nrad)+two*gxc1i(2:nrad,ispden)/pawrad%rad(2:nrad))
3513 : ! call pawrad_deducer0(ff,nrad,pawrad)
3514 : ! call pawrad_deducer0(gg,nrad,pawrad)
3515 : ! do ir=1,nrad
3516 : ! vxc1(2*ir-1,ispden)=ff(ir)
3517 : ! vxc1(2*ir ,ispden)=gg(ir)
3518 : ! end do
3519 : ! end do
3520 : ! LIBPAW_DEALLOCATE(dff)
3521 : ! LIBPAW_DEALLOCATE(dgg)
3522 : ! LIBPAW_DEALLOCATE(ff)
3523 : ! LIBPAW_DEALLOCATE(gg)
3524 : ! end if
3525 : !
3526 : ! LIBPAW_DEALLOCATE(vxc1r)
3527 : ! LIBPAW_DEALLOCATE(vxc1i)
3528 : ! LIBPAW_DEALLOCATE(gxc1r)
3529 : ! LIBPAW_DEALLOCATE(gxc1i)
3530 :
3531 : end if ! ngrad==2
3532 :
3533 : !--------------------------------------------------------------------------
3534 : !-------------- Deallocations
3535 : !--------------------------------------------------------------------------
3536 :
3537 : LIBPAW_DEALLOCATE(grho2)
3538 : LIBPAW_DEALLOCATE(kxc)
3539 : if (ngrad==2) then
3540 : LIBPAW_DEALLOCATE(grho_updn)
3541 : LIBPAW_DEALLOCATE(grho1_updn)
3542 : end if
3543 :
3544 : end subroutine pawxcsph_dfpt
3545 : !!***
3546 :
3547 : !----------------------------------------------------------------------
3548 :
3549 : !!****f* m_pawxc/pawxcsphpositron
3550 : !! NAME
3551 : !! pawxcsphpositron
3552 : !!
3553 : !! FUNCTION
3554 : !! Compute electron-positron XC energy and potential for spherical densities rho_el(r) rho_pos(r)
3555 : !! Driver of XC functionals. LDA and GGA
3556 : !!
3557 : !! INPUTS
3558 : !! calctype=type of electron-positron calculation:
3559 : !! calctype=1 : positron in electronic density
3560 : !! calctype=2 : electrons in positronic density
3561 : !! ixcpositron= choice of elctron-positron exchange-correlation scheme
3562 : !! nrad= dimension of the radial mesh
3563 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
3564 : !! posdensity0_limit=True if we are in the zero positron density limit
3565 : !! rho(nrad,lm_size)=electron (or positron) density in real space
3566 : !! Contents depends on calctype value:
3567 : !! calctype=1: rho is the positronic density
3568 : !! calctype=2: rho is the electronic density
3569 : !! rho_ep(nrad,lm_size)=electron (or positron) density in real space
3570 : !! Contents depends on calctype value:
3571 : !! calctype=1: rho_ep is the electronic density
3572 : !! calctype=2: rho_ep is the positronic density
3573 : !!
3574 : !! OUTPUT
3575 : !! fxc(nrad)= electron-positron XC energy per unit volume
3576 : !! vxce(nrad)= electron-positron XC potential for the electron
3577 : !! vxcp(nrad)= electron-positron XC potential for the positron
3578 : !!
3579 : !! SOURCE
3580 :
3581 58760 : subroutine pawxcsphpositron(calctype,fxc,ixcpositron,nrad,pawrad,posdensity0_limit,rho,rho_ep,vxce,vxcp)
3582 :
3583 : !Arguments ------------------------------------
3584 : !scalars
3585 : integer,intent(in) :: calctype,ixcpositron,nrad
3586 : logical,intent(in) :: posdensity0_limit
3587 : type(pawrad_type),intent(in) :: pawrad
3588 : !arrays
3589 : real(dp),intent(in) :: rho(nrad),rho_ep(nrad)
3590 : real(dp),intent(out) :: fxc(nrad),vxce(nrad),vxcp(nrad)
3591 :
3592 : !Local variables-------------------------------
3593 : !scalars
3594 : integer :: ngr
3595 : character(len=500) :: msg
3596 : !arrays
3597 58760 : real(dp),allocatable :: dff(:),rhograd(:),rhograd2(:),vxcegr(:)
3598 :
3599 : ! *************************************************************************
3600 :
3601 58760 : if(nrad>pawrad%mesh_size)then
3602 0 : msg='nrad > mesh size!'
3603 0 : LIBPAW_BUG(msg)
3604 : end if
3605 :
3606 : !Need gradient of density for GGA
3607 58760 : ngr=0;if (ixcpositron==3.or.ixcpositron==31) ngr=nrad
3608 176280 : LIBPAW_ALLOCATE(rhograd,(ngr))
3609 117520 : LIBPAW_ALLOCATE(rhograd2,(ngr))
3610 117520 : LIBPAW_ALLOCATE(vxcegr,(ngr))
3611 58760 : if (ngr==nrad) then
3612 0 : if (calctype==1) then
3613 0 : call nderiv_gen(rhograd,rho_ep,pawrad)
3614 0 : else if (calctype==2) then
3615 0 : call nderiv_gen(rhograd,rho,pawrad)
3616 : end if
3617 0 : rhograd2(:)=rhograd(:)**2
3618 : end if
3619 :
3620 : !---- Computation of Fxc and Vxc for the positron
3621 : !rho is the positronic density
3622 : !rho_ep is the electronic density
3623 58760 : if (calctype==1) then
3624 23910 : call pawxc_xcpositron_wrapper(fxc,rhograd2,ixcpositron,ngr,nrad,posdensity0_limit,rho_ep,rho,vxce,vxcegr,vxcp)
3625 :
3626 : ! ---- Computation of Exc and Vxc for the electron
3627 : ! rho is the electronic density
3628 : ! rho_ep is the positronic density
3629 34850 : else if (calctype==2) then
3630 34850 : call pawxc_xcpositron_wrapper(fxc,rhograd2,ixcpositron,ngr,nrad,posdensity0_limit,rho,rho_ep,vxce,vxcegr,vxcp)
3631 : end if
3632 :
3633 58760 : LIBPAW_DEALLOCATE(rhograd2)
3634 :
3635 : !---- GGA - gradient corrections
3636 58760 : if (ngr==nrad) then
3637 0 : LIBPAW_ALLOCATE(dff,(nrad))
3638 0 : vxcegr(1:nrad)=vxcegr(1:nrad)*rhograd(1:nrad)
3639 0 : call nderiv_gen(dff,vxcegr,pawrad)
3640 0 : vxcp(2:nrad)=vxcp(2:nrad)-(dff(2:nrad)+two*vxcegr(2:nrad)/pawrad%rad(2:nrad))
3641 0 : call pawrad_deducer0(vxcp,nrad,pawrad)
3642 0 : LIBPAW_DEALLOCATE(dff)
3643 : end if
3644 :
3645 58760 : LIBPAW_DEALLOCATE(vxcegr)
3646 58760 : LIBPAW_DEALLOCATE(rhograd)
3647 :
3648 58760 : end subroutine pawxcsphpositron
3649 : !!***
3650 :
3651 : !----------------------------------------------------------------------
3652 :
3653 : !!****f* m_pawxc/pawxcsum
3654 : !! NAME
3655 : !! pawxcsum
3656 : !!
3657 : !! FUNCTION
3658 : !! Compute useful sums of moments of densities needed to compute on-site contributions to XC energy and potential
3659 : !! First order sums:
3660 : !! Sum1(1)=Sum_L{Rho1_L(r)**2}
3661 : !! Sum1(2)=Sum_L{Rho1_L(r)*Rho2_L(r)}
3662 : !! Sum1(3)=Sum_L{Rho2_L(r)**2}
3663 : !! With L>0
3664 : !! Second order sums:
3665 : !! Sum2(L,1)=Sum_L1_L2{Rho1_L1(r)*Rho1_L1(r)*Gaunt_(L,L1,L2)}
3666 : !! Sum2(L,2)=Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)}
3667 : !! Sum2(L,3)=Sum_L1_L2{Rho2_L2(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)}
3668 : !! With L1>0, L2>0
3669 : !!
3670 : !! INPUTS
3671 : !! cplex1=if 1, density Rho1 is REAL, if 2, COMPLEX
3672 : !! cplex2=if 1, density Rho2 is REAL, if 2, COMPLEX
3673 : !! cplexsum=if 1, output sums (Sum1 and Sum2) are REAL, if 2, COMPLEX
3674 : !! lmselect1(lm_size)=select the non-zero LM-moments of input density Rho1
3675 : !! lmselect2(lm_size)=select the non-zero LM-moments of input density Rho2
3676 : !! lm_size=number of moments of the density
3677 : !! nrad=number of radial points
3678 : !! nsums=number of sums to compute:
3679 : !! if nsums=1, computes only
3680 : !! Sum1(1)=Sum_L{Rho1_L(r)*Rho2_L(r)}
3681 : !! Sum2(L,1)=Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)}
3682 : !! if nsums=3, computes all sums (Sum1(1:3), Sum2(1:3)
3683 : !! option= 1: compute first order sums
3684 : !! 2: compute first and second order sums
3685 : !! pawang <type(pawang_type)>=paw angular mesh and related data
3686 : !! rho1(cplex1*nrad,lm_size)=moments of first density on each radial point
3687 : !! rho2(cplex2*nrad,lm_size)=moments of 2nd density on each radial point
3688 : !!
3689 : !! OUTPUT
3690 : !! sum1(cplexsum*nrad,nsums)=first order sums
3691 : !! === if option>=2
3692 : !! sum2(cplexsum*nrad,lm_size,nsums)=second order sums
3693 : !!
3694 : !! SOURCE
3695 :
3696 100043 : subroutine pawxcsum(cplex1,cplex2,cplexsum,lmselect1,lmselect2,lm_size,nrad,nsums,&
3697 100043 : & option,pawang,rho1,rho2,sum1,sum2)
3698 :
3699 : !Arguments ------------------------------------
3700 : !scalars
3701 : integer,intent(in) :: cplex1,cplex2,cplexsum,lm_size,nrad,nsums,option
3702 : !arrays
3703 : logical,intent(in) :: lmselect1(lm_size),lmselect2(lm_size)
3704 : real(dp),intent(in) :: rho1(cplex1*nrad,lm_size),rho2(cplex2*nrad,lm_size)
3705 : real(dp),intent(out) :: sum1(cplexsum*nrad,nsums),sum2(cplexsum*nrad,lm_size,nsums*(option/2))
3706 : type(pawang_type),intent(in) :: pawang
3707 :
3708 : !Local variables-------------------------------
3709 : !scalars
3710 : integer :: ilm,ilm1,ilm2,ir,i1r,i2r,i3r,isel
3711 : real(dp) :: fact,ro1i,ro1r,ro2i,ro2r
3712 : character(len=500) :: msg
3713 : !arrays
3714 :
3715 : !************************************************************************
3716 :
3717 100043 : if(nsums/=1.and.nsums/=3) then
3718 0 : msg='nsums must be 1 or 3!'
3719 0 : LIBPAW_BUG(msg)
3720 : end if
3721 100043 : if(pawang%gnt_option==0) then
3722 0 : msg='pawang%gnt_option=0!'
3723 0 : LIBPAW_BUG(msg)
3724 : end if
3725 :
3726 100043 : if (option>=1) then
3727 :
3728 : ! SUM1(r)= Sum_L{Rho1_L(r)*Rho2_L(r)} (L>0)
3729 : ! --------------------------------------------------
3730 175455444 : sum1=zero
3731 :
3732 : ! ===== All input/output densities are REAL ====
3733 100043 : if (cplex1==1.and.cplex2==1.and.cplexsum==1) then
3734 : ! One sum to compute
3735 98651 : if (nsums==1) then
3736 611599 : do ilm=2,lm_size
3737 611599 : if (lmselect1(ilm).and.lmselect2(ilm)) then
3738 353735765 : sum1(:,1)=sum1(:,1)+rho1(:,ilm)*rho2(:,ilm)
3739 : end if
3740 : end do
3741 : ! Three sums to compute
3742 : else
3743 402806 : do ilm=2,lm_size
3744 376402 : if (lmselect1(ilm)) then
3745 233385496 : sum1(:,1)=sum1(:,1)+rho1(:,ilm)**2
3746 228572700 : if (lmselect2(ilm)) sum1(:,2)=sum1(:,2)+rho1(:,ilm)*rho2(:,ilm)
3747 : end if
3748 232201356 : if (lmselect2(ilm)) sum1(:,3)=sum1(:,3)+rho2(:,ilm)**2
3749 : end do
3750 : end if
3751 :
3752 : ! ===== At least one of Rho1 and Rho2 is COMPLEX ====
3753 : else
3754 : ! One sum to compute
3755 1392 : if (nsums==1) then
3756 12528 : do ilm=2,lm_size
3757 12528 : if (lmselect1(ilm).and.lmselect2(ilm)) then
3758 4749120 : do ir=1,nrad
3759 4739328 : i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1
3760 4739328 : ro1r=rho1(i1r,ilm);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm)
3761 4739328 : ro2r=rho2(i2r,ilm);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm)
3762 4739328 : sum1(i3r,1)=sum1(i3r,1)+ro1r*ro2r-ro1i*ro2i
3763 4749120 : if (cplexsum==2) sum1(i3r+1,1)=sum1(i3r+1,1)+ro1r*ro2i+ro1i*ro2r
3764 : end do
3765 : end if
3766 : end do
3767 : ! Three sums to compute
3768 : else
3769 0 : do ilm=2,lm_size
3770 0 : do ir=1,nrad
3771 0 : i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1
3772 0 : ro1r=rho1(i1r,ilm);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm)
3773 0 : ro2r=rho2(i2r,ilm);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm)
3774 0 : if (lmselect1(ilm)) then
3775 0 : sum1(i3r,1)=sum1(i3r,1)+ro1r**2-ro1i**2
3776 0 : if (lmselect2(ilm)) sum1(i3r,2)=sum1(i3r,2)+ro1r*ro2r-ro1i*ro2i
3777 : end if
3778 0 : if (lmselect2(ilm)) sum1(i3r,3)=sum1(i3r,3)+ro2r**2-ro2i**2
3779 0 : if (cplexsum==2) then
3780 0 : if (lmselect1(ilm)) then
3781 0 : sum1(i3r+1,1)=sum1(i3r+1,1)+two*ro1r*ro1i
3782 0 : if (lmselect2(ilm)) sum1(i3r+1,2)=sum1(i3r+1,2)+ro1r*ro2i+ro1i*ro2r
3783 : end if
3784 0 : if (lmselect2(ilm)) sum1(i3r+1,3)=sum1(i3r+1,3)+two*ro2r*ro2i
3785 : end if
3786 : end do
3787 : end do
3788 : end if ! nsums
3789 : end if ! cplex
3790 :
3791 : end if !option
3792 :
3793 100043 : if (option>=2) then
3794 :
3795 : ! SUM2(r,L)= Sum_L1_L2{Rho1_L1(r)*Rho2_L2(r)*Gaunt_(L,L1,L2)} (L1>0, L2>0)
3796 : ! --------------------------------------------------
3797 124099770 : sum2=zero
3798 : ! ===== All input/output densities are REAL ====
3799 17714 : if (cplex1==1.and.cplex2==1.and.cplexsum==1) then
3800 : ! One sum to compute
3801 16322 : if (nsums==1) then
3802 162736 : do ilm=1,lm_size
3803 1402960 : do ilm1=2,lm_size
3804 1386952 : if (lmselect1(ilm1)) then
3805 5428110 : do ilm2=2,ilm1
3806 5428110 : if (lmselect2(ilm2)) then
3807 3612162 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3808 3612162 : if (isel>0) then
3809 452138 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
3810 338985852 : sum2(:,ilm,1)=sum2(:,ilm,1)+fact*rho1(:,ilm1)*rho2(:,ilm2)
3811 : end if
3812 : end if
3813 : end do
3814 : end if
3815 : end do
3816 : end do
3817 : ! Three sums to compute
3818 : else
3819 8164 : do ilm=1,lm_size
3820 196250 : do ilm1=2,lm_size
3821 196250 : if (lmselect1(ilm1)) then
3822 2341550 : do ilm2=2,ilm1
3823 2341550 : if (lmselect1(ilm2)) then
3824 1970850 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3825 1970850 : if (isel>0) then
3826 158926 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
3827 169361568 : sum2(:,ilm,1)=sum2(:,ilm,1)+fact*rho1(:,ilm1)*rho1(:,ilm2)
3828 : end if
3829 : end if
3830 : end do
3831 : end if
3832 : end do
3833 196250 : do ilm1=2,lm_size
3834 196250 : if (lmselect2(ilm1)) then
3835 2341550 : do ilm2=2,ilm1
3836 2341550 : if (lmselect2(ilm2)) then
3837 1970850 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3838 1970850 : if (isel>0) then
3839 158926 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
3840 169361568 : sum2(:,ilm,3)=sum2(:,ilm,3)+fact*rho2(:,ilm1)*rho2(:,ilm2)
3841 : end if
3842 : end if
3843 : end do
3844 : end if
3845 : end do
3846 196564 : do ilm1=2,lm_size
3847 196250 : if (lmselect1(ilm1)) then
3848 2341550 : do ilm2=2,ilm1
3849 2341550 : if (lmselect2(ilm2)) then
3850 1970850 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3851 1970850 : if (isel>0) then
3852 158926 : fact=pawang%realgnt(isel)
3853 169361568 : sum2(:,ilm,2)=sum2(:,ilm,2)+fact*rho1(:,ilm1)*rho2(:,ilm2)
3854 : end if
3855 : end if
3856 : end do
3857 170950 : if (ilm1<lm_size) then
3858 2095300 : do ilm2=ilm1+1,lm_size
3859 2095300 : if (lmselect2(ilm2)) then
3860 1799900 : isel=pawang%gntselect(ilm,ilm1+ilm2*(ilm2-1)/2)
3861 1799900 : if (isel>0) then
3862 133768 : fact=pawang%realgnt(isel)
3863 142549344 : sum2(:,ilm,2)=sum2(:,ilm,2)+fact*rho1(:,ilm1)*rho2(:,ilm2)
3864 : end if
3865 : end if
3866 : end do
3867 : end if
3868 : end if
3869 : end do
3870 : end do
3871 : end if ! nsums
3872 :
3873 : ! ===== At least one of Rho1 and Rho2 is COMPLEX ====
3874 : else
3875 : ! One sum to compute
3876 1392 : if (nsums==1) then
3877 13920 : do ilm=1,lm_size
3878 114144 : do ilm1=2,lm_size
3879 112752 : if (lmselect1(ilm1)) then
3880 484704 : do ilm2=2,ilm1
3881 484704 : if (lmselect2(ilm2)) then
3882 372384 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3883 372384 : if (isel>0) then
3884 50280 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
3885 24385712 : do ir=1,nrad
3886 24335432 : i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1
3887 24335432 : ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1)
3888 24335432 : ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2)
3889 24335432 : sum2(i3r,ilm,1)=sum2(i3r,ilm,1)+fact*(ro1r*ro2r-ro1i*ro2i)
3890 24385712 : if (cplexsum==2) sum2(i3r+1,ilm,1)=sum2(i3r+1,ilm,1)+fact*(ro1r*ro2i+ro1i*ro2r)
3891 : end do
3892 : end if
3893 : end if
3894 : end do
3895 : end if
3896 : end do
3897 : end do
3898 : ! Three sums to compute
3899 : else
3900 0 : do ilm=2,lm_size
3901 0 : do ir=1,nrad
3902 0 : i1r=cplex1*(ir-1)+1;i2r=cplex2*(ir-1)+1;i3r=cplexsum*(ir-1)+1
3903 0 : do ilm1=2,lm_size
3904 0 : if (lmselect1(ilm1)) then
3905 0 : ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1)
3906 0 : do ilm2=2,ilm1
3907 0 : if (lmselect1(ilm2)) then
3908 0 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3909 0 : if (isel>0) then
3910 0 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
3911 0 : ro2r=rho1(i1r,ilm2);ro2i=zero;if (cplex1==2) ro2i=rho1(i1r+1,ilm2)
3912 0 : sum2(i3r,ilm,1)=sum2(i3r,ilm,1)+fact*(ro1r*ro2r-ro1i*ro2i)
3913 0 : if (cplexsum==2) sum2(i3r+1,ilm,1)=sum2(i3r+1,ilm,1)+fact*(ro1r*ro2i+ro1i*ro2r)
3914 : end if
3915 : end if
3916 : end do
3917 : end if
3918 : end do
3919 0 : do ilm1=2,lm_size
3920 0 : if (lmselect2(ilm1)) then
3921 0 : ro1r=rho2(i2r,ilm1);ro1i=zero;if (cplex2==2) ro1i=rho2(i2r+1,ilm1)
3922 0 : do ilm2=2,ilm1
3923 0 : if (lmselect2(ilm2)) then
3924 0 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3925 0 : if (isel>0) then
3926 0 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
3927 0 : ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2)
3928 0 : sum2(i3r,ilm,3)=sum2(i3r,ilm,3)+fact*(ro1r*ro2r-ro1i*ro2i)
3929 0 : if (cplexsum==2) sum2(i3r+1,ilm,3)=sum2(i3r+1,ilm,3)+fact*(ro1r*ro2i+ro1i*ro2r)
3930 : end if
3931 : end if
3932 : end do
3933 : end if
3934 : end do
3935 0 : do ilm1=2,lm_size
3936 0 : if (lmselect1(ilm1)) then
3937 0 : ro1r=rho1(i1r,ilm1);ro1i=zero;if (cplex1==2) ro1i=rho1(i1r+1,ilm1)
3938 0 : do ilm2=2,ilm1
3939 0 : if (lmselect2(ilm2)) then
3940 0 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3941 0 : if (isel>0) then
3942 0 : fact=pawang%realgnt(isel)
3943 0 : ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2)
3944 0 : sum2(i3r,ilm,2)=sum2(i3r,ilm,2)+fact*(ro1r*ro2r-ro1i*ro2i)
3945 0 : if (cplexsum==2) sum2(i3r+1,ilm,2)=sum2(i3r+1,ilm,2)+fact*(ro1r*ro2i+ro1i*ro2r)
3946 : end if
3947 : end if
3948 : end do
3949 0 : if (ilm1<lm_size) then
3950 0 : do ilm2=ilm1+1,lm_size
3951 0 : if (lmselect2(ilm2)) then
3952 0 : isel=pawang%gntselect(ilm,ilm1+ilm2*(ilm2-1)/2)
3953 0 : if (isel>0) then
3954 0 : fact=pawang%realgnt(isel)
3955 0 : ro2r=rho2(i2r,ilm2);ro2i=zero;if (cplex2==2) ro2i=rho2(i2r+1,ilm2)
3956 0 : sum2(i3r,ilm,2)=sum2(i3r,ilm,2)+fact*(ro1r*ro2r-ro1i*ro2i)
3957 0 : if (cplexsum==2) sum2(i3r+1,ilm,2)=sum2(i3r+1,ilm,2)+fact*(ro1r*ro2i+ro1i*ro2r)
3958 : end if
3959 : end if
3960 : end do
3961 : end if
3962 : end if
3963 : end do
3964 : end do
3965 : end do
3966 : end if ! nsums
3967 :
3968 : end if ! cplex
3969 :
3970 : end if !option
3971 :
3972 100043 : end subroutine pawxcsum
3973 : !!***
3974 :
3975 : !----------------------------------------------------------------------
3976 :
3977 : !!****f* m_pawxc/pawxcm
3978 : !! NAME
3979 : !! pawxcm
3980 : !!
3981 : !! FUNCTION
3982 : !! Start from the density or spin-density, and compute xc correlation
3983 : !! potential and energies inside a paw sphere.
3984 : !! LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS
3985 : !! Driver of XC functionals.
3986 : !!
3987 : !! INPUTS
3988 : !! corexc(nrad)=core density on radial grid
3989 : !! exexch= choice of <<<local>>> exact exchange. Active if exexch=3 (only for PBE)
3990 : !! ixc= choice of exchange-correlation scheme
3991 : !! lm_size=size of density array rhor (see below)
3992 : !! lmselect(lm_size)=select the non-zero LM-moments of input density rhor
3993 : !! nhat(nrad,lm_size,nspden)=compensation density
3994 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
3995 : !! nkxc=second dimension of the kxc array. If /=0, the exchange-correlation kernel must be computed
3996 : !! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
3997 : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
3998 : !! nspden=number of spin-density components
3999 : !! option=0 compute both XC energies (direct+double-counting) and potential (and Kernel)
4000 : !! 1 compute only XC potential (and Kernel)
4001 : !! 2 compute only XC energies (direct+double-counting)
4002 : !! 3 compute only XC energy by direct scheme
4003 : !! 4 compute only XC energy by direct scheme for spherical part of the density
4004 : !! 5 compute only XC potential (and Kernel) for spherical part of the density
4005 : !! pawang <type(pawang_type)>=paw angular mesh and related data
4006 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
4007 : !! pawxcdev=order of Vxc development
4008 : !! rhor(nrad,lm_size,nspden)=electron density in real space in electrons/bohr**3
4009 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
4010 : !! usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise
4011 : !! usexcnhat= 0 if compensation density does not have to be used
4012 : !! 1 if compensation density has to be used in double counting energy term only
4013 : !! 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
4014 : !! xclevel= XC functional level
4015 : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
4016 : !! el_temp=electronic temperature (hartree)
4017 : !!
4018 : !! OUTPUT
4019 : !! == if option==0, 2, 3, or 4 ==
4020 : !! enxc=returned exchange and correlation energy (hartree)
4021 : !! snxc=returned exchange and correlation entropy (for finite-temperature xc functionals)
4022 : !! == if option==0 or 2 ==
4023 : !! enxcdc=returned exchange-cor. contribution to double-counting energy
4024 : !! == if option==0 or 1 ==
4025 : !! vxc(nrad,lm_size,nspden)=xc potential
4026 : !! (spin up in 1st half and spin-down in 2nd half if nspden=2)
4027 : !! == if nkxc>0 ==
4028 : !! kxc(nrad,lm_size,nkxc)=xc kernel (see notes below for nkxc)
4029 : !! == For the TB09 XC functional (modified Becke-Johnson)
4030 : !! [grho1_over_rho1]=Integral of |Grad(rho^1)|/rho^1 over the augmentation region
4031 : !! Used to compute the c parameter of the TB09 XC functional
4032 : !! WARNING: NOT YET IMPLEMENTED!
4033 : !!
4034 : !! NOTES
4035 : !! Content of Kxc array:
4036 : !! ===== if LDA
4037 : !! if nspden==1: kxc(:,1)= d2Exc/drho2
4038 : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
4039 : !! if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
4040 : !! kxc(:,2)= d2Exc/drho_up drho_dn
4041 : !! kxc(:,3)= d2Exc/drho_dn drho_dn
4042 : !! if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
4043 : !! ===== if GGA
4044 : !! if nspden==1:
4045 : !! kxc(:,1)= d2Exc/drho2
4046 : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
4047 : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
4048 : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
4049 : !! kxc(:,5)= gradx(rho)
4050 : !! kxc(:,6)= grady(rho)
4051 : !! kxc(:,7)= gradz(rho)
4052 : !! if nspden>=2:
4053 : !! kxc(:,1)= d2Exc/drho_up drho_up
4054 : !! kxc(:,2)= d2Exc/drho_up drho_dn
4055 : !! kxc(:,3)= d2Exc/drho_dn drho_dn
4056 : !! kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
4057 : !! kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
4058 : !! kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
4059 : !! kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
4060 : !! kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
4061 : !! kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
4062 : !! kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
4063 : !! kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
4064 : !! kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
4065 : !! kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
4066 : !! kxc(:,14)=gradx(rho_up)
4067 : !! kxc(:,15)=gradx(rho_dn)
4068 : !! kxc(:,16)=grady(rho_up)
4069 : !! kxc(:,17)=grady(rho_dn)
4070 : !! kxc(:,18)=gradz(rho_up)
4071 : !! kxc(:,19)=gradz(rho_dn)
4072 : !! if nspden==4:
4073 : !! kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
4074 : !!
4075 : !! SOURCE
4076 :
4077 69974 : subroutine pawxcm(corexc,enxc,enxcdc,snxc,exexch,hyb_mixing,ixc,kxc,lm_size,lmselect,nhat,nkxc,&
4078 69974 : & non_magnetic_xc,nrad,nspden,option,pawang,pawrad,pawxcdev,rhor,&
4079 69974 : & usecore,usexcnhat,vxc,xclevel,xc_denpos,el_temp,grho1_over_rho1)
4080 :
4081 : !Arguments ------------------------------------
4082 : !scalars
4083 : integer,intent(in) :: exexch,ixc,lm_size,nkxc,nrad,nspden,option,pawxcdev,usecore
4084 : integer,intent(in) :: usexcnhat,xclevel
4085 : logical,intent(in) :: non_magnetic_xc
4086 : real(dp),intent(in) :: el_temp,hyb_mixing,xc_denpos
4087 : real(dp),intent(out) :: enxc,snxc,enxcdc
4088 : real(dp),intent(out),optional :: grho1_over_rho1
4089 : type(pawang_type),intent(in) :: pawang
4090 : type(pawrad_type),intent(in) :: pawrad
4091 : !arrays
4092 : logical,intent(in) :: lmselect(lm_size)
4093 : real(dp),intent(in) :: corexc(nrad)
4094 : real(dp),intent(in) :: nhat(nrad,lm_size,nspden*((usexcnhat+1)/2))
4095 : real(dp),intent(in) :: rhor(nrad,lm_size,nspden)
4096 : real(dp),intent(out) :: kxc(nrad,lm_size,nkxc)
4097 : real(dp),intent(out) :: vxc(nrad,lm_size,nspden)
4098 :
4099 : !Local variables-------------------------------
4100 : !scalars
4101 : integer :: ilm,ir,ir1,ir2,ispden,iwarn,jr,nspden_updn,nsums
4102 : real(dp),parameter :: delta=1.d-4
4103 : real(dp) :: dvxc1,dvxc2,dvxc3,dvxc4,dvxca,dvxcb,dvxcc,dvxcd
4104 : real(dp) :: fact,invsqfpi,invsqfpi2,sqfpi,sqfpi2,tol_rho
4105 : character(len=500) :: msg
4106 : !arrays
4107 69974 : real(dp),allocatable :: d1kxc(:,:),d2kxc(:,:),d1vxc(:,:),d2vxc(:,:)
4108 69974 : real(dp),allocatable :: exc_(:),sxc_(:),exci(:),tsxci(:),ff(:),gg(:)
4109 69974 : real(dp),allocatable :: kxc1(:,:),kxc2(:,:),kxcdn1(:,:),kxcdn2(:,:),kxci(:,:)
4110 69974 : real(dp),allocatable :: m_norm_inv(:),rho_(:,:),rhoinv(:,:),rhosph(:,:)
4111 69974 : real(dp),allocatable :: v1sum(:,:),v2sum(:,:,:)
4112 69974 : real(dp),allocatable :: vxc1(:,:),vxc2(:,:),vxcdn1(:,:),vxcdn2(:,:),vxci(:,:)
4113 69974 : real(dp),allocatable,target :: rho_nc(:,:),rho_updn(:,:,:),vxc_diag(:,:),vxc_nc(:,:)
4114 69974 : real(dp), LIBPAW_CONTIGUOUS pointer :: mag_nc(:,:),rho_dn(:,:),rho_up(:,:)
4115 :
4116 : !************************************************************************
4117 :
4118 69974 : if(nkxc>3) then
4119 0 : msg='Kxc not implemented for GGA! Use pawxcdev 0 '
4120 0 : LIBPAW_ERROR(msg)
4121 : end if
4122 69974 : if(nkxc>0.and.nspden==4) then
4123 0 : msg='Kxc not implemented for non-collinear magnetism!'
4124 0 : LIBPAW_ERROR(msg)
4125 : end if
4126 69974 : if (option/=1.and.option/=5) then
4127 67287 : if (nrad<pawrad%int_meshsz) then
4128 0 : msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!'
4129 0 : LIBPAW_BUG(msg)
4130 : end if
4131 : end if
4132 : #if defined LIBPAW_HAVE_LIBXC
4133 69974 : if (present(grho1_over_rho1).and.option<4.and.ixc<0) then
4134 0 : if (libxc_functionals_is_tb09()) then
4135 0 : msg='TB09 (mBJ) XC functional not yet implemented for pawxcdev/=0!'
4136 0 : LIBPAW_ERROR(msg)
4137 : end if
4138 : end if
4139 : #endif
4140 :
4141 : !----------------------------------------------------------------------
4142 : !----- Initializations
4143 : !----------------------------------------------------------------------
4144 :
4145 : !Arrays dimensions and constants
4146 69974 : iwarn=0
4147 69974 : nspden_updn=min(nspden,2)
4148 69974 : sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi
4149 69974 : invsqfpi=one/sqfpi;invsqfpi2=half*invsqfpi
4150 69974 : nsums=2*nspden_updn-1
4151 :
4152 : !Initializations of output arrays
4153 69974 : if (option/=1.and.option/=5) then
4154 67287 : enxc=zero
4155 67287 : snxc=zero
4156 : end if
4157 69974 : if (option==0.or.option==2) enxcdc=zero
4158 1048411596 : if (option/=3.and.option/=4) vxc(:,:,:)=zero
4159 1077306 : if (nkxc/=0) kxc(:,:,:)=zero
4160 :
4161 69974 : if (xclevel==0.or.ixc==0) then ! No xc at all is applied (usually for testing)
4162 494 : msg='Note that no xc is applied (ixc=0). Returning'
4163 494 : LIBPAW_WARNING(msg)
4164 494 : return
4165 : end if
4166 :
4167 : !----------------------------------------------------------------------
4168 : !----- Build several densities
4169 : !----------------------------------------------------------------------
4170 :
4171 : !rho_updn contains the effective density used for XC
4172 : !with core density and/or compensation density eventually included
4173 : !-----------------------------------------------------------------
4174 :
4175 347400 : LIBPAW_ALLOCATE(rho_updn,(nrad,lm_size,nspden))
4176 1046603062 : rho_updn(:,:,:)=rhor(:,:,:)
4177 233472811 : if (usexcnhat==2) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:)
4178 :
4179 : !Optionally suppressed magnetic part
4180 69480 : if(non_magnetic_xc) then
4181 8489008 : if(nspden==2) rho_updn(:,:,2)=rho_updn(:,:,1)*half
4182 38608910 : if(nspden==4) rho_updn(:,:,2:4)=zero
4183 : endif
4184 :
4185 : !Add core density
4186 69480 : if (usecore==1) then
4187 53552 : if (nspden==1.or.nspden==4) then
4188 60119620 : rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:)
4189 6747 : else if (nspden==2) then
4190 5783587 : rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:)
4191 5783587 : rho_updn(:,1,2)=rho_updn(:,1,2)+sqfpi2*corexc(:)
4192 : end if
4193 : end if
4194 :
4195 : !In case of collinear magnetism, separate up and down contributions
4196 69480 : if (nspden==2) then
4197 29772 : LIBPAW_ALLOCATE(ff,(nrad))
4198 217882 : do ilm=1,lm_size
4199 143882909 : ff(:)=rho_updn(:,ilm,2)
4200 143882909 : rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:)
4201 143892833 : rho_updn(:,ilm,1)=ff(:)
4202 : end do
4203 9924 : LIBPAW_DEALLOCATE(ff)
4204 : end if
4205 :
4206 : !Direct links to rho_up and rho_dn
4207 69480 : rho_up => rho_updn(:,:,1)
4208 69480 : rho_dn => rho_updn(:,:,nspden_updn)
4209 :
4210 : !rhoSPH contains the spherical part of effective density
4211 : !(including Y00 spherical harmonic)
4212 : !-----------------------------------------------------------------
4213 277920 : LIBPAW_ALLOCATE(rhosph,(nrad,nspden_updn))
4214 :
4215 : ! Non-magnetic system: rhoSPH(;,1)=(1/2).rhoSPH_total
4216 69480 : if (nspden==1) then
4217 80544462 : rhosph(:,1)=rho_updn(:,1,1)*invsqfpi2
4218 :
4219 : ! Collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn)
4220 12722 : else if (nspden==2) then
4221 15417810 : rhosph(:,1:2)=rho_updn(:,1,1:2)*invsqfpi
4222 :
4223 : ! Non-collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn)
4224 : ! obtained by rotating rho_updn
4225 2798 : else if (nspden==4) then
4226 8394 : LIBPAW_ALLOCATE(m_norm_inv,(nrad))
4227 11192 : LIBPAW_ALLOCATE(rho_nc,(nrad,nspden))
4228 13990 : do ispden=1,nspden
4229 10323926 : rho_nc(1:nrad,ispden)=rho_updn(1:nrad,1,ispden)*invsqfpi
4230 : end do
4231 2798 : mag_nc => rho_nc(:,2:4)
4232 2798 : call pawxc_rotate_mag(rho_nc,rhosph,mag_nc,nrad,mag_norm_out=m_norm_inv)
4233 2580282 : do ir=1,nrad
4234 3214829 : m_norm_inv(ir)=merge(invsqfpi/m_norm_inv(ir),zero,m_norm_inv(ir)>rho_min)
4235 : end do
4236 : end if
4237 :
4238 : !Make spherical density positive
4239 69480 : call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rhosph,xc_denpos)
4240 :
4241 : !----------------------------------------------------------------------
4242 : !----- Compute Exc(rhoSPH) and Vxc(rhoSPH)
4243 : !----------------------------------------------------------------------
4244 :
4245 208440 : LIBPAW_ALLOCATE(exci,(nrad))
4246 138960 : LIBPAW_ALLOCATE(tsxci,(nrad))
4247 208440 : LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn))
4248 277920 : LIBPAW_ALLOCATE(kxci,(nrad,nkxc))
4249 69480 : call pawxcsph(exci,tsxci,exexch,el_temp,hyb_mixing,ixc,kxci,nkxc,nrad,nspden_updn,pawrad,rhosph,vxci,xclevel)
4250 :
4251 : !----------------------------------------------------------------------
4252 : !----- Compute numerical derivatives of Vxc,Kxc (by finite diff. scheme)
4253 : !----------------------------------------------------------------------
4254 :
4255 69480 : if (option/=4.and.option/=5) then
4256 137890 : LIBPAW_ALLOCATE(exc_,(nrad))
4257 137890 : LIBPAW_ALLOCATE(sxc_,(nrad))
4258 206835 : LIBPAW_ALLOCATE(rho_,(nrad,nspden_updn))
4259 :
4260 10268065 : if (nspden_updn==2) rho_(:,2)=rhosph(:,2)
4261 :
4262 : ! Compute Exc, Vxc for rho+delta_rho
4263 206835 : LIBPAW_ALLOCATE(vxc1,(nrad,nspden_updn))
4264 206835 : LIBPAW_ALLOCATE(kxc1,(nrad,nkxc))
4265 90200717 : rho_(:,1)=(one+delta)*rhosph(:,1)
4266 68945 : call pawxcsph(exc_,sxc_,exexch,el_temp,hyb_mixing,ixc,kxc1,nkxc,nrad,nspden_updn,pawrad,rho_,vxc1,xclevel)
4267 :
4268 : ! Compute Exc, Vxc for rho-delta_rho
4269 206835 : LIBPAW_ALLOCATE(vxc2,(nrad,nspden_updn))
4270 206835 : LIBPAW_ALLOCATE(kxc2,(nrad,nkxc))
4271 90200717 : rho_(:,1)=(one-delta)*rhosph(:,1)
4272 68945 : call pawxcsph(exc_,sxc_,exexch,el_temp,hyb_mixing,ixc,kxc2,nkxc,nrad,nspden_updn,pawrad,rho_,vxc2,xclevel)
4273 :
4274 : ! Additional terms for spin-polarized systems
4275 68945 : if (nspden_updn==2) then
4276 10211796 : rho_(:,1)=rhosph(:,1)
4277 :
4278 : ! Compute Exc, Vxc for rho+delta_rho_down
4279 38028 : LIBPAW_ALLOCATE(vxcdn1,(nrad,nspden_updn))
4280 38028 : LIBPAW_ALLOCATE(kxcdn1,(nrad,nkxc))
4281 10211796 : rho_(:,2)=(one+delta)*rhosph(:,2)
4282 12676 : call pawxcsph(exc_,sxc_,exexch,el_temp,hyb_mixing,ixc,kxcdn1,nkxc,nrad,nspden_updn,pawrad,rho_,vxcdn1,xclevel)
4283 :
4284 : ! Compute Exc, Vxc for rho-delta_rho_down
4285 38028 : LIBPAW_ALLOCATE(vxcdn2,(nrad,nspden_updn))
4286 38028 : LIBPAW_ALLOCATE(kxcdn2,(nrad,nkxc))
4287 10211796 : rho_(:,2)=(one-delta)*rhosph(:,2)
4288 12676 : call pawxcsph(exc_,sxc_,exexch,el_temp,hyb_mixing,ixc,kxcdn2,nkxc,nrad,nspden_updn,pawrad,rho_,vxcdn2,xclevel)
4289 :
4290 : end if !nspden_updn==2
4291 68945 : LIBPAW_DEALLOCATE(sxc_)
4292 68945 : LIBPAW_DEALLOCATE(exc_)
4293 68945 : LIBPAW_DEALLOCATE(rho_)
4294 :
4295 : ! Store inverse of density finite step
4296 206835 : LIBPAW_ALLOCATE(rhoinv,(nrad,nspden_updn))
4297 68945 : fact=one/delta;if (nspden_updn==1) fact=half*fact
4298 150566 : do ispden=1,nspden_updn
4299 100481458 : do ir=1,nrad
4300 100412513 : if (rhosph(ir,ispden)>rho_min) then
4301 100326022 : rhoinv(ir,ispden)=fact/rhosph(ir,ispden)
4302 : else
4303 4870 : rhoinv(ir,ispden)=zero
4304 : end if
4305 : end do
4306 : end do
4307 :
4308 : ! Compute numerical first derivatives of Vxc (by finite difference scheme)
4309 344725 : LIBPAW_ALLOCATE(d1vxc,(nrad,2*nspden_updn-1))
4310 : ! Non-magnetic system: compute dVxc/dn
4311 68945 : if (nspden==1) then
4312 79988921 : d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1)
4313 : ! Collinear magnetism: compute dVxc_up/dn_up,dVxc_dn/dn_up,dVxc_dn/dn_dn
4314 12676 : else if (nspden==2) then
4315 7631514 : d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1)
4316 7631514 : d1vxc(1:nrad,2)=(vxc1(1:nrad,2)-vxc2(1:nrad,2))*half*rhoinv(1:nrad,1)
4317 7631514 : d1vxc(1:nrad,3)=(vxcdn1(1:nrad,2)-vxcdn2(1:nrad,2))*half*rhoinv(1:nrad,2)
4318 : ! Non-collinear magnetism: compute 1/2 d(Vxc_up+Vxc_dn)/dn,1/2 d(Vxc_up-Vxc_dn)/dn
4319 : ! 1/2 d(Vxc_up-Vxc_dn)/dm
4320 2798 : else if (nspden==4) then
4321 2580282 : do ir=1,nrad
4322 2577484 : fact=half*rhoinv(ir,1)
4323 2577484 : dvxc1=(vxc1 (ir,1)-vxc2 (ir,1))*fact !dVxc_up/dn_up
4324 2577484 : dvxc2=(vxc1 (ir,2)-vxc2 (ir,2))*fact !dVxc_dn/dn_up
4325 2577484 : fact=half*rhoinv(ir,2)
4326 2577484 : dvxc3=(vxcdn1(ir,2)-vxcdn2(ir,2))*fact !dVxc_dn/dn_dn
4327 2577484 : dvxca=dvxc1+dvxc3;dvxcb=dvxc1-dvxc3;dvxcc=two*dvxc2 !Temporary terms
4328 2577484 : d1vxc(ir,1)=quarter*(dvxca+dvxcc) ! 1/2 d(Vxc_up+Vxc_dn)/dn
4329 2577484 : d1vxc(ir,2)=quarter* dvxcb ! 1/2 d(Vxc_up-Vxc_dn)/dn
4330 2580282 : d1vxc(ir,3)=quarter*(dvxca-dvxcc) ! 1/2 d(Vxc_up-Vxc_dn)/dm
4331 : end do
4332 : end if
4333 :
4334 : ! Compute numerical second derivatives of Vxc (by finite difference scheme)
4335 68945 : if (option/=3.or.pawxcdev>=2) then
4336 275780 : LIBPAW_ALLOCATE(d2vxc,(nrad,3*nspden_updn-2))
4337 : ! Non-magnetic system: compute d2Vxc/dn2
4338 68945 : if (nspden==1) then
4339 79988921 : d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2
4340 : ! Collinear magnetism: compute d2Vxc_up/dn_up2,d2Vxc_dn/dn_up2,d2Vxc_up/dn_dn2,d2Vxc_dn/dn_dn2
4341 12676 : else if (nspden==2) then
4342 7631514 : d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2
4343 7631514 : d2vxc(1:nrad,2)=(vxc1(1:nrad,2)+vxc2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,1)**2
4344 7631514 : d2vxc(1:nrad,3)=(vxcdn1(1:nrad,1)+vxcdn2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,2)**2
4345 7631514 : d2vxc(1:nrad,4)=(vxcdn1(1:nrad,2)+vxcdn2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,2)**2
4346 : ! Non-collinear magnetism: compute 1/2 d2(Vxc_up+Vxc_dn)/dn2,1/2 d2(Vxc_up-Vxc_dn)/dn2
4347 : ! 1/2 d2(Vxc_up+Vxc_dn)/dm2,1/2 d2(Vxc_up-Vxc_dn)/dm2
4348 2798 : else if (nspden==4) then
4349 2580282 : do ir=1,nrad
4350 2577484 : fact=rhoinv(ir,1)**2
4351 2577484 : dvxc1=(vxc1 (ir,1)+vxc2 (ir,1)-two*vxci(ir,1))*fact !d2Vxc_up/dn_up2
4352 2577484 : dvxc2=(vxc1 (ir,2)+vxc2 (ir,2)-two*vxci(ir,2))*fact !d2Vxc_dn/dn_up2
4353 2577484 : fact=rhoinv(ir,2)**2
4354 2577484 : dvxc3=(vxcdn1(ir,1)+vxcdn2(ir,1)-two*vxci(ir,1))*fact !d2Vxc_up/dn_dn2
4355 2577484 : dvxc4=(vxcdn1(ir,2)+vxcdn2(ir,2)-two*vxci(ir,2))*fact !d2Vxc_dn/dn_dn2
4356 2577484 : dvxca=dvxc1+dvxc4;dvxcb=dvxc1-dvxc4 !Temporary terms
4357 2577484 : dvxcc=dvxc2+dvxc3;dvxcd=dvxc2-dvxc3 !Temporary terms
4358 2577484 : d2vxc(ir,1)=(dvxca+three*dvxcc)/8._dp ! 1/2 d2(Vxc_up+Vxc_dn)/dn2
4359 2577484 : d2vxc(ir,2)=(dvxcb+dvxcd)/8._dp ! 1/2 d2(Vxc_up-Vxc_dn)/dn2
4360 2577484 : d2vxc(ir,3)=(dvxca-dvxcc)/8._dp ! 1/2 d2(Vxc_up+Vxc_dn)/dm2
4361 2580282 : d2vxc(ir,4)=(dvxcb-three*dvxcd)/8._dp ! 1/2 d2(Vxc_up-Vxc_dn)/dm2
4362 : end do
4363 : end if
4364 : end if
4365 :
4366 : ! Compute numerical first and second derivatives of Kxc (by finite difference scheme)
4367 68945 : if (nkxc>0) then
4368 : ! Non-magnetic system: compute dKxc/dn, d2Kxc/dn2
4369 126 : if (nspden==1) then
4370 252 : LIBPAW_ALLOCATE(d1kxc,(nrad,1))
4371 252 : LIBPAW_ALLOCATE(d2kxc,(nrad,1))
4372 85686 : d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1)
4373 85686 : d2kxc(1:nrad,1)=(kxc1(1:nrad,1)+kxc2(1:nrad,1)-two*kxci(1:nrad,1))*rhoinv(1:nrad,1)**2
4374 : ! Collinear magnetism: compute dKxc_upup/dn_up,dKxc_updn/dn_up,dKxc_updn/dn_dn,dKxc_dndn/dn_dn
4375 : ! compute d2Kxc_upup/dn_up2,d2Kxc_updn/dn_up2,d2Kxc_upup/dn_dn2,d2Kxc_updn/dn_dn2,d2Kxc_dndn/dn_dn2
4376 0 : else if (nspden==2) then
4377 0 : LIBPAW_ALLOCATE(d1kxc,(nrad,4))
4378 0 : LIBPAW_ALLOCATE(d2kxc,(nrad,5))
4379 0 : d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1) ! dKxc_upup/dn_up
4380 0 : d1kxc(1:nrad,2)=(kxc1(1:nrad,2)-kxc2(1:nrad,2))*half*rhoinv(1:nrad,1) ! dKxc_updn/dn_up
4381 0 : d1kxc(1:nrad,3)=(kxc1(1:nrad,3)-kxc2(1:nrad,3))*half*rhoinv(1:nrad,1) ! dKxc_dndn/dn_up
4382 0 : d1kxc(1:nrad,4)=(kxcdn1(1:nrad,3)-kxcdn2(1:nrad,3))*half*rhoinv(1:nrad,2) ! dKxc_dndn/dn_dn
4383 0 : d2kxc(1:nrad,1)=(kxc1(1:nrad,1)+kxc2(1:nrad,1)-two*kxci(1:nrad,1))*rhoinv(1:nrad,1)**2 ! d2Kxc_upup/dn_up2
4384 0 : d2kxc(1:nrad,2)=(kxc1(1:nrad,2)+kxc2(1:nrad,2)-two*kxci(1:nrad,2))*rhoinv(1:nrad,1)**2 ! d2Kxc_updn/dn_up2
4385 0 : d2kxc(1:nrad,3)=(kxcdn1(1:nrad,1)+kxcdn2(1:nrad,1)-two*kxci(1:nrad,1))*rhoinv(1:nrad,2)**2 ! d2Kxc_upup/dn_dn2
4386 0 : d2kxc(1:nrad,4)=(kxcdn1(1:nrad,2)+kxcdn2(1:nrad,2)-two*kxci(1:nrad,2))*rhoinv(1:nrad,2)**2 ! d2Kxc_updn/dn_dn2
4387 0 : d2kxc(1:nrad,5)=(kxcdn1(1:nrad,3)+kxcdn2(1:nrad,3)-two*kxci(1:nrad,3))*rhoinv(1:nrad,2)**2 ! d2Kxc_dndn/dn_dn2
4388 : end if
4389 : end if
4390 :
4391 68945 : LIBPAW_DEALLOCATE(rhoinv)
4392 68945 : LIBPAW_DEALLOCATE(vxc1)
4393 68945 : LIBPAW_DEALLOCATE(vxc2)
4394 68945 : LIBPAW_DEALLOCATE(kxc1)
4395 68945 : LIBPAW_DEALLOCATE(kxc2)
4396 68945 : if (nspden_updn==2) then
4397 12676 : LIBPAW_DEALLOCATE(vxcdn1)
4398 12676 : LIBPAW_DEALLOCATE(vxcdn2)
4399 12676 : LIBPAW_DEALLOCATE(kxcdn1)
4400 12676 : LIBPAW_DEALLOCATE(kxcdn2)
4401 : end if
4402 :
4403 : end if ! (option/=4 and option/=5)
4404 :
4405 69480 : LIBPAW_DEALLOCATE(rhosph)
4406 :
4407 : !If non-collinear magnetism, store 1/2(Vxc_up+Vxc_dn) and 1/2(Vxc_up-Vxc_dn)
4408 69480 : if (nspden==4) then
4409 2580282 : vxci(:,1)=half*(vxci(:,1)+vxci(:,2))
4410 2580282 : vxci(:,2)=vxci(:,1)-vxci(:,2)
4411 : end if
4412 :
4413 : !----------------------------------------------------------------------
4414 : !----- Compute useful sums of densities
4415 : !----------------------------------------------------------------------
4416 :
4417 69480 : if (option/=4.and.option/=5) then
4418 :
4419 : ! Non-collinear magnetism: replace rho_dn by (m_0.dot.m)/|m_0|
4420 68945 : if (nspden==4) then
4421 11192 : LIBPAW_POINTER_ALLOCATE(rho_dn,(nrad,lm_size))
4422 2580282 : rho_dn(:,1)=zero
4423 71342 : do ilm=2,lm_size
4424 : rho_dn(1:nrad,ilm)=m_norm_inv(1:nrad) &
4425 : & *(rho_updn(1:nrad,1,2)*rho_updn(1:nrad,ilm,2) &
4426 : & +rho_updn(1:nrad,1,3)*rho_updn(1:nrad,ilm,3) &
4427 125204846 : & +rho_updn(1:nrad,1,4)*rho_updn(1:nrad,ilm,4))
4428 : end do
4429 : end if
4430 :
4431 : ! Non-magnetic system:
4432 : ! Compute
4433 : ! V1SUM1(r)=Sum_L{n_L(r)^2}
4434 : ! V2SUM1(r,L)=Sum_L1_L2{n_L1(r)*n_L2(r)*Gaunt_(L,L1,L2)}
4435 : ! Collinear magnetism:
4436 : ! Compute
4437 : ! V1SUM1(r)=Sum_L{n^up_L(r)^2}
4438 : ! V1SUM2(r)=Sum_L{n^up_L(r)*n^dn_L(r)}
4439 : ! V1SUM3(r)=Sum_L{n^dn_L(r)^2}
4440 : ! V2SUM1(r,L)=Sum_L1_L2{n^up_L1(r)*n^up_L2(r)*Gaunt_(L,L1,L2)}
4441 : ! V2SUM2(r,L)=Sum_L1_L2{n^up_L1(r)*n^dn_L2(r)*Gaunt_(L,L1,L2)}
4442 : ! V2SUM3(r,L)=Sum_L1_L2{n^dn_L1(r)*n^dn_L2(r)*Gaunt_(L,L1,L2)}
4443 : ! Non-collinear magnetism:
4444 : ! Compute
4445 : ! V1SUM1(r)=Sum_L{n_L(r)^2}
4446 : ! V1SUM2(r)=Sum_L{n_L(r) (m_0.m_L)}/|m_0|
4447 : ! V1SUM3(r)=Sum_L{(m_0.m_L)^2}/|m_0|^2
4448 : ! V2SUM1(r,L)=Sum_L1_L2{n_L1(r)*n_L2(r)*Gaunt_(L,L1,L2)}
4449 : ! V2SUM2(r,L)=Sum_L1_L2{n_L1(r) (m_0.m_L2)*Gaunt_(L,L1,L2)}/|m_0|
4450 : ! V2SUM3(r,L)=Sum_L1_L2{(m_0.m_L1)*(m_0.m_L2)*Gaunt_(L,L1,L2)}/|m_0|^2
4451 68945 : if (pawxcdev>=1) then
4452 275780 : LIBPAW_ALLOCATE(v1sum,(nrad,nsums))
4453 : else
4454 0 : LIBPAW_ALLOCATE(v1sum,(0,0))
4455 : end if
4456 68945 : if (pawxcdev>=2) then
4457 1720 : LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,nsums))
4458 : else
4459 68601 : LIBPAW_ALLOCATE(v2sum,(0,0,0))
4460 : end if
4461 : call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,nsums,pawxcdev,pawang,&
4462 68945 : & rho_up,rho_dn,v1sum,v2sum)
4463 :
4464 : end if !option
4465 :
4466 : !----------------------------------------------------------------------
4467 : !----- Accumulate and store XC potential
4468 : !----------------------------------------------------------------------
4469 :
4470 69480 : if (option/=3.and.option/=4) then
4471 :
4472 : ! === First order development
4473 : ! ---------------------------
4474 68989 : if (pawxcdev>=1) then
4475 :
4476 : ! Non-magnetic system
4477 68989 : if (nspden_updn==1) then
4478 80011485 : vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi
4479 56309 : if (option/=5) then
4480 79988921 : vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+v1sum(1:nrad,1)*d2vxc(1:nrad,1)*invsqfpi2
4481 465141 : do ilm=2,lm_size
4482 465141 : if (lmselect(ilm)) then
4483 298844121 : vxc(1:nrad,ilm,1)=d1vxc(1:nrad,1)*rho_up(1:nrad,ilm)
4484 : end if
4485 : end do
4486 : end if
4487 :
4488 : ! Magnetic system (including non-collinear magn.)
4489 12680 : else if (nspden_updn==2) then
4490 10217128 : vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi
4491 10217128 : vxc(1:nrad,1,2)=vxci(1:nrad,2)*sqfpi
4492 12680 : if (option/=5) then
4493 : vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+invsqfpi2*(v1sum(1:nrad,1)*d2vxc(1:nrad,1) &
4494 10211796 : & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,2)+v1sum(1:nrad,3)*d2vxc(1:nrad,3))
4495 : vxc(1:nrad,1,2)=vxc(1:nrad,1,2)+invsqfpi2*(v1sum(1:nrad,1)*d2vxc(1:nrad,2) &
4496 10211796 : & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,3)+v1sum(1:nrad,3)*d2vxc(1:nrad,4))
4497 279254 : do ilm=2,lm_size
4498 279254 : if (lmselect(ilm)) then
4499 : vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1) &
4500 130068594 : & +d1vxc(1:nrad,1)*rho_up(1:nrad,ilm)+d1vxc(1:nrad,2)*rho_dn(1:nrad,ilm)
4501 : vxc(1:nrad,ilm,2)=vxc(1:nrad,ilm,2) &
4502 130068594 : & +d1vxc(1:nrad,2)*rho_up(1:nrad,ilm)+d1vxc(1:nrad,3)*rho_dn(1:nrad,ilm)
4503 : end if
4504 : end do
4505 : end if
4506 : end if
4507 : end if ! pawxcdev>=1
4508 :
4509 : ! == 2nd order development
4510 : ! ---------------------------
4511 68989 : if (pawxcdev>=2.and.option/=5) then
4512 :
4513 : ! Non-magnetic system
4514 344 : if (nspden_updn==1) then
4515 270 : do ilm=2,lm_size
4516 332910 : vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1)+half*d2vxc(1:nrad,1)*v2sum(1:nrad,ilm,1)
4517 : end do
4518 :
4519 : ! Magnetic system (including non-collinear magn.)
4520 314 : else if (nspden_updn==2) then
4521 7850 : do ilm=2,lm_size
4522 : vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1)+d2vxc(1:nrad,2)*v2sum(1:nrad,ilm,2) &
4523 8032320 : & +half*(d2vxc(1:nrad,1)*v2sum(1:nrad,ilm,1)+d2vxc(1:nrad,3)*v2sum(1:nrad,ilm,3))
4524 : vxc(1:nrad,ilm,2)=vxc(1:nrad,ilm,2)+d2vxc(1:nrad,3)*v2sum(1:nrad,ilm,2) &
4525 8032634 : & +half*(d2vxc(1:nrad,2)*v2sum(1:nrad,ilm,1)+d2vxc(1:nrad,4)*v2sum(1:nrad,ilm,3))
4526 : end do
4527 : end if
4528 : end if !pawxcdev=2
4529 :
4530 : ! === Pathological case: if rho(r) is negative, interpolate Vxc
4531 : ! -------------------------------------------------------------
4532 68989 : if (lmselect(1)) then
4533 68989 : tol_rho=xc_denpos*(one+tol6)
4534 150658 : do ispden=1,nspden_updn
4535 : ir1=0;ir2=0
4536 100514730 : do ir=1,nrad
4537 100445741 : if (rho_updn(ir,1,ispden)<tol_rho) then
4538 1232475 : if (ir1==0) ir1=ir-1
4539 1232475 : ir2=ir+1
4540 99131597 : else if (ir1>0) then
4541 491 : if (ir1>1.or.ir2<nrad) then
4542 489 : fact=(vxc(ir2,1,ispden)-vxc(ir1,1,ispden))/(pawrad%rad(ir2)-pawrad%rad(ir1))
4543 152581 : do jr=ir1+1,ir2-1
4544 152583 : vxc(jr,1,ispden)=vxc(ir1,1,ispden)+fact*(pawrad%rad(jr)-pawrad%rad(ir1))
4545 : end do
4546 : end if
4547 : ir1=0;ir2=0
4548 : end if
4549 : end do
4550 : end do
4551 : end if
4552 :
4553 : ! === Non-collinear magnetism: "rotate" back the XC potential
4554 : ! ------- ---------------------------------------------------
4555 68989 : if (nspden==4) then
4556 8394 : LIBPAW_ALLOCATE(vxc_diag,(nrad,nspden_updn))
4557 11192 : LIBPAW_ALLOCATE(vxc_nc,(nrad,nspden))
4558 74140 : do ilm=1,lm_size
4559 65215578 : vxc_diag(:,1)=vxc(:,ilm,1)+vxc(:,ilm,2) ! Get V from (V_up+V_dn)/2
4560 65215578 : vxc_diag(:,2)=vxc(:,ilm,1)-vxc(:,ilm,2) ! and (V_up-V_dn)/2
4561 71342 : call pawxc_rotate_back_mag(vxc_diag,vxc_nc,mag_nc,nrad)
4562 359508 : do ispden=1,nspden
4563 260933654 : vxc(1:nrad,ilm,ispden)=vxc_nc(1:nrad,ispden)
4564 : end do
4565 : end do
4566 2798 : LIBPAW_DEALLOCATE(vxc_diag)
4567 2798 : LIBPAW_DEALLOCATE(vxc_nc)
4568 : end if
4569 : end if !option/=3 and option/=4
4570 :
4571 : !----------------------------------------------------------------------
4572 : !----- Accumulate and store XC kernel
4573 : !----------------------------------------------------------------------
4574 :
4575 69480 : if (nkxc>0) then
4576 :
4577 : ! === First order development
4578 : ! ---------------------------
4579 126 : if (pawxcdev>=1) then
4580 : ! Non-magnetic system:
4581 126 : if (nspden_updn==1) then
4582 85686 : kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi
4583 126 : if (option/=5.and.option/=4) then
4584 85686 : kxc(1:nrad,1,1)=kxc(1:nrad,1,1)+invsqfpi2*v1sum(1:nrad,1)*d2kxc(1:nrad,1)
4585 1326 : do ilm=2,lm_size
4586 1326 : if (lmselect(ilm)) then
4587 336732 : kxc(1:nrad,ilm,1)=d1kxc(1:nrad,1)*rho_up(1:nrad,ilm)
4588 : end if
4589 : end do
4590 : end if
4591 : ! Magnetic system:
4592 0 : else if (nspden==2) then
4593 0 : kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi
4594 0 : kxc(1:nrad,1,2)=kxci(1:nrad,2)*sqfpi
4595 0 : kxc(1:nrad,1,3)=kxci(1:nrad,3)*sqfpi
4596 0 : if (option/=5.and.option/=4) then
4597 : kxc(1:nrad,1,1)=kxc(1:nrad,1,1)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,1) &
4598 0 : & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,2)+v1sum(1:nrad,3)*d2kxc(1:nrad,3))
4599 : kxc(1:nrad,1,2)=kxc(1:nrad,1,2)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,2) &
4600 0 : & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,3)+v1sum(1:nrad,3)*d2kxc(1:nrad,4))
4601 : kxc(1:nrad,1,3)=kxc(1:nrad,1,3)+invsqfpi2*(v1sum(1:nrad,1)*d2kxc(1:nrad,3) &
4602 0 : & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,4)+v1sum(1:nrad,3)*d2kxc(1:nrad,5))
4603 0 : do ilm=2,lm_size
4604 0 : if (lmselect(ilm)) then
4605 : kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1) &
4606 0 : & +d1kxc(1:nrad,1)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,2)*rho_dn(1:nrad,ilm)
4607 : kxc(1:nrad,ilm,2)=kxc(1:nrad,ilm,2) &
4608 0 : & +d1kxc(1:nrad,2)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,3)*rho_dn(1:nrad,ilm)
4609 : kxc(1:nrad,ilm,3)=kxc(1:nrad,ilm,3) &
4610 0 : & +d1kxc(1:nrad,3)*rho_up(1:nrad,ilm)+d1kxc(1:nrad,4)*rho_dn(1:nrad,ilm)
4611 : end if
4612 : end do
4613 : end if
4614 : end if
4615 : end if ! pawxcdev>=1
4616 :
4617 : ! == 2nd order development
4618 : ! ---------------------------
4619 126 : if (pawxcdev>=2.and.option/=4.and.option/=5) then
4620 :
4621 : ! Non-magnetic system:
4622 0 : if (nspden_updn==1) then
4623 0 : do ilm=2,lm_size
4624 0 : kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1)+half*d2kxc(1:nrad,1)*v2sum(1:nrad,ilm,1)
4625 : end do
4626 : ! Magnetic system:
4627 0 : else if (nspden==2) then
4628 0 : do ilm=2,lm_size
4629 : kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1)+d2kxc(1:nrad,2)*v2sum(1:nrad,ilm,2) &
4630 0 : & +half*(d2kxc(1:nrad,1)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,3))
4631 : kxc(1:nrad,ilm,2)=kxc(1:nrad,ilm,2)+d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,2) &
4632 0 : & +half*(d2kxc(1:nrad,2)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,4)*v2sum(1:nrad,ilm,3))
4633 : kxc(1:nrad,ilm,3)=kxc(1:nrad,ilm,3)+d2kxc(1:nrad,4)*v2sum(1:nrad,ilm,2) &
4634 0 : & +half*(d2kxc(1:nrad,3)*v2sum(1:nrad,ilm,1)+d2kxc(1:nrad,5)*v2sum(1:nrad,ilm,3))
4635 : end do
4636 : end if
4637 : end if !pawxcdev=2
4638 :
4639 : ! === Pathological case: if rho(r) is negative, interpolate Kxc
4640 : ! -------------------------------------------------------------
4641 :
4642 : ! NOT OK for spin polarized
4643 126 : if (lmselect(1)) then
4644 126 : tol_rho=xc_denpos*(one+tol6)
4645 252 : do ispden=1,nspden_updn
4646 : ir1=0;ir2=0
4647 85812 : do ir=1,nrad
4648 85686 : if (rho_updn(ir,1,ispden)<tol_rho) then
4649 0 : if (ir1==0) ir1=ir-1
4650 0 : ir2=ir+1
4651 85560 : else if (ir1>0) then
4652 0 : if (ir1>1.or.ir2<nrad) then
4653 0 : fact=(kxc(ir2,1,ispden)-kxc(ir1,1,ispden))/(pawrad%rad(ir2)-pawrad%rad(ir1))
4654 0 : do jr=ir1+1,ir2-1
4655 0 : kxc(jr,1,ispden)=kxc(ir1,1,ispden)+fact*(pawrad%rad(jr)-pawrad%rad(ir1))
4656 : end do
4657 : end if
4658 : ir1=0;ir2=0
4659 : end if
4660 : end do
4661 : end do
4662 : end if
4663 :
4664 : ! Non-collinear magnetism: need to store magnetization in kxc
4665 126 : if (nkxc==6.or.nkxc==22) then
4666 0 : do ilm=2,lm_size
4667 0 : kxc(1:nrad,ilm,nkxc-2)=rho_updn(1:nrad,ilm,2)
4668 0 : kxc(1:nrad,ilm,nkxc-1)=rho_updn(1:nrad,ilm,3)
4669 0 : kxc(1:nrad,ilm,nkxc )=rho_updn(1:nrad,ilm,4)
4670 : end do
4671 : end if
4672 :
4673 : end if ! nkxc>0
4674 :
4675 69480 : if (nspden==4) then
4676 2798 : LIBPAW_DEALLOCATE(rho_nc)
4677 2798 : LIBPAW_DEALLOCATE(m_norm_inv)
4678 : end if
4679 :
4680 69480 : LIBPAW_DEALLOCATE(kxci)
4681 69480 : if (nkxc>0.and.option/=4.and.option/=5) then
4682 126 : LIBPAW_DEALLOCATE(d1kxc)
4683 126 : LIBPAW_DEALLOCATE(d2kxc)
4684 : end if
4685 :
4686 : !----------------------------------------------------------------------
4687 : !----- Accumulate and store XC energies
4688 : !----------------------------------------------------------------------
4689 :
4690 : !----- Calculate Exc (direct scheme) term
4691 : !----------------------------------------
4692 69480 : if (option/=1.and.option/=5) then
4693 134074 : LIBPAW_ALLOCATE(ff,(nrad))
4694 :
4695 : ! Contribution from spherical part of rho
4696 67037 : if (nspden==1.or.nspden==4) then
4697 82065015 : ff(1:nrad)=rho_updn(1:nrad,1,1)*exci(1:nrad)*sqfpi
4698 9064 : else if (nspden==2) then
4699 7091149 : ff(1:nrad)=(rho_updn(1:nrad,1,1)+rho_updn(1:nrad,1,2))*exci(1:nrad)*sqfpi
4700 : end if
4701 :
4702 : ! Contribution from aspherical part of rho
4703 67037 : if (option/=4) then
4704 :
4705 : ! First order development
4706 66546 : if (pawxcdev>=1) then
4707 66546 : if (nspden_updn==1) then
4708 79039816 : ff(1:nrad)=ff(1:nrad)+half*v1sum(1:nrad,1)*d1vxc(1:nrad,1)
4709 11672 : else if (nspden_updn==2) then
4710 : ff(1:nrad)=ff(1:nrad)+v1sum(1:nrad,2)*d1vxc(1:nrad,2) &
4711 9516274 : & +half*(v1sum(1:nrad,1)*d1vxc(1:nrad,1)+v1sum(1:nrad,3)*d1vxc(1:nrad,3))
4712 : end if
4713 : end if
4714 :
4715 : ! Second order development
4716 66546 : if (pawxcdev>=2) then
4717 688 : LIBPAW_ALLOCATE(gg,(nrad))
4718 :
4719 376290 : gg=zero
4720 8120 : do ilm=2,lm_size
4721 8120 : if (lmselect(ilm)) then
4722 7331888 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,1)*rho_up(1:nrad,ilm)
4723 : end if
4724 : end do
4725 376290 : ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,1)/6._dp
4726 :
4727 344 : if (nspden_updn==2) then ! Spin polarized (including non-coll. magn.)
4728 334680 : gg=zero
4729 7850 : do ilm=2,lm_size
4730 7850 : if (lmselect(ilm)) then
4731 7287504 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_dn(1:nrad,ilm)
4732 : end if
4733 : end do
4734 334680 : ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,4)/6._dp
4735 334680 : gg=zero
4736 7850 : do ilm=2,lm_size
4737 7850 : if (lmselect(ilm)) then
4738 7287504 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,2)*rho_up(1:nrad,ilm)
4739 : end if
4740 : end do
4741 334680 : ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,2)
4742 334680 : gg=zero
4743 7850 : do ilm=2,lm_size
4744 7850 : if (lmselect(ilm)) then
4745 7287504 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_up(1:nrad,ilm)
4746 : end if
4747 : end do
4748 334680 : ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,3)
4749 : end if
4750 344 : LIBPAW_DEALLOCATE(gg)
4751 : end if
4752 :
4753 : end if ! option/=4
4754 :
4755 89156164 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
4756 67037 : call simp_gen(enxc,ff,pawrad)
4757 67037 : LIBPAW_DEALLOCATE(ff)
4758 : end if ! option/=1 and option/=5
4759 :
4760 : !----- Calculate Sxc term (using Exc as a model)
4761 : !----------------------------------------
4762 90817667 : if (any(tsxci/=zero).and.option/=1.and.option/=5) then
4763 60 : LIBPAW_ALLOCATE(ff,(nrad))
4764 :
4765 : ! Contribution from spherical part of rho
4766 30 : if (nspden==1.or.nspden==4) then
4767 11050 : ff(1:nrad)=rho_updn(1:nrad,1,1)*tsxci(1:nrad)*sqfpi
4768 0 : else if (nspden==2) then
4769 0 : ff(1:nrad)=(rho_updn(1:nrad,1,1)+rho_updn(1:nrad,1,2))*tsxci(1:nrad)*sqfpi
4770 : end if
4771 :
4772 : ! Contribution from aspherical part of rho
4773 30 : if (option/=4) then
4774 :
4775 : ! First order development
4776 28 : if (pawxcdev>=1) then
4777 28 : if (nspden_updn==1) then
4778 10276 : ff(1:nrad)=ff(1:nrad)+half*v1sum(1:nrad,1)*d1vxc(1:nrad,1)
4779 0 : else if (nspden_updn==2) then
4780 : ff(1:nrad)=ff(1:nrad)+v1sum(1:nrad,2)*d1vxc(1:nrad,2) &
4781 0 : & +half*(v1sum(1:nrad,1)*d1vxc(1:nrad,1)+v1sum(1:nrad,3)*d1vxc(1:nrad,3))
4782 : end if
4783 : end if
4784 :
4785 : ! Second order development
4786 28 : if (pawxcdev>=2) then
4787 0 : LIBPAW_ALLOCATE(gg,(nrad))
4788 :
4789 0 : gg=zero
4790 0 : do ilm=2,lm_size
4791 0 : if (lmselect(ilm)) then
4792 0 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,1)*rho_up(1:nrad,ilm)
4793 : end if
4794 : end do
4795 0 : ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,1)/6._dp
4796 :
4797 0 : if (nspden_updn==2) then ! Spin polarized (including non-coll. magn.)
4798 0 : gg=zero
4799 0 : do ilm=2,lm_size
4800 0 : if (lmselect(ilm)) then
4801 0 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_dn(1:nrad,ilm)
4802 : end if
4803 : end do
4804 0 : ff(1:nrad)=ff(1:nrad)+gg(1:nrad)*d2vxc(1:nrad,4)/6._dp
4805 0 : gg=zero
4806 0 : do ilm=2,lm_size
4807 0 : if (lmselect(ilm)) then
4808 0 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,2)*rho_up(1:nrad,ilm)
4809 : end if
4810 : end do
4811 0 : ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,2)
4812 0 : gg=zero
4813 0 : do ilm=2,lm_size
4814 0 : if (lmselect(ilm)) then
4815 0 : gg(1:nrad)=gg(1:nrad)+v2sum(1:nrad,ilm,3)*rho_up(1:nrad,ilm)
4816 : end if
4817 : end do
4818 0 : ff(1:nrad)=ff(1:nrad)+half*gg(1:nrad)*d2vxc(1:nrad,3)
4819 : end if
4820 0 : LIBPAW_DEALLOCATE(gg)
4821 : end if
4822 :
4823 : end if ! option/=4
4824 :
4825 11050 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
4826 30 : call simp_gen(snxc,ff,pawrad)
4827 30 : LIBPAW_DEALLOCATE(ff)
4828 60 : snxc=snxc/el_temp
4829 : end if ! option/=1 and option/=5
4830 :
4831 69480 : LIBPAW_DEALLOCATE(tsxci)
4832 69480 : LIBPAW_DEALLOCATE(exci)
4833 69480 : LIBPAW_DEALLOCATE(vxci)
4834 69480 : if (nspden==4.and.option/=4.and.option/=5) then
4835 2798 : LIBPAW_POINTER_DEALLOCATE(rho_dn)
4836 : end if
4837 69480 : if (allocated(v1sum)) then
4838 68945 : LIBPAW_DEALLOCATE(v1sum)
4839 : end if
4840 69480 : if (allocated(v2sum)) then
4841 68945 : LIBPAW_DEALLOCATE(v2sum)
4842 : end if
4843 69480 : if (allocated(d1vxc)) then
4844 68945 : LIBPAW_DEALLOCATE(d1vxc)
4845 : end if
4846 69480 : if (allocated(d2vxc)) then
4847 68945 : LIBPAW_DEALLOCATE(d2vxc)
4848 : end if
4849 :
4850 : !----- Calculate Excdc double counting term
4851 : !------------------------------------------
4852 69480 : if (option==0.or.option==2) then
4853 :
4854 133092 : LIBPAW_ALLOCATE(ff,(nrad))
4855 :
4856 : ! Build appropriate density (without core density)
4857 991189844 : rho_updn(:,:,:)=rhor(:,:,:)
4858 207637174 : if (usexcnhat>0) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:)
4859 66546 : if (nspden==2) then
4860 195598 : do ilm=1,lm_size
4861 128712922 : ff(:)=rho_updn(:,ilm,2)
4862 128712922 : rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:)
4863 128721944 : rho_updn(:,ilm,1)=ff(:)
4864 : end do
4865 : end if
4866 :
4867 88556090 : ff(1:nrad)=zero
4868 :
4869 : ! Non magnetic or collinear magnetic system:
4870 66546 : if (nspden/=4) then
4871 136814 : do ispden=1,nspden_updn
4872 953864 : do ilm=1,lm_size
4873 523744986 : if (lmselect(ilm)) ff(1:nrad)=ff(1:nrad)+vxc(1:nrad,ilm,ispden)*rho_updn(1:nrad,ilm,ispden)
4874 : end do
4875 : end do
4876 : else
4877 : ! Non-collinear magnetic system:
4878 70292 : do ilm=1,lm_size
4879 70292 : if (lmselect(ilm)) then
4880 59234848 : do ir=1,nrad
4881 59171550 : dvxca=vxc(ir,ilm,1)+vxc(ir,ilm,2);dvxcb=vxc(ir,ilm,1)-vxc(ir,ilm,2)
4882 : ff(ir)=ff(ir)+half*(dvxca*rho_updn(ir,ilm,1)+dvxcb*rho_updn(ir,ilm,4)) &
4883 59234848 : & +vxc(ir,ilm,3)*rho_updn(ir,ilm,2)-vxc(ir,ilm,4)*rho_updn(ir,ilm,3)
4884 : end do
4885 : end if
4886 : end do
4887 : end if
4888 :
4889 88556090 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
4890 66546 : call simp_gen(enxcdc,ff,pawrad)
4891 66546 : LIBPAW_DEALLOCATE(ff)
4892 :
4893 : end if ! option
4894 :
4895 69480 : LIBPAW_DEALLOCATE(rho_updn)
4896 :
4897 139948 : end subroutine pawxcm
4898 : !!***
4899 :
4900 : !----------------------------------------------------------------------
4901 :
4902 : !!****f* m_pawxc/pawxcm_dfpt
4903 : !! NAME
4904 : !! pawxcm_dfpt
4905 : !!
4906 : !! FUNCTION
4907 : !! Compute first-order change of XC potential and contribution to
4908 : !! 2nd-order change of XC energy inside a PAW sphere.
4909 : !! LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS
4910 : !!
4911 : !! INPUTS
4912 : !! corexc1(cplex_den*nrad)=first-order change of core density on radial grid
4913 : !! cplex_den= if 1, 1st-order densities are REAL, if 2, COMPLEX
4914 : !! cplex_vxc= if 1, 1st-order XC potential is complex, if 2, COMPLEX
4915 : !! ixc= choice of exchange-correlation scheme
4916 : !! kxc(nrad,lm_size,nkxc)=GS xc kernel
4917 : !! lm_size=size of density array rhor (see below)
4918 : !! lmselect(lm_size)=select the non-zero LM-moments of input density rhor1
4919 : !! nhat1(cplex_den*nrad,lm_size,nspden)=first-order change of compensation density
4920 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
4921 : !! nkxc=second dimension of the kxc array
4922 : !! non_magnetic_xc= if true, handle density/potential as non-magnetic (even if it is)
4923 : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
4924 : !! nspden=number of spin-density components
4925 : !! option=0 compute both 2nd-order XC energy and 1st-order potential
4926 : !! 1 compute only 1st-order XC potential
4927 : !! 2 compute only 2nd-order XC energy, XC potential is temporary computed here
4928 : !! 3 compute only 2nd-order XC energy, XC potential is input in vxc1(:)
4929 : !! pawang <type(pawang_type)>=paw angular mesh and related data
4930 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
4931 : !! rhor1(cplex_den*nrad,lm_size,nspden)=first-order change of density
4932 : !! usecore= 1 if core density has to be used in Exc/Vxc ; 0 otherwise
4933 : !! usexcnhat= 0 if compensation density does not have to be used
4934 : !! 1 if compensation density has to be used in d2Exc only
4935 : !! 2 if compensation density (nhat) has to be used in d2Exc and Vxc1
4936 : !! xclevel= XC functional level
4937 : !!
4938 : !! OUTPUT
4939 : !! == if option=0 or 2 or 3 ==rho1_updn
4940 : !! d2enxc=returned exchange-cor. contribution to 2nd-order XC energy
4941 : !!
4942 : !! SIDE EFFECTS
4943 : !! vxc1(cplex_vxc*nrad,pawang%angl_size,nspden)=1st-order XC potential
4944 : !! Output if option==0 or 1
4945 : !! Unused if option==2
4946 : !! Input if option==3
4947 : !!
4948 : !! SOURCE
4949 :
4950 34122 : subroutine pawxcm_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,&
4951 34122 : & nkxc,non_magnetic_xc,nrad,nspden,option,pawang,pawrad,rhor1,usecore,&
4952 34122 : & usexcnhat,vxc1,xclevel,&
4953 : & d2enxc_im) ! optional
4954 :
4955 : !Arguments ------------------------------------
4956 : !scalars
4957 : integer,intent(in) :: cplex_den,cplex_vxc,ixc,lm_size,nkxc,nrad,nspden,option
4958 : integer,intent(in) :: usecore,usexcnhat,xclevel
4959 : logical,intent(in) :: non_magnetic_xc
4960 : real(dp),intent(out) :: d2enxc
4961 : real(dp),intent(out),optional :: d2enxc_im
4962 : type(pawang_type),intent(in) :: pawang
4963 : type(pawrad_type),intent(in) :: pawrad
4964 : !arrays
4965 : logical,intent(in) :: lmselect(lm_size)
4966 : real(dp),intent(in) :: corexc1(cplex_den*nrad)
4967 : real(dp),intent(in) :: kxc(nrad,lm_size,nkxc)
4968 : real(dp),intent(in) :: nhat1(cplex_den*nrad,lm_size,nspden*((usexcnhat+1)/2))
4969 : real(dp),intent(in) :: rhor1(cplex_den*nrad,lm_size,nspden)
4970 : real(dp),intent(inout),target :: vxc1(cplex_vxc*nrad,lm_size,nspden)
4971 :
4972 : !Local variables-------------------------------
4973 : !scalars
4974 : integer :: ii,ilm,iplex,ir,ivxc,jr,kr,nkxc_cur
4975 : logical :: need_impart
4976 : real(dp) :: invsqfpi,ro1i,ro1r,sqfpi,sqfpi2,v1i,v1r,vxcrho
4977 : character(len=500) :: msg
4978 : !arrays
4979 : integer,parameter :: ikxc(4)=(/1,2,2,3/),irho(4)=(/1,2,1,2/)
4980 : ! real(dp) :: tsec(2)
4981 34122 : real(dp),allocatable :: ff(:),gg(:),rho1_updn(:,:,:)
4982 34122 : real(dp),allocatable :: v1sum(:),v2sum(:,:)
4983 34122 : real(dp),pointer :: vxc1_(:,:,:)
4984 :
4985 : !************************************************************************
4986 :
4987 : !NOTE (MT)
4988 : !lmselect and lm_size are not necessarily the same for densities, kxc and vxc1
4989 : !This is not taken into account for the moment, but has to be programmed...
4990 :
4991 : !----------------------------------------------------------------------
4992 : !----- Check options
4993 : !----------------------------------------------------------------------
4994 :
4995 34122 : if(option<0.or.option>3) then
4996 0 : msg='wrong option!'
4997 0 : LIBPAW_BUG(msg)
4998 : end if
4999 34122 : if(option/=3) then
5000 17370 : call pawxc_get_nkxc(nkxc_cur,nspden,xclevel)
5001 17370 : if(nkxc/=nkxc_cur) then
5002 0 : msg='Wrong size for kxc array!'
5003 0 : LIBPAW_BUG(msg)
5004 : end if
5005 : end if
5006 34122 : if(nspden==4.and.option/=3) then
5007 0 : msg='nspden=4 not implemented (for vxc)!'
5008 0 : LIBPAW_ERROR(msg)
5009 : end if
5010 34122 : if (option/=1) then
5011 25066 : if (nrad<pawrad%int_meshsz) then
5012 0 : msg='When option=0,2,3, nrad must be greater than pawrad%int_meshsz!'
5013 0 : LIBPAW_BUG(msg)
5014 : end if
5015 : end if
5016 :
5017 : !----------------------------------------------------------------------
5018 : !----- Initializations
5019 : !----------------------------------------------------------------------
5020 :
5021 : !Arrays dimensions and constants
5022 34122 : need_impart=present(d2enxc_im)
5023 34122 : sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi;invsqfpi=one/sqfpi
5024 :
5025 : !Initializations of outputs
5026 34122 : if (option/=1) then
5027 25066 : d2enxc=zero
5028 25066 : if (need_impart) d2enxc_im=zero
5029 : end if
5030 51480290 : if (option<=1) vxc1(:,:,:)=zero
5031 :
5032 : !Special case: no XC applied
5033 34122 : if (ixc==0.or.(nkxc==0.and.option/=3)) then
5034 0 : msg='Note that no xc is applied (ixc=0). Returning'
5035 0 : LIBPAW_WARNING(msg)
5036 : return
5037 : end if
5038 :
5039 : !----------------------------------------------------------------------
5040 : !----- Build several densities
5041 : !----------------------------------------------------------------------
5042 :
5043 : !rho1_updn contains the effective 1st-order density used for XC
5044 : !with 1st-order core density and/or 1st-order compensation density eventually included
5045 : !-----------------------------------------------------------------
5046 170610 : LIBPAW_ALLOCATE(rho1_updn,(cplex_den*nrad,lm_size,nspden))
5047 186976114 : rho1_updn(:,:,:)=rhor1(:,:,:)
5048 63759324 : if (usexcnhat==2) rho1_updn(:,:,:)=rho1_updn(:,:,:)+nhat1(:,:,:)
5049 34122 : if (usecore==1) then
5050 0 : if (nspden==1.or.nspden==4) then
5051 0 : rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:)
5052 0 : else if (nspden==2) then
5053 0 : rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:)
5054 0 : rho1_updn(:,1,2)=rho1_updn(:,1,2)+sqfpi2*corexc1(:)
5055 : end if
5056 : end if
5057 :
5058 : !Optionally suppressed magnetic part
5059 34122 : if(non_magnetic_xc) then
5060 0 : if(nspden==2) rho1_updn(:,:,2)=rho1_updn(:,:,1)*half
5061 0 : if(nspden==4) rho1_updn(:,:,2:4)=zero
5062 : endif
5063 :
5064 : !In case of collinear magnetism, separate up and down contributions
5065 34122 : if (nspden==2) then
5066 0 : LIBPAW_ALLOCATE(ff,(cplex_den*nrad))
5067 0 : do ilm=1,lm_size
5068 0 : ff(:)=rho1_updn(:,ilm,2)
5069 0 : rho1_updn(:,ilm,2)=rho1_updn(:,ilm,1)-ff(:)
5070 0 : rho1_updn(:,ilm,1)=ff(:)
5071 : end do
5072 0 : LIBPAW_DEALLOCATE(ff)
5073 : end if
5074 :
5075 : !
5076 : !----------------------------------------------------------------------
5077 : !----- Accumulate and store 1st-order change of XC potential
5078 : !----------------------------------------------------------------------
5079 :
5080 34122 : if (option==2) then
5081 41570 : LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,lm_size,nspden))
5082 : else
5083 25808 : vxc1_ => vxc1
5084 : end if
5085 :
5086 34122 : if (option/=3) then
5087 :
5088 98622964 : vxc1_=zero
5089 52110 : LIBPAW_ALLOCATE(v1sum,(cplex_vxc*nrad))
5090 69480 : LIBPAW_ALLOCATE(v2sum,(cplex_vxc*nrad,lm_size))
5091 :
5092 34740 : do ii=1,3*nspden-2
5093 17370 : ivxc=1;if (ii>2) ivxc=2
5094 :
5095 : ! === Vxc1 and Rho1 are REAL
5096 34740 : if (cplex_vxc==1.and.cplex_den==1) then ! cplex_vxc==1 and cplex_den==1
5097 : call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,1,2,pawang,&
5098 15978 : & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum)
5099 9263120 : vxc1_(:,1,ivxc)=vxc1_(:,1,ivxc)+invsqfpi*(v1sum(:)+kxc(:,1,ikxc(ii))*rho1_updn(:,1,irho(ii)))
5100 146458 : do ilm=2,lm_size
5101 : vxc1_(:,ilm,ivxc)=vxc1_(:,ilm,ivxc)+v2sum(:,ilm) &
5102 : & +invsqfpi*(kxc(:,ilm,ikxc(ii))*rho1_updn(:,1 ,irho(ii)) &
5103 77201450 : & +kxc(:,1 ,ikxc(ii))*rho1_updn(:,ilm,irho(ii)))
5104 : end do
5105 :
5106 : ! === At least one of Vxc1 or Rho1 is COMPLEX
5107 : else
5108 : call pawxcsum(1,cplex_den,cplex_vxc,lmselect,lmselect,lm_size,nrad,1,2,pawang,&
5109 1392 : & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum)
5110 675120 : do ir=1,nrad
5111 673728 : jr=cplex_den*(ir-1);kr=cplex_vxc*(ir-1)
5112 2022576 : do iplex=1,1+(cplex_den*cplex_vxc)/4
5113 1347456 : jr=jr+1;kr=kr+1
5114 1347456 : vxc1_(kr,1,ivxc)=vxc1_(kr,1,ivxc)+invsqfpi*(v1sum(kr)+kxc(ir,1,ikxc(ii))*rho1_updn(jr,1,irho(ii)))
5115 12800832 : do ilm=2,lm_size
5116 : vxc1_(kr,ilm,ivxc)=vxc1_(kr,ilm,ivxc)+v2sum(kr,ilm) &
5117 : & +invsqfpi*(kxc(ir,ilm,ikxc(ii))*rho1_updn(jr,1 ,irho(ii)) &
5118 12127104 : & +kxc(ir,1 ,ikxc(ii))*rho1_updn(jr,ilm,irho(ii)))
5119 : end do
5120 : end do
5121 : end do
5122 :
5123 : end if ! cplex_den and vxc_den
5124 : end do ! ii=1,3*nspden-2
5125 :
5126 17370 : LIBPAW_DEALLOCATE(v1sum)
5127 17370 : LIBPAW_DEALLOCATE(v2sum)
5128 :
5129 : end if
5130 :
5131 : !----------------------------------------------------------------------
5132 : !----- Accumulate and store 2nd-order change of XC energy
5133 : !----------------------------------------------------------------------
5134 34122 : if (option/=1) then
5135 :
5136 25066 : if (.not.non_magnetic_xc) then
5137 : ! For usexnhat=1 particular case, add now compensation density
5138 25066 : if (usexcnhat==1) then
5139 0 : rho1_updn(:,:,1)=rho1_updn(:,:,1)+nhat1(:,:,nspden)
5140 0 : if (nspden==2) rho1_updn(:,:,2)=rho1_updn(:,:,2)+nhat1(:,:,1)-nhat1(:,:,2)
5141 : end if
5142 : else
5143 : ! Has to be magnetic here
5144 0 : rho1_updn(:,:,:)=rhor1(:,:,:)
5145 0 : if (usexcnhat>0) rho1_updn(:,:,:)=rho1_updn(:,:,:)+nhat1(:,:,:)
5146 0 : if (usecore==1) then
5147 0 : if (nspden==1.or.nspden==4) then
5148 0 : rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:)
5149 0 : else if (nspden==2) then
5150 0 : rho1_updn(:,1,1)=rho1_updn(:,1,1)+sqfpi*corexc1(:)
5151 0 : rho1_updn(:,1,2)=rho1_updn(:,1,2)+sqfpi2*corexc1(:)
5152 : end if
5153 : end if
5154 : end if
5155 :
5156 75198 : LIBPAW_ALLOCATE(ff,(nrad))
5157 14193302 : ff=zero
5158 25066 : if (need_impart) then
5159 33504 : LIBPAW_ALLOCATE(gg,(nrad))
5160 9432110 : gg=zero
5161 : end if
5162 :
5163 : ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr]
5164 50132 : do ii=1,nspden
5165 : ! === Vxc1 and Rho1 are REAL
5166 50132 : if (cplex_vxc==1.and.cplex_den==1) then
5167 242932 : do ilm=1,lm_size
5168 75063334 : if (lmselect(ilm)) ff(:)=ff(:)+vxc1_(:,ilm,ii)*rho1_updn(:,ilm,ii)
5169 : end do
5170 : ! === Vxc1 and Rho1 are COMPLEX
5171 1048 : else if (cplex_vxc==2.and.cplex_den==2) then ! cplex_vxc==2 and cplex_den==2
5172 1048 : if (.not.need_impart) then ! Real part only
5173 6640 : do ilm=1,lm_size
5174 6640 : if (lmselect(ilm)) then
5175 2572440 : do ir=1,nrad
5176 2567136 : jr=2*ir;v1r=vxc1_(jr-1,ilm,ii);v1i=vxc1_(jr,ilm,ii)
5177 2567136 : ro1r=rho1_updn(jr-1,ilm,ii);ro1i=rho1_updn(jr,ilm,ii)
5178 2572440 : ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i
5179 : end do
5180 : end if
5181 : end do
5182 : else ! Real and imaginary parts
5183 3840 : do ilm=1,lm_size
5184 3840 : if (lmselect(ilm)) then
5185 1520960 : do ir=1,nrad
5186 1517824 : jr=2*ir;v1r=vxc1_(jr-1,ilm,ii);v1i=vxc1_(jr,ilm,ii)
5187 1517824 : ro1r=rho1_updn(jr-1,ilm,ii);ro1i=rho1_updn(jr,ilm,ii)
5188 1517824 : ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i
5189 1520960 : gg(ir)=gg(ir)+v1r*ro1i-v1i*ro1r
5190 : end do
5191 : end if
5192 : end do
5193 : end if ! need_impart
5194 : ! === Vxc1 and Rho1 are REAL and COMPLEX
5195 : else
5196 : v1i=zero;ro1i=zero
5197 0 : do ilm=1,lm_size
5198 0 : if (lmselect(ilm)) then
5199 0 : do ir=1,nrad
5200 0 : jr=cplex_vxc*(ir-1)+1;v1r=vxc1_(jr,ilm,ii);;if(cplex_vxc==2)v1i=vxc1_(jr+1,ilm,ii)
5201 0 : jr=cplex_den*(ir-1)+1;ro1r=rho1_updn(jr,ilm,ii);if(cplex_den==2)ro1i=rho1_updn(jr+1,ilm,ii)
5202 0 : ff(ir)=ff(ir)+v1r*ro1r+v1i*ro1i
5203 0 : if (need_impart) gg(ir)=gg(ir)+v1r*ro1i-v1i*ro1r
5204 : end do
5205 : end if
5206 : end do
5207 : end if ! cplex_vxc and cplex_den
5208 : end do ! ii=1,nspden
5209 :
5210 14193302 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5211 25066 : call simp_gen(vxcrho,ff,pawrad)
5212 25066 : d2enxc=d2enxc+vxcrho
5213 25066 : LIBPAW_DEALLOCATE(ff)
5214 :
5215 50132 : if (need_impart) then
5216 9432110 : gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2
5217 16752 : call simp_gen(vxcrho,gg,pawrad)
5218 16752 : d2enxc_im=d2enxc_im+vxcrho
5219 16752 : LIBPAW_DEALLOCATE(gg)
5220 : end if
5221 :
5222 : end if
5223 :
5224 34122 : LIBPAW_DEALLOCATE(rho1_updn)
5225 34122 : if (option==2) then
5226 8314 : LIBPAW_POINTER_DEALLOCATE(vxc1_)
5227 : end if
5228 :
5229 68244 : end subroutine pawxcm_dfpt
5230 : !!***
5231 :
5232 : !----------------------------------------------------------------------
5233 :
5234 : !!****f* m_pawxc/pawxcmpositron
5235 : !! NAME
5236 : !! pawxcmpositron
5237 : !!
5238 : !! FUNCTION
5239 : !! Compute electron-positron correlation potential and energies inside a PAW sphere
5240 : !! LDA+GGA - USE A DEVELOPMENT OF THE DENSITY OVER (L,M) MOMENTS
5241 : !! Driver of XC functionals.
5242 : !!
5243 : !! INPUTS
5244 : !! calctype=type of electron-positron calculation:
5245 : !! calctype=1 : positron in electronic density
5246 : !! calctype=2 : electrons in positronic density
5247 : !! corexc(nrad)=electron core density on radial grid
5248 : !! ixcpositron=choice of electron-positron XC scheme
5249 : !! lm_size=size of density array rhor (see below)
5250 : !! lmselect (lm_size)=select the non-zero LM-moments of input density rhor (see below)
5251 : !! lmselect_ep(lm_size)=select the non-zero LM-moments of input density rhor_ep (see below)
5252 : !! nhat (nrad,lm_size,nspden)=compensation density corresponding to rhor
5253 : !! nhat_ep(nrad,lm_size,nspden)=compensation density corresponding to rhor_ep
5254 : !! nrad=size of radial mesh for densities/potentials (might be different from pawrad%mesh_size)
5255 : !! nspden=number of spin-density components
5256 : !! option=0 compute both XC energies (direct+double-counting) and potential
5257 : !! 1 compute only XC potential
5258 : !! 2 compute only XC energies (direct+double-counting)
5259 : !! 3 compute only XC energy by direct scheme
5260 : !! 4 compute only XC energy by direct scheme for spherical part of the density
5261 : !! pawang <type(pawang_type)>=paw angular mesh and related data
5262 : !! pawrad <type(pawrad_type)>=paw radial mesh and related data
5263 : !! pawxcdev=order of Vxc development
5264 : !! posdensity0_limit=True if we are in the zero positron density limit
5265 : !! rhor(nrad,lm_size,nspden)=electron (or positron) density in real space
5266 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
5267 : !! Contents depends on calctype value:
5268 : !! calctype=1: rhor is the positronic density
5269 : !! calctype=2: rhor is the electronic density
5270 : !! rhor_ep(nrad,lm_size,nspden)=electron (or positron) density in real space
5271 : !! (total in 1st half and spin-up in 2nd half if nspden=2)
5272 : !! Contents depends on calctype value:
5273 : !! calctype=1: rhor_ep is the electronic density
5274 : !! calctype=2: rhor_ep is the positronic density
5275 : !! usecore= 1 if core density has to be used in Exc/Vxc for the electronic density ; 0 otherwise
5276 : !! usexcnhat= 0 if compensation density does not have to be used
5277 : !! 1 if compensation density has to be used in double counting energy term only
5278 : !! 2 if compensation density (nhat) has to be used in Exc/Vxc and double counting energy term
5279 : !! xc_denpos= lowest allowed density (usually for the computation of the XC functionals)
5280 : !!
5281 : !! OUTPUT
5282 : !! == if option==0, 2, 3, or 4 ==
5283 : !! enxc=returned exchange and correlation energy (hartree)
5284 : !! == if option==0 or 2 ==
5285 : !! enxcdc=returned exchange-cor. contribution to double-counting energy
5286 : !! == if option==0 or 1 ==
5287 : !! vxc(nrad,lm_size,nspden)=xc potential
5288 : !! (spin up in 1st half and spin-down in 2nd half if nspden=2)
5289 : !!
5290 : !! NOTES
5291 : !!
5292 : !! SOURCE
5293 :
5294 11752 : subroutine pawxcmpositron(calctype,corexc,enxc,enxcdc,ixcpositron,lm_size,lmselect,lmselect_ep,&
5295 11752 : & nhat,nhat_ep,nrad,nspden,option,pawang,pawrad,pawxcdev,posdensity0_limit,&
5296 11752 : & rhor,rhor_ep,usecore,usexcnhat,vxc,xc_denpos)
5297 :
5298 : !Arguments ------------------------------------
5299 : !scalars
5300 : integer,intent(in) :: calctype,ixcpositron,lm_size,nrad,nspden,option,pawxcdev,usecore
5301 : integer,intent(in) :: usexcnhat
5302 : logical,intent(in) :: posdensity0_limit
5303 : real(dp),intent(in) :: xc_denpos
5304 : real(dp),intent(out) :: enxc,enxcdc
5305 : type(pawang_type),intent(in) :: pawang
5306 : type(pawrad_type),intent(in) :: pawrad
5307 : !arrays
5308 : logical,intent(in) :: lmselect(lm_size),lmselect_ep(lm_size)
5309 : real(dp),intent(in) :: corexc(nrad)
5310 : real(dp),intent(in) :: nhat (nrad,lm_size,nspden*((usexcnhat+1)/2))
5311 : real(dp),intent(in) :: nhat_ep(nrad,lm_size,nspden*((usexcnhat+1)/2))
5312 : real(dp),intent(in) :: rhor (nrad,lm_size,nspden)
5313 : real(dp),intent(in) :: rhor_ep(nrad,lm_size,nspden)
5314 : real(dp),intent(out) :: vxc(nrad,lm_size,nspden)
5315 :
5316 : !Local variables-------------------------------
5317 : !scalars
5318 : integer :: ilm,ir,ir1,ir2,iwarn,iwarnp,jr
5319 : real(dp),parameter :: delta=1.d-4
5320 : real(dp) :: fact,invsqfpi,sqfpi,rhomin
5321 : character(len=500) :: msg
5322 : !arrays
5323 11752 : real(dp),allocatable :: d1vxc(:,:),d2vxc(:,:),fxc_(:),ff(:),fxci(:),gg(:)
5324 11752 : real(dp),allocatable :: rho_(:),rhotot(:,:),rhotot_ep(:,:),rhoinv(:),rhoinv_ep(:)
5325 11752 : real(dp),allocatable :: rhosph(:),rhosph_ep(:),v1sum(:,:),v2sum(:,:,:)
5326 11752 : real(dp),allocatable :: vxce1(:),vxce1_ep(:),vxce2(:),vxce2_ep(:)
5327 11752 : real(dp),allocatable :: vxcp1(:),vxcp1_ep(:),vxcp2(:),vxcp2_ep(:)
5328 11752 : real(dp),allocatable :: vxcei(:),vxcpi(:)
5329 :
5330 : !************************************************************************
5331 :
5332 : !----- Check options
5333 11752 : if(calctype/=1.and.calctype/=2) then
5334 0 : msg='Invalid value for calctype'
5335 0 : LIBPAW_BUG(msg)
5336 : end if
5337 11752 : if (option/=1) then
5338 11752 : if (nrad<pawrad%int_meshsz) then
5339 0 : msg='When option=0,2,3,4, nrad must be greater than pawrad%int_meshsz!'
5340 0 : LIBPAW_BUG(msg)
5341 : end if
5342 : end if
5343 :
5344 : !----------------------------------------------------------------------
5345 : !----- Initializations
5346 : !----------------------------------------------------------------------
5347 :
5348 : !Initializations and constants
5349 11752 : iwarn=0;iwarnp=1
5350 11752 : sqfpi=sqrt(four_pi)
5351 11752 : invsqfpi=one/sqfpi
5352 :
5353 : !Initializations of output arrays
5354 11752 : if (option/=1) enxc=zero
5355 11752 : if (option==0.or.option==2) enxcdc=zero
5356 141640664 : if (option<3) vxc(:,:,:)=zero
5357 :
5358 11752 : if (ixcpositron==0) then ! No xc at all is applied (usually for testing)
5359 0 : msg='Note that no xc is applied (ixc=0). Returning'
5360 0 : LIBPAW_WARNING(msg)
5361 0 : return
5362 : end if
5363 :
5364 : !----------------------------------------------------------------------
5365 : !----- Build several densities
5366 : !----------------------------------------------------------------------
5367 :
5368 : !rhotot/rhotot_ep contain the effective total densities used for XC
5369 : !with core density and/or compensation density eventually included
5370 : !-----------------------------------------------------------------
5371 : !Input density
5372 47008 : LIBPAW_ALLOCATE(rhotot,(nrad,lm_size))
5373 35256 : LIBPAW_ALLOCATE(rhotot_ep,(nrad,lm_size))
5374 141628912 : rhotot (:,:)=rhor (:,:,1)
5375 141628912 : rhotot_ep(:,:)=rhor_ep(:,:,1)
5376 : !Eventually add compensation density
5377 11752 : if (usexcnhat==2) then
5378 2113048 : rhotot (:,:)=rhotot (:,:)+nhat (:,:,1)
5379 2113048 : rhotot_ep(:,:)=rhotot_ep(:,:)+nhat_ep(:,:,1)
5380 : end if
5381 : !Eventually add core density
5382 11752 : if (usecore==1) then
5383 6223436 : if (calctype==1) rhotot_ep(:,1)=rhotot_ep(:,1)+sqfpi*corexc(:)
5384 9479940 : if (calctype==2) rhotot (:,1)=rhotot (:,1)+sqfpi*corexc(:)
5385 : end if
5386 :
5387 : !rhoSPH/rhoSPH_ep contain the spherical part of effective densities
5388 : !(including Y00 spherical harmonic)
5389 : !-----------------------------------------------------------------
5390 35256 : LIBPAW_ALLOCATE(rhosph,(nrad))
5391 23504 : LIBPAW_ALLOCATE(rhosph_ep,(nrad))
5392 :
5393 15735240 : rhosph (:)=rhotot (:,1)*invsqfpi
5394 15735240 : rhosph_ep(:)=rhotot_ep(:,1)*invsqfpi
5395 :
5396 : !Make spherical densities positive
5397 11752 : if (calctype==1) then
5398 4782 : if (.not.posdensity0_limit) then
5399 56 : call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhosph,xc_denpos)
5400 : end if
5401 4782 : call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhosph_ep,xc_denpos)
5402 6970 : else if (calctype==2) then
5403 6970 : call pawxc_mkdenpos_wrapper(iwarn ,nrad,1,1,rhosph,xc_denpos)
5404 6970 : if (.not.posdensity0_limit) then
5405 56 : call pawxc_mkdenpos_wrapper(iwarnp,nrad,1,1,rhosph_ep,xc_denpos)
5406 : end if
5407 : end if
5408 :
5409 : !----------------------------------------------------------------------
5410 : !----- Compute Exc(rhoSPH,rhoSPH_ep) and Vxc(rhoSPH,rhoSPH_ep)
5411 : !----------------------------------------------------------------------
5412 :
5413 23504 : LIBPAW_ALLOCATE(fxci,(nrad))
5414 23504 : LIBPAW_ALLOCATE(vxcei,(nrad))
5415 23504 : LIBPAW_ALLOCATE(vxcpi,(nrad))
5416 11752 : call pawxcsphpositron(calctype,fxci,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rhosph_ep,vxcei,vxcpi)
5417 :
5418 : !----------------------------------------------------------------------
5419 : !----- Compute numerical derivatives of Vxc (by finite diff. scheme)
5420 : !----------------------------------------------------------------------
5421 :
5422 11752 : if (option/=4) then
5423 :
5424 23504 : LIBPAW_ALLOCATE(fxc_,(nrad))
5425 23504 : LIBPAW_ALLOCATE(rho_,(nrad))
5426 :
5427 : ! Compute Vxc for (rho+delta_rho,rho_ep)
5428 23504 : LIBPAW_ALLOCATE(vxce1,(nrad))
5429 23504 : LIBPAW_ALLOCATE(vxcp1,(nrad))
5430 15735240 : rho_(:)=(one+delta)*rhosph(:)
5431 11752 : call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rho_,rhosph_ep,vxce1,vxcp1)
5432 :
5433 : ! Compute Vxc for(rho-delta_rho,rho_ep)
5434 23504 : LIBPAW_ALLOCATE(vxce2,(nrad))
5435 23504 : LIBPAW_ALLOCATE(vxcp2,(nrad))
5436 15735240 : rho_(:)=(one-delta)*rhosph(:)
5437 11752 : call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rho_,rhosph_ep,vxce2,vxcp2)
5438 :
5439 : ! Compute Vxc for (rho,rho_ep+delta_rho_ep)
5440 23504 : LIBPAW_ALLOCATE(vxce1_ep,(nrad))
5441 23504 : LIBPAW_ALLOCATE(vxcp1_ep,(nrad))
5442 15735240 : rho_(:)=(one+delta)*rhosph_ep(:)
5443 11752 : call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rho_,vxce1_ep,vxcp1_ep)
5444 :
5445 : ! Compute Vxc for (rho,rho_ep-delta_rho_ep)
5446 23504 : LIBPAW_ALLOCATE(vxce2_ep,(nrad))
5447 23504 : LIBPAW_ALLOCATE(vxcp2_ep,(nrad))
5448 15735240 : rho_(:)=(one-delta)*rhosph_ep(:)
5449 11752 : call pawxcsphpositron(calctype,fxc_,ixcpositron,nrad,pawrad,posdensity0_limit,rhosph,rho_,vxce2_ep,vxcp2_ep)
5450 :
5451 11752 : LIBPAW_DEALLOCATE(fxc_)
5452 11752 : LIBPAW_DEALLOCATE(rho_)
5453 :
5454 : ! Store inverse of density finite step
5455 23504 : LIBPAW_ALLOCATE(rhoinv,(nrad))
5456 23504 : LIBPAW_ALLOCATE(rhoinv_ep,(nrad))
5457 15735240 : fact=one/delta
5458 15735240 : do ir=1,nrad
5459 15723488 : if (rhosph(ir)>rho_min) then
5460 15501351 : rhoinv(ir)=fact/rhosph(ir)
5461 : else
5462 222137 : rhoinv(ir)=zero
5463 : end if
5464 15735240 : if (rhosph_ep(ir)>rho_min) then
5465 15722788 : rhoinv_ep(ir)=fact/rhosph_ep(ir)
5466 : else
5467 700 : rhoinv_ep(ir)=zero
5468 : end if
5469 : end do
5470 :
5471 : ! Compute numerical first derivatives of Vxc (by finite difference scheme)
5472 35256 : LIBPAW_ALLOCATE(d1vxc,(nrad,3))
5473 11752 : if (calctype==1) then
5474 6260050 : d1vxc(:,1)=(vxcp1 (:)-vxcp2 (:))*half*rhoinv (:) ! dVxc+/drho+
5475 6260050 : d1vxc(:,2)=(vxcp1_ep(:)-vxcp2_ep(:))*half*rhoinv_ep(:) ! dVxc+/drho-
5476 6260050 : d1vxc(:,3)=(vxce1_ep(:)-vxce2_ep(:))*half*rhoinv_ep(:) ! dVxc-/drho-
5477 6970 : else if (calctype==2) then
5478 9475190 : d1vxc(:,1)=(vxce1 (:)-vxce2 (:))*half*rhoinv (:) ! dVxc-/drho-
5479 9475190 : d1vxc(:,2)=(vxcp1 (:)-vxcp2 (:))*half*rhoinv (:) ! dVxc+/drho-
5480 : ! d1vxc(:,2)=(vxce1_ep(:)-vxce2_ep(:))*half*rhoinv_ep(:) ! dVxc-/drho+
5481 9475190 : d1vxc(:,3)=(vxcp1_ep(:)-vxcp2_ep(:))*half*rhoinv_ep(:) ! dVxc+/drho+
5482 : end if
5483 :
5484 : ! Compute numerical second derivatives of Vxc (by finite difference scheme)
5485 11752 : if (option<3.or.pawxcdev>1) then
5486 35256 : LIBPAW_ALLOCATE(d2vxc,(nrad,4))
5487 11752 : if (calctype==1) then
5488 6260050 : d2vxc(:,1)=(vxcp1 (:)+vxcp2 (:)-two*vxcpi(:))*rhoinv (:)**2 ! d2Vxc+/drho+_drho+
5489 6260050 : d2vxc(:,2)=(vxce1 (:)+vxce2 (:)-two*vxcei(:))*rhoinv (:)**2 ! d2Vxc-/drho+_drho+
5490 6260050 : d2vxc(:,3)=(vxcp1_ep(:)+vxcp2_ep(:)-two*vxcpi(:))*rhoinv_ep(:)**2 ! d2Vxc+/drho-_drho-
5491 6260050 : d2vxc(:,4)=(vxce1_ep(:)+vxce2_ep(:)-two*vxcei(:))*rhoinv_ep(:)**2 ! d2Vxc-/drho-_drho-
5492 6970 : else if (calctype==2) then
5493 9475190 : d2vxc(:,1)=(vxce1 (:)+vxce2 (:)-two*vxcei(:))*rhoinv (:)**2 ! d2Vxc-/drho-_drho-
5494 9475190 : d2vxc(:,2)=(vxcp1 (:)+vxcp2 (:)-two*vxcpi(:))*rhoinv (:)**2 ! d2Vxc+/drho-_drho-
5495 9475190 : d2vxc(:,3)=(vxce1_ep(:)+vxce2_ep(:)-two*vxcei(:))*rhoinv_ep(:)**2 ! d2Vxc-/drho+_drho+
5496 9475190 : d2vxc(:,4)=(vxcp1_ep(:)+vxcp2_ep(:)-two*vxcpi(:))*rhoinv_ep(:)**2 ! d2Vxc+/drho+_drho+
5497 : end if
5498 : end if ! option
5499 :
5500 11752 : LIBPAW_DEALLOCATE(rhoinv)
5501 11752 : LIBPAW_DEALLOCATE(rhoinv_ep)
5502 11752 : LIBPAW_DEALLOCATE(vxce1)
5503 11752 : LIBPAW_DEALLOCATE(vxcp1)
5504 11752 : LIBPAW_DEALLOCATE(vxce2)
5505 11752 : LIBPAW_DEALLOCATE(vxcp2)
5506 11752 : LIBPAW_DEALLOCATE(vxce1_ep)
5507 11752 : LIBPAW_DEALLOCATE(vxcp1_ep)
5508 11752 : LIBPAW_DEALLOCATE(vxce2_ep)
5509 11752 : LIBPAW_DEALLOCATE(vxcp2_ep)
5510 :
5511 : end if ! option/=4
5512 :
5513 11752 : LIBPAW_DEALLOCATE(rhosph)
5514 11752 : LIBPAW_DEALLOCATE(rhosph_ep)
5515 :
5516 : !----------------------------------------------------------------------
5517 : !----- Compute useful sums of densities
5518 : !----------------------------------------------------------------------
5519 :
5520 : if (option<3.or.option/=1) then
5521 :
5522 : ! Compute V1SUM1(r)=Sum_L{n^el_L(r)^2}
5523 : ! V1SUM2(r)=Sum_L{n^el_L(r)*n^pos_L(r)}
5524 : ! V1SUM3(r)=Sum_L{n^pos_L(r)^2}
5525 : ! V2SUM1(r,L)=Sum_L1_L2{n^el_L1(r)*n^el_L2(r)*Gaunt_(L,L1,L2)}
5526 : ! V2SUM2(r,L)=Sum_L1_L2{n^el_L1(r)*n^pos_L2(r)*Gaunt_(L,L1,L2)}
5527 : ! V2SUM3(r,L)=Sum_L1_L2{n^pos_L1(r)*n^pos_L2(r)*Gaunt_(L,L1,L2)}
5528 11752 : if (pawxcdev>=1) then
5529 35256 : LIBPAW_ALLOCATE(v1sum,(nrad,3))
5530 : else
5531 0 : LIBPAW_ALLOCATE(v1sum,(0,0))
5532 : end if
5533 11752 : if (pawxcdev>=2) then
5534 0 : LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,3))
5535 : else
5536 11752 : LIBPAW_ALLOCATE(v2sum,(0,0,0))
5537 : end if
5538 11752 : call pawxcsum(1,1,1,lmselect,lmselect_ep,lm_size,nrad,3,pawxcdev,pawang,rhotot,rhotot_ep,v1sum,v2sum)
5539 :
5540 : end if !option
5541 :
5542 : !----------------------------------------------------------------------
5543 : !----- Accumulate and store XC potential
5544 : !----------------------------------------------------------------------
5545 :
5546 11752 : if (option<3) then
5547 :
5548 : ! if (option==0.or.option==2) allocate(vxc_ep(nrad,lm_size))
5549 :
5550 : ! === First order development
5551 : ! ---------------------------
5552 11752 : if (pawxcdev>=1) then
5553 6267020 : if (calctype==1) vxc(:,1,1)=vxcpi(:)*sqfpi
5554 9479972 : if (calctype==2) vxc(:,1,1)=vxcei(:)*sqfpi
5555 : vxc(:,1,1)=vxc(:,1,1)+invsqfpi*(d2vxc(:,2)*v1sum(:,2) &
5556 15735240 : & +half*(d2vxc(:,1)*v1sum(:,1)+d2vxc(:,3)*v1sum(:,3)))
5557 105768 : do ilm=2,lm_size
5558 84912996 : if (lmselect(ilm)) vxc(:,ilm,1)=vxc(:,ilm,1)+d1vxc(:,1)*rhotot (:,ilm)
5559 83581456 : if (lmselect_ep(ilm)) vxc(:,ilm,1)=vxc(:,ilm,1)+d1vxc(:,2)*rhotot_ep(:,ilm)
5560 : end do
5561 : ! if (option==0.or.option==2) then
5562 : ! if (calctype==1) vxc_ep(:,1)=vxcei(:)*sqfpi
5563 : ! if (calctype==2) vxc_ep(:,1)=vxcpi(:)*sqfpi
5564 : ! vxc_ep(:,1)=vxc_ep(:,1,1)+invsqfpi*(d2vxc(:,3)*v1sum(:,2) &
5565 : ! & +half*(d2vxc(:,2)*v1sum(:,1)+d2vxc(:,4)*v1sum(:,3)))
5566 : ! do ilm=2,lm_size
5567 : ! if (lmselect(ilm)) vxc_ep(:,ilm)=vxc_ep(:,ilm)+d1vxc(:,2)*rhotot (:,ilm)
5568 : ! if (lmselect_ep(ilm)) vxc_ep(:,ilm)=vxc_ep(:,ilm)+d1vxc(:,3)*rhotot_ep(:,ilm)
5569 : ! end do
5570 : ! end if
5571 : end if ! pawxcdev>=1
5572 :
5573 : ! == 2nd order development
5574 : ! ---------------------------
5575 11752 : if (pawxcdev>=2) then
5576 0 : do ilm=2,lm_size
5577 : vxc(:,ilm,1)=vxc(:,ilm,1)+d2vxc(:,2)*v2sum(:,ilm,2) &
5578 0 : & +half*(d2vxc(:,1)*v2sum(:,ilm,1)+d2vxc(:,3)*v2sum(:,ilm,3))
5579 : end do
5580 : ! if (option==0.or.option==2) then
5581 : ! do ilm=2,lm_size
5582 : ! vxc_ep(:,ilm)=vxc_ep(:,ilm)+d2vxc(:,3)*v2sum(:,ilm,2) &
5583 : ! & +half*(d2vxc(:,2)*v2sum(:,ilm,1)+d2vxc(:,4)*v2sum(:,ilm,3))
5584 : ! end do
5585 : ! end if
5586 : end if !pawxcdev=2
5587 :
5588 : ! === Pathological case: if rho(r) is negative, interpolate Vxc
5589 : ! -------------------------------------------------------------
5590 11752 : if (lmselect(1)) then
5591 11752 : rhomin=xc_denpos*(one+tol6)
5592 11752 : ir1=0;ir2=0
5593 15735240 : do ir=1,nrad
5594 15735240 : if (rhotot(ir,1)<rhomin) then
5595 222137 : if (ir1==0) ir1=ir-1
5596 222137 : ir2=ir+1
5597 15501351 : else if (ir1>0) then
5598 680 : if (ir1>1.or.ir2<nrad) then
5599 680 : fact=(vxc(ir2,1,1)-vxc(ir1,1,1))/(pawrad%rad(ir2)-pawrad%rad(ir1))
5600 51508 : do jr=ir1+1,ir2-1
5601 51508 : vxc(jr,1,1)=vxc(ir1,1,1)+fact*(pawrad%rad(jr)-pawrad%rad(ir1))
5602 : end do
5603 : end if
5604 : ir1=0;ir2=0
5605 : end if
5606 : end do
5607 : end if
5608 : ! if (option==0.or.option==2) then
5609 : ! if (lmselect_ep(1)) then
5610 : ! ir1=0;ir2=0
5611 : ! do ir=1,nrad
5612 : ! if (rhotot_ep(ir,1)<rho_min) then
5613 : ! if (ir1==0) ir1=ir-1
5614 : ! ir2=ir+1
5615 : ! else if (ir1>0) then
5616 : ! if (ir1>1.or.ir2<nrad) then
5617 : ! fact=(vxc_ep(ir2,1)-vxc_ep(ir1,1))/(pawrad%rad(ir2)-pawrad%rad(ir1))
5618 : ! do jr=ir1+1,ir2-1
5619 : ! vxc_ep(jr,1)=vxc_ep(ir1,1)+fact*(pawrad%rad(jr)-pawrad%rad(ir1))
5620 : ! end do
5621 : ! end if
5622 : ! ir1=0;ir2=0
5623 : ! end if
5624 : ! end do
5625 : ! end if
5626 : ! end if
5627 :
5628 : ! When vxc is dimensionned as polarized...
5629 11752 : if (nspden>=2) vxc(:,:,2)=vxc(:,:,1)
5630 11752 : if (nspden==4) vxc(:,:,3:4)=zero
5631 :
5632 : end if !option<3
5633 :
5634 11752 : LIBPAW_DEALLOCATE(vxcei)
5635 11752 : LIBPAW_DEALLOCATE(vxcpi)
5636 :
5637 : !----------------------------------------------------------------------
5638 : !----- Accumulate and store XC energies
5639 : !----------------------------------------------------------------------
5640 :
5641 : !----- Calculate Exc (direct scheme) term
5642 : !----------------------------------------
5643 :
5644 11752 : if (option/=1) then
5645 23504 : LIBPAW_ALLOCATE(ff,(nrad))
5646 :
5647 : ! Contribution from spherical part of rho
5648 15735240 : ff(:)=fxci(:)*four_pi
5649 :
5650 : ! Contribution from aspherical part of rho
5651 11752 : if (option/=4) then
5652 :
5653 : ! First order development
5654 11752 : if (pawxcdev>=1) then
5655 : ff(:)=ff(:)+v1sum(:,2)*d1vxc(:,2) &
5656 15735240 : & +half*(v1sum(:,1)*d1vxc(:,1)+v1sum(:,3)*d1vxc(:,3))
5657 : end if
5658 :
5659 : ! Second order development
5660 11752 : if (pawxcdev>=2) then
5661 0 : LIBPAW_ALLOCATE(gg,(nrad))
5662 0 : gg=zero
5663 0 : do ilm=2,lm_size
5664 0 : if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,1)*rhotot(:,ilm)
5665 : end do
5666 0 : ff(:)=ff(:)+gg(:)*d2vxc(:,1)/6._dp
5667 0 : gg=zero
5668 0 : do ilm=2,lm_size
5669 0 : if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,2)*rhotot(:,ilm)
5670 : end do
5671 0 : ff(:)=ff(:) +half*gg(:)*d2vxc(:,2)
5672 0 : gg=zero
5673 0 : do ilm=2,lm_size
5674 0 : if (lmselect(ilm)) gg(:)=gg(:)+v2sum(:,ilm,3)*rhotot(:,ilm)
5675 : end do
5676 0 : ff(:)=ff(:) +half*gg(:)*d2vxc(:,3)
5677 0 : gg=zero
5678 0 : do ilm=2,lm_size
5679 0 : if (lmselect_ep(ilm)) gg(:)=gg(:)+v2sum(:,ilm,3)*rhotot_ep(:,ilm)
5680 : end do
5681 0 : ff(:)=ff(:)+gg(:)*d2vxc(:,4)/6._dp
5682 0 : LIBPAW_DEALLOCATE(gg)
5683 : end if ! pawxcdev>=2
5684 :
5685 : end if ! option/=4
5686 :
5687 15735240 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5688 11752 : call simp_gen(enxc,ff,pawrad)
5689 11752 : LIBPAW_DEALLOCATE(ff)
5690 : end if ! option/=1
5691 :
5692 11752 : LIBPAW_DEALLOCATE(fxci)
5693 : if (option<3.or.option/=1) then
5694 11752 : LIBPAW_DEALLOCATE(v1sum)
5695 11752 : LIBPAW_DEALLOCATE(v2sum)
5696 : end if
5697 11752 : if (option<3.or.(option/=4.and.pawxcdev>1)) then
5698 11752 : LIBPAW_DEALLOCATE(d2vxc)
5699 : end if
5700 11752 : if (option/=4) then
5701 11752 : LIBPAW_DEALLOCATE(d1vxc)
5702 : end if
5703 :
5704 : !----- Calculate Excdc double counting term
5705 : !------------------------------------------
5706 11752 : if (option==0.or.option==2) then
5707 :
5708 : ! Build appropriate density
5709 11752 : if (usexcnhat==1) rhotot(:,:)=rhotot(:,:)+nhat(:,:,1)
5710 9479972 : if (usecore==1.and.calctype==2) rhotot(:,1)=rhotot(:,1)-sqfpi*corexc(:)
5711 :
5712 : ! Integrate with potential
5713 23504 : LIBPAW_ALLOCATE(ff,(nrad))
5714 15735240 : ff(:)=zero
5715 117520 : do ilm=1,lm_size
5716 100659988 : if (lmselect(ilm)) ff(:)=ff(:)+vxc(:,ilm,1)*rhotot(:,ilm)
5717 : end do
5718 15735240 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5719 11752 : call simp_gen(enxcdc,ff,pawrad)
5720 11752 : LIBPAW_DEALLOCATE(ff)
5721 : end if ! option
5722 :
5723 11752 : LIBPAW_DEALLOCATE(rhotot)
5724 11752 : LIBPAW_DEALLOCATE(rhotot_ep)
5725 :
5726 11752 : end subroutine pawxcmpositron
5727 : !!***
5728 :
5729 : !----------------------------------------------------------------------
5730 :
5731 : !!****f* m_pawxc/pawxc_get_nkxc
5732 : !! NAME
5733 : !! pawxc_get_nkxc
5734 : !!
5735 : !! FUNCTION
5736 : !! Get size of XC kernel array (Kxc) according to spin polarization and XC type
5737 : !!
5738 : !! INPUTS
5739 : !! nspden= nmber of density spin components
5740 : !! xclevel= XC type
5741 : !!
5742 : !! OUTPUT
5743 : !! nkxc= size of XC kernel (kxc array)
5744 : !!
5745 : !! NOTES
5746 : !! Content of Kxc array:
5747 : !! ===== if LDA
5748 : !! if nspden==1: kxc(:,1)= d2Exc/drho2
5749 : !! (kxc(:,2)= d2Exc/drho_up drho_dn)
5750 : !! if nspden>=2: kxc(:,1)= d2Exc/drho_up drho_up
5751 : !! kxc(:,2)= d2Exc/drho_up drho_dn
5752 : !! kxc(:,3)= d2Exc/drho_dn drho_dn
5753 : !! if nspden==4: kxc(:,4:6)= (m_x, m_y, m_z) (magnetization)
5754 : !! ===== if GGA
5755 : !! if nspden==1:
5756 : !! kxc(:,1)= d2Exc/drho2
5757 : !! kxc(:,2)= 1/|grad(rho)| dExc/d|grad(rho)|
5758 : !! kxc(:,3)= 1/|grad(rho)| d2Exc/d|grad(rho)| drho
5759 : !! kxc(:,4)= 1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dExc/d|grad(rho)| )
5760 : !! kxc(:,5)= gradx(rho)
5761 : !! kxc(:,6)= grady(rho)
5762 : !! kxc(:,7)= gradz(rho)
5763 : !! if nspden>=2:
5764 : !! kxc(:,1)= d2Exc/drho_up drho_up
5765 : !! kxc(:,2)= d2Exc/drho_up drho_dn
5766 : !! kxc(:,3)= d2Exc/drho_dn drho_dn
5767 : !! kxc(:,4)= 1/|grad(rho_up)| dEx/d|grad(rho_up)|
5768 : !! kxc(:,5)= 1/|grad(rho_dn)| dEx/d|grad(rho_dn)|
5769 : !! kxc(:,6)= 1/|grad(rho_up)| d2Ex/d|grad(rho_up)| drho_up
5770 : !! kxc(:,7)= 1/|grad(rho_dn)| d2Ex/d|grad(rho_dn)| drho_dn
5771 : !! kxc(:,8)= 1/|grad(rho_up)| * d/d|grad(rho_up)| ( 1/|grad(rho_up)| dEx/d|grad(rho_up)| )
5772 : !! kxc(:,9)= 1/|grad(rho_dn)| * d/d|grad(rho_dn)| ( 1/|grad(rho_dn)| dEx/d|grad(rho_dn)| )
5773 : !! kxc(:,10)=1/|grad(rho)| dEc/d|grad(rho)|
5774 : !! kxc(:,11)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_up
5775 : !! kxc(:,12)=1/|grad(rho)| d2Ec/d|grad(rho)| drho_dn
5776 : !! kxc(:,13)=1/|grad(rho)| * d/d|grad(rho)| ( 1/|grad(rho)| dEc/d|grad(rho)| )
5777 : !! kxc(:,14)=gradx(rho_up)
5778 : !! kxc(:,15)=gradx(rho_dn)
5779 : !! kxc(:,16)=grady(rho_up)
5780 : !! kxc(:,17)=grady(rho_dn)
5781 : !! kxc(:,18)=gradz(rho_up)
5782 : !! kxc(:,19)=gradz(rho_dn)
5783 : !! if nspden==4:
5784 : !! kxc(:,20:22)= (m_x, m_y, m_z) (magnetization)
5785 : !!
5786 : !! SOURCE
5787 :
5788 23717 : subroutine pawxc_get_nkxc(nkxc,nspden,xclevel)
5789 :
5790 : !Arguments ------------------------------------
5791 : !scalars
5792 : integer,intent(in) :: nspden,xclevel
5793 : integer,intent(out) :: nkxc
5794 : !arrays
5795 :
5796 : !Local variables-------------------------------
5797 : !scalars
5798 : !arrays
5799 :
5800 : !************************************************************************
5801 :
5802 23717 : nkxc=0
5803 :
5804 23717 : if (nspden==1) then ! Non polarized
5805 :
5806 19367 : if (xclevel==1) nkxc=1
5807 19367 : if (xclevel==2) nkxc=7
5808 :
5809 4350 : else if (nspden==2) then ! Polarized
5810 :
5811 4350 : if (xclevel==1) nkxc=3
5812 4350 : if (xclevel==2) nkxc=19
5813 :
5814 0 : else if (nspden==4) then ! Non-collinear
5815 :
5816 : ! Store magnetization in the 3 last terms of Kxc
5817 0 : if (xclevel==1) nkxc=6
5818 0 : if (xclevel==2) nkxc=22
5819 :
5820 : end if
5821 :
5822 23717 : end subroutine pawxc_get_nkxc
5823 : !!***
5824 :
5825 : !----------------------------------------------------------------------
5826 :
5827 : !!****f* m_pawxc/pawxc_drivexc_wrapper
5828 : !! NAME
5829 : !! pawxc_drivexc_wrapper
5830 : !!
5831 : !! FUNCTION
5832 : !! PAW only
5833 : !! Wrapper for drivexc routines
5834 : !!
5835 : !! NOTES
5836 : !! PENDING. Need to manage properly optional arguments:
5837 : !! Check that these are present before calling drivexc
5838 : !! Probably use better interfaces of fortran 2003 to avoid
5839 : !! numerous if/then sentences.
5840 : !!
5841 : !! SOURCE
5842 :
5843 527869 : subroutine pawxc_drivexc_wrapper(hyb_mixing,ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
5844 527869 : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, & ! mandatory arguments
5845 : & grho2,vxcgrho,lrho,vxclrho,tau,vxctau,dvxc,d2vxc, & ! optional arguments
5846 : & exexch) ! optional arguments
5847 :
5848 : !Arguments ------------------------------------
5849 : !scalars
5850 : integer,intent(in) :: ixc,ndvxc,nd2vxc,npts,nspden,nvxcgrho,nvxclrho,nvxctau,order
5851 : integer,intent(in) :: usegradient,uselaplacian,usekden
5852 : real(dp),intent(in) :: el_temp,hyb_mixing
5853 : integer,intent(in),optional :: exexch
5854 : !arrays
5855 : real(dp),intent(in) :: rho(npts,nspden)
5856 : real(dp),intent(out) :: exc(npts),tsxc(npts),vxcrho(npts,nspden)
5857 : real(dp),intent(in),optional :: grho2(npts,(2*nspden-1)*usegradient)
5858 : real(dp),intent(in),optional :: lrho(npts,nspden*uselaplacian)
5859 : real(dp),intent(in),optional :: tau(npts,nspden*usekden)
5860 : real(dp),intent(out),optional:: dvxc(npts,ndvxc),d2vxc(npts,nd2vxc)
5861 : real(dp),intent(out),optional:: vxcgrho(npts,nvxcgrho),vxclrho(npts,nvxclrho),vxctau(npts,nvxctau)
5862 :
5863 : !Local variables-------------------------------
5864 : character(len=100) :: msg
5865 :
5866 : ! *************************************************************************
5867 :
5868 :
5869 : !One could add here a section for other codes (i.e. BigDFT, ...)
5870 : #if defined HAVE_LIBPAW_ABINIT
5871 527869 : call pawxc_drivexc_abinit()
5872 : #elif defined LIBPAW_HAVE_LIBXC
5873 : call pawxc_drivexc_libxc()
5874 : #else
5875 : write(msg,'(5a)') 'libPAW XC driving routine only implemented in the following cases:',ch10, &
5876 : & ' - ABINIT',ch10,' - libXC'
5877 : LIBPAW_BUG(msg)
5878 : #endif
5879 :
5880 : if (.false.) write(std_out,*) el_temp
5881 : !!***
5882 :
5883 : contains
5884 : !!***
5885 :
5886 : #if defined HAVE_LIBPAW_ABINIT
5887 : !!****f* m_pawxc/pawxc_drivexc_abinit
5888 : !! NAME
5889 : !! pawxc_drivexc_abinit
5890 : !!
5891 : !! FUNCTION
5892 : !! ABINIT version of XC driving routine
5893 : !!
5894 : !! SOURCE
5895 :
5896 527869 : subroutine pawxc_drivexc_abinit()
5897 :
5898 : logical :: test_args
5899 :
5900 : ! *************************************************************************
5901 :
5902 527869 : test_args=present(dvxc)
5903 527869 : if (nd2vxc>0) test_args=(test_args.and.present(d2vxc))
5904 527869 : if (usegradient==1) test_args=(test_args.and.present(grho2).and.present(vxcgrho))
5905 527869 : if (uselaplacian==1) test_args=(test_args.and.present(lrho).and.present(vxclrho))
5906 527869 : if (usekden==1) test_args=(test_args.and.present(tau).and.present(vxctau))
5907 376847 : if (.not.test_args) then
5908 0 : msg='missing mandatory arguments in pawxc_drivexc_wrapper'
5909 0 : LIBPAW_BUG(msg)
5910 : end if
5911 :
5912 527869 : if (uselaplacian==1.or.usekden==1) then
5913 151022 : if (uselaplacian==1.and.usekden==1) then
5914 : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
5915 : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
5916 : & grho2_updn=grho2,vxcgrho=vxcgrho,&
5917 : & lrho_updn=lrho,vxclrho=vxclrho,&
5918 : & tau_updn=tau,vxctau=vxctau,&
5919 34946 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
5920 116076 : else if (uselaplacian==1) then
5921 : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
5922 : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
5923 : & grho2_updn=grho2,vxcgrho=vxcgrho,&
5924 : & lrho_updn=lrho,vxclrho=vxclrho,&
5925 0 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
5926 116076 : else if (usekden==1) then
5927 : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
5928 : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
5929 : & grho2_updn=grho2,vxcgrho=vxcgrho,&
5930 : & tau_updn=tau,vxctau=vxctau,&
5931 116076 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
5932 : end if
5933 376847 : else if (usegradient==1) then
5934 109802 : if (present(exexch)) then
5935 : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
5936 : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
5937 : & grho2_updn=grho2,vxcgrho=vxcgrho,&
5938 : & dvxc=dvxc,d2vxc=d2vxc,&
5939 71151 : & exexch=exexch,hyb_mixing=hyb_mixing)
5940 : else
5941 : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
5942 : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
5943 : & grho2_updn=grho2,vxcgrho=vxcgrho,&
5944 38651 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
5945 : end if
5946 : else
5947 : call drivexc(ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
5948 : & rho,exc,tsxc,vxcrho,nvxcgrho,nvxclrho,nvxctau,ndvxc,nd2vxc,el_temp, &
5949 267045 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
5950 : end if
5951 :
5952 527869 : end subroutine pawxc_drivexc_abinit
5953 : !!***
5954 : #endif
5955 :
5956 : #if defined LIBPAW_HAVE_LIBXC
5957 : !!****f* m_pawxc/pawxc_drivexc_libxc
5958 : !! NAME
5959 : !! pawxc_drivexc_libxc
5960 : !!
5961 : !! FUNCTION
5962 : !! LibXC version of XC driving routine
5963 : !!
5964 : !! SOURCE
5965 :
5966 : subroutine pawxc_drivexc_libxc()
5967 :
5968 : ! *************************************************************************
5969 :
5970 : !Check the compatibility of input arguments
5971 : if (ixc>=0) then
5972 : msg='ixc argument should be negative!'
5973 : LIBPAW_BUG(msg)
5974 : end if
5975 : if (ixc/=libxc_functionals_ixc()) then
5976 : msg='The value of ixc differs from the one used to initialize the functional!'
5977 : LIBPAW_BUG(msg)
5978 : end if
5979 : if ((order<1.and.order/=-2).or.order>4) then
5980 : msg='The only allowed values for order are 1, 2, -2, or 3!'
5981 : LIBPAW_BUG(msg)
5982 : end if
5983 : if ((order**2>1).and.(.not.present(dvxc))) then
5984 : msg='The value of order is not compatible with the presence of the array dvxc!'
5985 : LIBPAW_BUG(msg)
5986 : end if
5987 : if ((order==3).and.(.not.present(d2vxc))) then
5988 : msg='The value of order is not compatible with the presence of the array d2vxc!'
5989 : LIBPAW_BUG(msg)
5990 : end if
5991 : if (libxc_functionals_isgga().or.libxc_functionals_ismgga()) then
5992 : if ((.not.present(grho2)).or.(.not.present(vxcgrho)).or.&
5993 : & (usegradient==0).or.(nvxcgrho==0)) then
5994 : write(msg,'(3a)') 'At least one of the functionals is a GGA,',ch10, &
5995 : & 'but not all the necessary optional arguments are present.'
5996 : LIBPAW_BUG(msg)
5997 : end if
5998 : if (libxc_functionals_needs_laplacian()) then
5999 : if ((.not.present(lrho)).or.(.not.present(vxclrho)).or.&
6000 : & (uselaplacian==0).or.(nvxclrho==0)) then
6001 : write(msg,'(3a)') 'At least one of the functionals is a mGGA,',ch10, &
6002 : & 'but not all the necessary optional arguments are present.'
6003 : LIBPAW_BUG(msg)
6004 : end if
6005 : end if
6006 : if (libxc_functionals_ismgga()) then
6007 : if ((.not.present(tau)).or.(.not.present(vxctau)).or.&
6008 : & (usekden==0).or.(nvxctau==0)) then
6009 : write(msg,'(3a)') 'At least one of the functionals is a mGGA,',ch10, &
6010 : & 'but not all the necessary optional arguments are present.'
6011 : LIBPAW_BUG(msg)
6012 : end if
6013 : end if
6014 : end if
6015 : if ((uselaplacian==1.or.usekden==1).and.(usegradient==0)) then
6016 : msg='Laplacian or kinetic energy density needs gradient!'
6017 : LIBPAW_BUG(msg)
6018 : end if
6019 :
6020 : !Call LibXC routines
6021 : if (uselaplacian==1.or.usekden==1) then ! meta-GGA
6022 : if (uselaplacian==1.and.usekden==1) then
6023 : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6024 : & grho2=grho2,vxcgr=vxcgrho,lrho=lrho,vxclrho=vxclrho,tau=tau,vxctau=vxctau)
6025 : else if (uselaplacian==1) then
6026 : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6027 : & grho2=grho2,vxcgr=vxcgrho,lrho=lrho,vxclrho=vxclrho)
6028 : else if (usekden==1) then
6029 : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6030 : & grho2=grho2,vxcgr=vxcgrho,tau=tau,vxctau=vxctau)
6031 : end if
6032 : else if (usegradient==1) then ! GGA
6033 : if (abs(order)<=1) then
6034 : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6035 : & grho2=grho2,vxcgr=vxcgrho)
6036 : else
6037 : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6038 : & grho2=grho2,vxcgr=vxcgrho,dvxc=dvxc)
6039 : end if
6040 : else ! LDA
6041 : if (abs(order)<=1) then
6042 : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho)
6043 : else if (abs(order)<=2) then
6044 : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6045 : & dvxc=dvxc)
6046 : else
6047 : call libxc_functionals_getvxc(ndvxc,nd2vxc,npts,nspden,order,rho,exc,vxcrho,&
6048 : & d2vxc=d2vxc)
6049 : end if
6050 : end if
6051 :
6052 : end subroutine pawxc_drivexc_libxc
6053 : !!***
6054 : #endif
6055 :
6056 : end subroutine pawxc_drivexc_wrapper
6057 : !!***
6058 :
6059 : !----------------------------------------------------------------------
6060 :
6061 : !!****f* m_pawxc/pawxc_rotate_mag
6062 : !! NAME
6063 : !! pawxc_rotate_mag
6064 : !!
6065 : !! FUNCTION
6066 : !! Project (rotate) a non-collinear density (stored as density+magn.)
6067 : !! on a magnetization and give a collinear density (stored as [up,dn] or [up+dn,up]).
6068 : !!
6069 : !! INPUTS
6070 : !! rho_in(vectsize,4)=input non-collinear density and magnetization
6071 : !! mag(vectsize,3)=magnetization used for projection
6072 : !! vectsize=size of vector fields
6073 : !! [rho_out_format]= 1=rho_out is stored as [up,dn]
6074 : !! 2=rho_out is stored as [up+dn,up]
6075 : !! Default=1
6076 : !!
6077 : !! OUTPUT
6078 : !! rho_out(vectsize,2)=output (projected, collinear) density
6079 : !! [mag_norm_out(vectsize)]= --optional-- norm of mag(:) at each point of the grid
6080 : !! SOURCE
6081 :
6082 33686 : subroutine pawxc_rotate_mag(rho_in,rho_out,mag,vectsize,mag_norm_out,rho_out_format)
6083 :
6084 : !Arguments ------------------------------------
6085 : !scalars
6086 : integer,intent(in) :: vectsize
6087 : integer,intent(in),optional :: rho_out_format
6088 : !arrays
6089 : real(dp),intent(in) :: rho_in(vectsize,4),mag(vectsize,3)
6090 : real(dp),intent(out) :: rho_out(vectsize,2)
6091 : real(dp),intent(out),optional :: mag_norm_out(vectsize)
6092 :
6093 : !Local variables-------------------------------
6094 : !scalars
6095 : #if ! defined HAVE_LIBPAW_ABINIT
6096 : integer :: ipt
6097 : real(dp),parameter :: m_norm_min=tol8
6098 : real(dp) :: m_norm,rhoin_dot_mag,rho_up
6099 : #endif
6100 : !arrays
6101 :
6102 : ! *************************************************************************
6103 :
6104 : !One could add here a section for other codes (i.e. BigDFT, ...)
6105 : #if defined HAVE_LIBPAW_ABINIT
6106 33686 : if (present(rho_out_format).and.present(mag_norm_out)) then
6107 : call rotate_mag(rho_in,rho_out,mag,vectsize,1, &
6108 0 : & rho_out_format=rho_out_format,mag_norm_out=mag_norm_out)
6109 33686 : else if (present(rho_out_format).and..not.present(mag_norm_out)) then
6110 0 : call rotate_mag(rho_in,rho_out,mag,vectsize,1,rho_out_format=rho_out_format)
6111 33686 : else if (.not.present(rho_out_format).and.present(mag_norm_out)) then
6112 2798 : call rotate_mag(rho_in,rho_out,mag,vectsize,1,mag_norm_out=mag_norm_out)
6113 : else
6114 30888 : call rotate_mag(rho_in,rho_out,mag,vectsize,1)
6115 : end if
6116 : #else
6117 : do ipt=1,vectsize
6118 : m_norm=sqrt(mag(ipt,1)**2+mag(ipt,2)**2+mag(ipt,3)**2)
6119 : rhoin_dot_mag=rho_in(ipt,2)*mag(ipt,1)+rho_in(ipt,3)*mag(ipt,2) &
6120 : & +rho_in(ipt,4)*mag(ipt,3)
6121 : if(m_norm>m_norm_min)then
6122 : rho_out(ipt,1)=half*(rho_in(ipt,1)+rhoin_dot_mag/m_norm)
6123 : rho_out(ipt,2)=half*(rho_in(ipt,1)-rhoin_dot_mag/m_norm)
6124 : else
6125 : rho_out(ipt,1)=half*rho_in(ipt,1)
6126 : rho_out(ipt,2)=half*rho_in(ipt,1)
6127 : end if
6128 : if (present(mag_norm_out).and.m_norm> m_norm_min) mag_norm_out(ipt)=m_norm
6129 : if (present(mag_norm_out).and.m_norm<=m_norm_min) mag_norm_out(ipt)=zero
6130 : end do
6131 : if (present(rho_out_format)) then
6132 : if (rho_out_format==2) then
6133 : do ipt=1,vectsize
6134 : rho_up=rho_out(ipt,1)
6135 : rho_out(ipt,1)=rho_up+rho_out(ipt,2)
6136 : rho_out(ipt,2)=rho_up
6137 : end do
6138 : end if
6139 : end if
6140 : #endif
6141 :
6142 33686 : end subroutine pawxc_rotate_mag
6143 : !!***
6144 :
6145 : !----------------------------------------------------------------------
6146 :
6147 : !!****f* m_pawxc/pawxc_rotate_back_mag
6148 : !! NAME
6149 : !! pawxc_rotate_back_mag
6150 : !!
6151 : !! FUNCTION
6152 : !! Rotate back a collinear XC potential (stored as up+dn) with respect to
6153 : !! a magnetization and give a non-collinear XC potential
6154 : !! (stored as up_up, dn_dn, Re{up_dn}, Im{up_dn}).
6155 : !!
6156 : !! INPUTS
6157 : !! vxc_in(vectsize,2)=input collinear XC potential
6158 : !! mag(vectsize,3)=magnetization used for projection
6159 : !! vectsize=size of vector fields
6160 : !!
6161 : !! OUTPUT
6162 : !! vxc_out(vectsize,4)=output non-collinear XC potential
6163 : !!
6164 : !! SOURCE
6165 :
6166 71540 : subroutine pawxc_rotate_back_mag(vxc_in,vxc_out,mag,vectsize)
6167 :
6168 : !Arguments ------------------------------------
6169 : !scalars
6170 : integer,intent(in) :: vectsize
6171 : !arrays
6172 : real(dp),intent(in) :: vxc_in(vectsize,2),mag(vectsize,3)
6173 : real(dp),intent(out) :: vxc_out(vectsize,4)
6174 :
6175 : !Local variables-------------------------------
6176 : !scalars
6177 : #if ! defined HAVE_LIBPAW_ABINIT
6178 : integer :: ipt
6179 : real(dp),parameter :: m_norm_min=tol8
6180 : real(dp) :: dvdn,dvdz,m_norm
6181 : #endif
6182 : !arrays
6183 :
6184 : ! *************************************************************************
6185 :
6186 : !One could add here a section for other codes (i.e. BigDFT, ...)
6187 : #if defined HAVE_LIBPAW_ABINIT
6188 71540 : call rotate_back_mag(vxc_in,vxc_out,mag,vectsize)
6189 : #else
6190 : do ipt=1,vectsize
6191 : m_norm=sqrt(mag(ipt,1)**2+mag(ipt,2)**2+mag(ipt,3)**2)
6192 : dvdn=half*(vxc_in(ipt,1)+vxc_in(ipt,2))
6193 : if (m_norm>m_norm_min) then
6194 : dvdz=half*(vxc_in(ipt,1)-vxc_in(ipt,2))/m_norm
6195 : vxc_out(ipt,1)=dvdn+mag(ipt,3)*dvdz
6196 : vxc_out(ipt,2)=dvdn-mag(ipt,3)*dvdz
6197 : vxc_out(ipt,3)= mag(ipt,1)*dvdz
6198 : vxc_out(ipt,4)=-mag(ipt,2)*dvdz
6199 : else
6200 : vxc_out(ipt,1:2)=dvdn
6201 : vxc_out(ipt,3:4)=zero
6202 : end if
6203 : end do
6204 : #endif
6205 :
6206 : end subroutine pawxc_rotate_back_mag
6207 : !!***
6208 :
6209 : !----------------------------------------------------------------------
6210 :
6211 : !!****f* m_pawxc/pawxc_rotate_back_mag_dfpt
6212 : !! NAME
6213 : !! pawxc_rotate_back_mag_dfpt
6214 : !!
6215 : !! FUNCTION
6216 : !! Rotate back a 1st-order collinear XC potential (stored as up+dn) with respect to
6217 : !! a magnetization and give a 1st-order non-collinear XC potential
6218 : !! (stored as up_up, dn_dn, Re{up_dn}, Im{up_dn}).
6219 : !!
6220 : !! INPUTS
6221 : !! mag(vectsize,3)=0-order magnetization used for projection
6222 : !! rho1(vectsize,4)=1st-order non-collinear density and magnetization
6223 : !! vxc(vectsize,4)=0-order non-collinear XC potential
6224 : !! kxc(vectsize,nkxc)=0-order XC kernel (associated to vxc)
6225 : !! vxc1_in(vectsize,2)=input 1st-order collinear XC potential
6226 : !! vectsize=size of vector fields
6227 : !!
6228 : !! OUTPUT
6229 : !! vxc1_out(vectsize,4)=output 1st-order non-collinear XC potential
6230 : !!
6231 : !! SOURCE
6232 :
6233 0 : subroutine pawxc_rotate_back_mag_dfpt(vxc1_in,vxc1_out,vxc,kxc,rho1,mag,vectsize)
6234 :
6235 : !Arguments ------------------------------------
6236 : !scalars
6237 : integer,intent(in) :: vectsize
6238 : !arrays
6239 : real(dp),intent(in) :: kxc(:,:),mag(vectsize,3),rho1(vectsize,4)
6240 : real(dp),intent(in) :: vxc(vectsize,4),vxc1_in(vectsize,2)
6241 : real(dp),intent(out) :: vxc1_out(vectsize,4)
6242 :
6243 : !Local variables-------------------------------
6244 : !scalars
6245 : #if ! defined HAVE_LIBPAW_ABINIT
6246 : character(len=100) :: msg
6247 : #endif
6248 : !arrays
6249 :
6250 : ! *************************************************************************
6251 :
6252 : !One could add here a section for other codes (i.e. BigDFT, ...)
6253 : #if defined HAVE_LIBPAW_ABINIT
6254 0 : call rotate_back_mag_dfpt(1,vxc1_in,vxc1_out,vxc,kxc,rho1,mag,vectsize,1)
6255 : #else
6256 : msg='[LIBPAW] Non-collinear DFPT not available (only in ABINIT)!'
6257 : LIBPAW_ERROR(msg)
6258 : #endif
6259 :
6260 0 : end subroutine pawxc_rotate_back_mag_dfpt
6261 : !!***
6262 :
6263 : !----------------------------------------------------------------------
6264 :
6265 : end module m_pawxc
6266 : !!***
|
