Branch data 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 : 245164 : 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 : 245164 : & ndvxc=ndvxc_,nd2vxc=nd2vxc_)
270 : : #else
271 : : call pawxc_size_dvxc_local()
272 : : #endif
273 [ + - ]: 245164 : if (present(usegradient)) usegradient=usegradient_
274 [ + + ]: 245164 : if (present(uselaplacian)) uselaplacian=uselaplacian_
275 [ + + ]: 245164 : if (present(usekden)) usekden=usekden_
276 [ + - ]: 245164 : if (present(nvxcgrho)) nvxcgrho=nvxcgrho_
277 [ + + ]: 245164 : if (present(nvxclrho)) nvxclrho=nvxclrho_
278 [ + + ]: 245164 : if (present(nvxctau)) nvxctau=nvxctau_
279 [ + - ]: 245164 : if (present(ndvxc)) ndvxc=ndvxc_
280 [ + + ]: 245164 : 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 : 245164 : 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 : 530788 : 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 : 530788 : 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 : 611 : function pawxc_get_xclevel(ixc)
679 : : !Arguments ------------------------------------
680 : : integer,intent(in) :: ixc
681 : : integer :: pawxc_get_xclevel
682 : :
683 : : ! *************************************************************************
684 : :
685 : 611 : pawxc_get_xclevel=0
686 : :
687 : : !ABINIT
688 [ + + ]: 611 : if ((1<=ixc.and.ixc<=10).or.(30<=ixc.and.ixc<=39).or.(ixc==50)) pawxc_get_xclevel=1 ! ABINIT LDA
689 [ + + - + ]: 611 : if ((11<=ixc.and.ixc<=19).or.(23<=ixc.and.ixc<=29).or.ixc==1402000) pawxc_get_xclevel=2 ! ABINIT GGA
690 [ - + ]: 611 : if (20<=ixc.and.ixc<=22) pawxc_get_xclevel=3 ! ABINIT TDDFT kernel tests
691 [ - + ]: 611 : if (ixc>=31.and.ixc<=35) pawxc_get_xclevel=2 ! ABINIT internal fake mGGA
692 [ + + ]: 611 : if (ixc>=41.and.ixc<=42) pawxc_get_xclevel=2 ! ABINIT internal hybrids using GGA
693 : :
694 : : !LibXC functionals
695 [ + + ]: 611 : if (ixc<0) then
696 : 248 : pawxc_get_xclevel=1
697 [ + + ]: 248 : if (libxc_functionals_isgga()) pawxc_get_xclevel=2
698 [ + + ]: 248 : if (libxc_functionals_ismgga()) pawxc_get_xclevel=2
699 [ + + ]: 248 : if (libxc_functionals_is_hybrid()) pawxc_get_xclevel=2
700 : : end if
701 : :
702 : 611 : 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 : 27846 : function pawxc_get_usekden(ixc)
720 : : !Arguments ------------------------------------
721 : : integer,intent(in) :: ixc
722 : : integer :: pawxc_get_usekden
723 : :
724 : : ! *************************************************************************
725 : :
726 : 27846 : pawxc_get_usekden=0
727 [ + + ]: 27846 : if (ixc<0) then
728 [ + + ]: 10755 : if (libxc_functionals_ismgga()) pawxc_get_usekden=1
729 [ - + ]: 17091 : else if (ixc==31.or.ixc==34.or.ixc==35) then
730 : 648 : pawxc_get_usekden=1
731 : : end if
732 : :
733 : 27846 : 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 : 608 : function pawxc_get_uselaplacian(ixc)
751 : : !Arguments ------------------------------------
752 : : integer,intent(in) :: ixc
753 : : integer :: pawxc_get_uselaplacian
754 : :
755 : : ! *************************************************************************
756 : :
757 : 608 : pawxc_get_uselaplacian=0
758 [ + + ]: 608 : if (ixc<0) then
759 [ + + ]: 246 : if (libxc_functionals_needs_laplacian()) pawxc_get_uselaplacian=1
760 [ - + ]: 362 : else if (ixc==32.or.ixc==35) then
761 : 2 : pawxc_get_uselaplacian=1
762 : : end if
763 : :
764 : 608 : 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 : 243173 : 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 : 243173 : real(dp),allocatable :: dff(:),dnexcdn(:,:),dvxcdgr(:,:),dvxci(:,:)
3024 : 243173 : real(dp),allocatable :: grho2(:,:),grho_updn(:,:)
3025 : :
3026 : : ! *************************************************************************
3027 : :
3028 [ - + ]: 243173 : 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 [ - + ]: 243173 : if(nkxc>3)then
3035 : 0 : msg='nkxc>3 not allowed (GGA)!'
3036 : 0 : LIBPAW_ERROR(msg)
3037 : : end if
3038 [ - + ]: 243173 : 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 [ + + ]: 243173 : order=1;if (nkxc>0) order=2
3045 [ + + ]: 243173 : nspgrad=0;if (xclevel==2) nspgrad=3*nspden-1
3046 : : call pawxc_size_dvxc_wrapper(ixc,order,nspden,&
3047 : 243173 : & usegradient=usegradient,nvxcgrho=nvxcdgr,ndvxc=ndvxc)
3048 : 243173 : 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 [ - + + - : 972692 : LIBPAW_ALLOCATE(grho2,(nrad,(2*nspden-1)*usegradient))
+ + + - +
- + + - +
- + ]
3055 [ + + ]: 243173 : 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 [ - + + - : 300340 : LIBPAW_ALLOCATE(grho_updn,(nrad,nspden))
- + + - +
- + - - +
- + ]
3060 : :
3061 : : ! Gradient of radial part of density
3062 [ - + + - : 225255 : LIBPAW_ALLOCATE(dff,(nrad))
+ - + - -
+ - + ]
3063 [ + + ]: 184256 : do ispden=1,nspden
3064 : 109171 : call nderiv_gen(dff,rho_updn(:,ispden),pawrad)
3065 [ + + ]: 113932657 : grho_updn(:,ispden)=dff(:)
3066 : : end do
3067 [ - + ]: 75085 : LIBPAW_DEALLOCATE(dff)
3068 : :
3069 : : ! Squared norm of the gradient
3070 [ + + ]: 81001233 : grho2(:,1)=grho_updn(:,1)**2
3071 [ + + ]: 75085 : 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 [ - + + - : 972692 : LIBPAW_ALLOCATE(dvxci,(nrad,ndvxc))
+ + + - +
- + + - +
- + ]
3084 [ - + + - : 972692 : 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 : 486346 : & dvxc=dvxci,d2vxc=d2vxc,exexch=exexch)
3091 : :
3092 : : !Transfer the XC kernel
3093 [ + + + - ]: 243173 : if (nkxc>0.and.ndvxc>0) then
3094 [ + + - + ]: 418 : 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 [ + + - + ]: 418 : 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 [ - + - - ]: 418 : 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 [ - + - - ]: 418 : 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 [ - + - - ]: 418 : 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 [ + + + + ]: 299596 : kxc(1:nrad,1:nkxc)=zero
3126 [ + + + + ]: 299596 : kxc(1:nrad,1:min(nkxc,ndvxc))=dvxci(1:nrad,1:min(nkxc,ndvxc))
3127 : : end if
3128 [ - + ]: 418 : 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 [ - + ]: 418 : 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 [ - + ]: 243173 : LIBPAW_DEALLOCATE(dvxci)
3142 : :
3143 : : !--------------------------------------------------------------------------
3144 : : !-------------- GGA: gardient corrections
3145 : : !--------------------------------------------------------------------------
3146 : :
3147 [ + + + - ]: 243173 : 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 [ - + + - : 300340 : LIBPAW_ALLOCATE(dnexcdn,(nrad,nspgrad))
- + + - +
- + - - +
+ - ]
3163 : : ! LDA term
3164 [ + + + + ]: 113932657 : dnexcdn(:,1:nspden)=vxc(:,1:nspden)
3165 : : ! Additional GGA terms
3166 [ + + ]: 81001233 : do ir=1,nrad
3167 [ + + ]: 227571887 : do ispden=1,3 ! spin_up, spin_down and total spin density
3168 [ + + + + ]: 194674549 : 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 [ + + ]: 146570654 : if(grho2(ir,ispden)<tol24) then
3173 : 132736 : 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 [ + - ]: 146437918 : if (nvxcdgr/=0) then
3179 [ + + ]: 146437918 : if (nspden==1) then
3180 : : ! Definition of dvxcdgr changed in v3.3
3181 [ + - ]: 48034456 : if (nvxcdgr==3) then
3182 : 48034456 : 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 : 227364066 : dnexcdn(ir,ispden+nspden)=coeff
3197 : : end do
3198 : : end do
3199 : :
3200 : : ! Calculate grad(rho)*dnexcdn and put it in grho_updn(:,:)
3201 [ + - ]: 75085 : if (nvxcdgr/=0) then
3202 [ + + ]: 75085 : if(nspden==1)then
3203 [ + + ]: 48144894 : 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 [ - + ]: 75085 : LIBPAW_DEALLOCATE(dnexcdn)
3213 : :
3214 : : ! Compute Vxc
3215 [ - + + - : 225255 : LIBPAW_ALLOCATE(dff,(nrad))
+ - + - -
+ - + -
+ ]
3216 [ + + ]: 75085 : fact=one;if (nspden==1) fact=two
3217 [ + + ]: 184256 : do ispden=1,nspden
3218 : 109171 : call nderiv_gen(dff,grho_updn(:,ispden),pawrad)
3219 [ + + ]: 113748401 : vxc(2:nrad,ispden)=vxc(2:nrad,ispden)-fact*(dff(2:nrad)+two*grho_updn(2:nrad,ispden)/pawrad%rad(2:nrad))
3220 : 184256 : call pawrad_deducer0(vxc(:,ispden),nrad,pawrad)
3221 : : end do
3222 [ - + ]: 75085 : LIBPAW_DEALLOCATE(dff)
3223 : :
3224 : : end if ! xclevel==2
3225 : :
3226 : : !--------------------------------------------------------------------------
3227 : : !-------------- Deallocations
3228 : : !--------------------------------------------------------------------------
3229 : :
3230 [ - + ]: 243173 : LIBPAW_DEALLOCATE(grho2)
3231 [ - + ]: 243173 : LIBPAW_DEALLOCATE(dvxcdgr)
3232 [ + + ]: 243173 : if (xclevel==2) then
3233 [ - + ]: 75085 : LIBPAW_DEALLOCATE(grho_updn)
3234 : : end if
3235 : :
3236 [ - + - + ]: 486346 : 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 : 105927 : subroutine pawxcsum(cplex1,cplex2,cplexsum,lmselect1,lmselect2,lm_size,nrad,nsums,&
3697 : 105927 : & 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 [ - + ]: 105927 : 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 [ - + ]: 105927 : if(pawang%gnt_option==0) then
3722 : 0 : msg='pawang%gnt_option=0!'
3723 : 0 : LIBPAW_BUG(msg)
3724 : : end if
3725 : :
3726 [ + - ]: 105927 : if (option>=1) then
3727 : :
3728 : : ! SUM1(r)= Sum_L{Rho1_L(r)*Rho2_L(r)} (L>0)
3729 : : ! --------------------------------------------------
3730 [ + + + + ]: 180673718 : sum1=zero
3731 : :
3732 : : ! ===== All input/output densities are REAL ====
3733 [ + - + + : 105927 : if (cplex1==1.and.cplex2==1.and.cplexsum==1) then
+ - ]
3734 : : ! One sum to compute
3735 [ + + ]: 104535 : if (nsums==1) then
3736 [ + + ]: 683299 : do ilm=2,lm_size
3737 [ + + + - ]: 683299 : if (lmselect1(ilm).and.lmselect2(ilm)) then
3738 [ + + ]: 396430365 : sum1(:,1)=sum1(:,1)+rho1(:,ilm)*rho2(:,ilm)
3739 : : end if
3740 : : end do
3741 : : ! Three sums to compute
3742 : : else
3743 [ + + ]: 408382 : do ilm=2,lm_size
3744 [ + + ]: 381650 : if (lmselect1(ilm)) then
3745 [ + + ]: 234582406 : sum1(:,1)=sum1(:,1)+rho1(:,ilm)**2
3746 [ + + + + ]: 229769610 : if (lmselect2(ilm)) sum1(:,2)=sum1(:,2)+rho1(:,ilm)*rho2(:,ilm)
3747 : : end if
3748 [ + + + + ]: 233400432 : 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 [ + + ]: 105927 : 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 [ + + + + : 139762426 : sum2=zero
+ + ]
3798 : : ! ===== All input/output densities are REAL ====
3799 [ + - + + : 20338 : if (cplex1==1.and.cplex2==1.and.cplexsum==1) then
+ - ]
3800 : : ! One sum to compute
3801 [ + + ]: 18946 : if (nsums==1) then
3802 [ + + ]: 209968 : do ilm=1,lm_size
3803 [ + + ]: 2331856 : do ilm1=2,lm_size
3804 [ + + ]: 2313224 : if (lmselect1(ilm1)) then
3805 [ + + ]: 12990862 : do ilm2=2,ilm1
3806 [ + + ]: 12990862 : if (lmselect2(ilm2)) then
3807 : 9957250 : isel=pawang%gntselect(ilm,ilm2+ilm1*(ilm1-1)/2)
3808 [ + + ]: 9957250 : if (isel>0) then
3809 [ + + ]: 995530 : fact=pawang%realgnt(isel);if (ilm1/=ilm2) fact=two*fact
3810 [ + + ]: 529716444 : 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 : 105927 : 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 : 73249 : subroutine pawxcm(corexc,enxc,enxcdc,snxc,exexch,hyb_mixing,ixc,kxc,lm_size,lmselect,nhat,nkxc,&
4078 : 73249 : & non_magnetic_xc,nrad,nspden,option,pawang,pawrad,pawxcdev,rhor,&
4079 : 73249 : & 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 : 73249 : real(dp),allocatable :: d1kxc(:,:),d2kxc(:,:),d1vxc(:,:),d2vxc(:,:)
4108 : 73249 : real(dp),allocatable :: exc_(:),sxc_(:),exci(:),tsxci(:),ff(:),gg(:)
4109 : 73249 : real(dp),allocatable :: kxc1(:,:),kxc2(:,:),kxcdn1(:,:),kxcdn2(:,:),kxci(:,:)
4110 : 73249 : real(dp),allocatable :: m_norm_inv(:),rho_(:,:),rhoinv(:,:),rhosph(:,:)
4111 : 73249 : real(dp),allocatable :: v1sum(:,:),v2sum(:,:,:)
4112 : 73249 : real(dp),allocatable :: vxc1(:,:),vxc2(:,:),vxcdn1(:,:),vxcdn2(:,:),vxci(:,:)
4113 : 73249 : real(dp),allocatable,target :: rho_nc(:,:),rho_updn(:,:,:),vxc_diag(:,:),vxc_nc(:,:)
4114 : 73249 : real(dp), LIBPAW_CONTIGUOUS pointer :: mag_nc(:,:),rho_dn(:,:),rho_up(:,:)
4115 : :
4116 : : !************************************************************************
4117 : :
4118 : 73249 : if(nkxc>3) then
4119 : 0 : msg='Kxc not implemented for GGA! Use pawxcdev 0 '
4120 : 0 : LIBPAW_ERROR(msg)
4121 : : end if
4122 [ + + - + ]: 73249 : 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 [ + + ]: 73249 : if (option/=1.and.option/=5) then
4127 [ - + ]: 70546 : 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 [ - + - - : 73249 : 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 : 73249 : iwarn=0
4147 : 73249 : nspden_updn=min(nspden,2)
4148 : 73249 : sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi
4149 : 73249 : invsqfpi=one/sqfpi;invsqfpi2=half*invsqfpi
4150 : 73249 : nsums=2*nspden_updn-1
4151 : :
4152 : : !Initializations of output arrays
4153 [ + + ]: 73249 : if (option/=1.and.option/=5) then
4154 : 70546 : enxc=zero
4155 : 70546 : snxc=zero
4156 : : end if
4157 [ + + ]: 73249 : if (option==0.or.option==2) enxcdc=zero
4158 [ + + + + : 1088922361 : if (option/=3.and.option/=4) vxc(:,:,:)=zero
+ + + + ]
4159 [ + + + + : 1223813 : if (nkxc/=0) kxc(:,:,:)=zero
+ + + + ]
4160 : :
4161 [ + + - + ]: 73249 : 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 [ - + + - : 363775 : LIBPAW_ALLOCATE(rho_updn,(nrad,lm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
4176 [ + + + + : 1087140669 : rho_updn(:,:,:)=rhor(:,:,:)
+ + ]
4177 [ + + + + : 235433590 : if (usexcnhat==2) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:)
+ + + + ]
4178 : :
4179 : : !Optionally suppressed magnetic part
4180 [ + + ]: 72755 : 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 [ + + ]: 72755 : if (usecore==1) then
4187 [ + + ]: 56633 : if (nspden==1.or.nspden==4) then
4188 [ + + ]: 63939109 : rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:)
4189 [ + - ]: 6993 : else if (nspden==2) then
4190 [ + + ]: 5869933 : rho_updn(:,1,1)=rho_updn(:,1,1)+sqfpi*corexc(:)
4191 [ + + ]: 5869933 : 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 [ + + ]: 72755 : if (nspden==2) then
4197 [ - + + - : 30756 : LIBPAW_ALLOCATE(ff,(nrad))
+ - + - -
+ - + ]
4198 [ + + ]: 223786 : do ilm=1,lm_size
4199 [ + + ]: 145840085 : ff(:)=rho_updn(:,ilm,2)
4200 [ + + ]: 145840085 : rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:)
4201 [ + + ]: 145850337 : rho_updn(:,ilm,1)=ff(:)
4202 : : end do
4203 [ - + ]: 10252 : LIBPAW_DEALLOCATE(ff)
4204 : : end if
4205 : :
4206 : : !Direct links to rho_up and rho_dn
4207 : 72755 : rho_up => rho_updn(:,:,1)
4208 : 72755 : rho_dn => rho_updn(:,:,nspden_updn)
4209 : :
4210 : : !rhoSPH contains the spherical part of effective density
4211 : : !(including Y00 spherical harmonic)
4212 : : !-----------------------------------------------------------------
4213 [ - + + - : 291020 : LIBPAW_ALLOCATE(rhosph,(nrad,nspden_updn))
- + + - +
- + - - +
- + ]
4214 : :
4215 : : ! Non-magnetic system: rhoSPH(;,1)=(1/2).rhoSPH_total
4216 [ + + ]: 72755 : if (nspden==1) then
4217 [ + + ]: 84517271 : rhosph(:,1)=rho_updn(:,1,1)*invsqfpi2
4218 : :
4219 : : ! Collinear magnetism: rhoSPH = (rhoSPH_up, rhoSPH_dn)
4220 [ + + ]: 13050 : else if (nspden==2) then
4221 [ + + + + ]: 15648394 : 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 : 72755 : call pawxc_mkdenpos_wrapper(iwarn,nrad,nspden_updn,0,rhosph,xc_denpos)
4240 : :
4241 : : !----------------------------------------------------------------------
4242 : : !----- Compute Exc(rhoSPH) and Vxc(rhoSPH)
4243 : : !----------------------------------------------------------------------
4244 : :
4245 [ - + + - : 218265 : LIBPAW_ALLOCATE(exci,(nrad))
+ - + - -
+ - + ]
4246 [ - + + - : 145510 : LIBPAW_ALLOCATE(tsxci,(nrad))
- + - + ]
4247 [ - + + - : 218265 : LIBPAW_ALLOCATE(vxci,(nrad,nspden_updn))
- + + - -
+ - + ]
4248 [ - + + - : 291020 : LIBPAW_ALLOCATE(kxci,(nrad,nkxc))
+ + + - +
- + + - +
- + ]
4249 : 72755 : 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 [ + + ]: 72755 : if (option/=4.and.option/=5) then
4256 [ - + + - : 144410 : LIBPAW_ALLOCATE(exc_,(nrad))
- + - + ]
4257 [ - + + - : 144410 : LIBPAW_ALLOCATE(sxc_,(nrad))
- + - + ]
4258 [ - + + - : 216615 : LIBPAW_ALLOCATE(rho_,(nrad,nspden_updn))
- + + - -
+ - + ]
4259 : :
4260 [ + + + + ]: 10386125 : if (nspden_updn==2) rho_(:,2)=rhosph(:,2)
4261 : :
4262 : : ! Compute Exc, Vxc for rho+delta_rho
4263 [ - + + - : 216615 : LIBPAW_ALLOCATE(vxc1,(nrad,nspden_updn))
- + + - -
+ - + ]
4264 [ - + + - : 216615 : LIBPAW_ALLOCATE(kxc1,(nrad,nkxc))
+ + + - -
+ - + ]
4265 [ + + ]: 94261827 : rho_(:,1)=(one+delta)*rhosph(:,1)
4266 : 72205 : 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 [ - + + - : 216615 : LIBPAW_ALLOCATE(vxc2,(nrad,nspden_updn))
- + + - -
+ - + ]
4270 [ - + + - : 216615 : LIBPAW_ALLOCATE(kxc2,(nrad,nkxc))
+ + + - -
+ - + ]
4271 [ + + ]: 94261827 : rho_(:,1)=(one-delta)*rhosph(:,1)
4272 : 72205 : 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 [ + + ]: 72205 : if (nspden_updn==2) then
4276 [ + + ]: 10326924 : rho_(:,1)=rhosph(:,1)
4277 : :
4278 : : ! Compute Exc, Vxc for rho+delta_rho_down
4279 [ - + + - : 39012 : LIBPAW_ALLOCATE(vxcdn1,(nrad,nspden_updn))
- + + - -
+ - + ]
4280 [ - + + - : 39012 : LIBPAW_ALLOCATE(kxcdn1,(nrad,nkxc))
+ + + - -
+ - + ]
4281 [ + + ]: 10326924 : rho_(:,2)=(one+delta)*rhosph(:,2)
4282 : 13004 : 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 [ - + + - : 39012 : LIBPAW_ALLOCATE(vxcdn2,(nrad,nspden_updn))
- + + - -
+ - + ]
4286 [ - + + - : 39012 : LIBPAW_ALLOCATE(kxcdn2,(nrad,nkxc))
+ + + - -
+ - + ]
4287 [ + + ]: 10326924 : rho_(:,2)=(one-delta)*rhosph(:,2)
4288 : 13004 : 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 [ - + ]: 72205 : LIBPAW_DEALLOCATE(sxc_)
4292 [ - + ]: 72205 : LIBPAW_DEALLOCATE(exc_)
4293 [ - + ]: 72205 : LIBPAW_DEALLOCATE(rho_)
4294 : :
4295 : : ! Store inverse of density finite step
4296 [ - + + - : 216615 : LIBPAW_ALLOCATE(rhoinv,(nrad,nspden_updn))
- + + - -
+ - + ]
4297 [ + + ]: 72205 : fact=one/delta;if (nspden_updn==1) fact=half*fact
4298 [ + + ]: 157414 : do ispden=1,nspden_updn
4299 [ + + ]: 104660956 : do ir=1,nrad
4300 [ + + ]: 104588751 : if (rhosph(ir,ispden)>rho_min) then
4301 : 104498672 : 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 [ - + + - : 361025 : LIBPAW_ALLOCATE(d1vxc,(nrad,2*nspden_updn-1))
+ - - + +
- + - + -
- + - + ]
4310 : : ! Non-magnetic system: compute dVxc/dn
4311 [ + + ]: 72205 : if (nspden==1) then
4312 [ + + ]: 83934903 : 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 [ + + ]: 13004 : else if (nspden==2) then
4315 [ + + ]: 7746642 : d1vxc(1:nrad,1)=(vxc1(1:nrad,1)-vxc2(1:nrad,1))*half*rhoinv(1:nrad,1)
4316 [ + + ]: 7746642 : d1vxc(1:nrad,2)=(vxc1(1:nrad,2)-vxc2(1:nrad,2))*half*rhoinv(1:nrad,1)
4317 [ + + ]: 7746642 : 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 [ - + - - ]: 72205 : if (option/=3.or.pawxcdev>=2) then
4336 [ - + + - : 288820 : LIBPAW_ALLOCATE(d2vxc,(nrad,3*nspden_updn-2))
+ - - + +
- + - + -
- + - + ]
4337 : : ! Non-magnetic system: compute d2Vxc/dn2
4338 [ + + ]: 72205 : if (nspden==1) then
4339 [ + + ]: 83934903 : 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 [ + + ]: 13004 : else if (nspden==2) then
4342 [ + + ]: 7746642 : d2vxc(1:nrad,1)=(vxc1(1:nrad,1)+vxc2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,1)**2
4343 [ + + ]: 7746642 : d2vxc(1:nrad,2)=(vxc1(1:nrad,2)+vxc2(1:nrad,2)-two*vxci(1:nrad,2))*rhoinv(1:nrad,1)**2
4344 [ + + ]: 7746642 : d2vxc(1:nrad,3)=(vxcdn1(1:nrad,1)+vxcdn2(1:nrad,1)-two*vxci(1:nrad,1))*rhoinv(1:nrad,2)**2
4345 [ + + ]: 7746642 : 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 [ + + ]: 72205 : if (nkxc>0) then
4368 : : ! Non-magnetic system: compute dKxc/dn, d2Kxc/dn2
4369 [ + + ]: 134 : 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 [ + - ]: 8 : else if (nspden==2) then
4377 [ - + + - : 24 : LIBPAW_ALLOCATE(d1kxc,(nrad,4))
+ - + - -
+ - + ]
4378 [ - + + - : 24 : LIBPAW_ALLOCATE(d2kxc,(nrad,5))
+ - + - -
+ - + ]
4379 [ + + ]: 2808 : d1kxc(1:nrad,1)=(kxc1(1:nrad,1)-kxc2(1:nrad,1))*half*rhoinv(1:nrad,1) ! dKxc_upup/dn_up
4380 [ + + ]: 2808 : d1kxc(1:nrad,2)=(kxc1(1:nrad,2)-kxc2(1:nrad,2))*half*rhoinv(1:nrad,1) ! dKxc_updn/dn_up
4381 [ + + ]: 2808 : d1kxc(1:nrad,3)=(kxc1(1:nrad,3)-kxc2(1:nrad,3))*half*rhoinv(1:nrad,1) ! dKxc_dndn/dn_up
4382 [ + + ]: 2808 : d1kxc(1:nrad,4)=(kxcdn1(1:nrad,3)-kxcdn2(1:nrad,3))*half*rhoinv(1:nrad,2) ! dKxc_dndn/dn_dn
4383 [ + + ]: 2808 : 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 [ + + ]: 2808 : 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 [ + + ]: 2808 : 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 [ + + ]: 2808 : 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 [ + + ]: 2808 : 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 [ - + ]: 72205 : LIBPAW_DEALLOCATE(rhoinv)
4392 [ - + ]: 72205 : LIBPAW_DEALLOCATE(vxc1)
4393 [ - + ]: 72205 : LIBPAW_DEALLOCATE(vxc2)
4394 [ - + ]: 72205 : LIBPAW_DEALLOCATE(kxc1)
4395 [ - + ]: 72205 : LIBPAW_DEALLOCATE(kxc2)
4396 [ + + ]: 72205 : if (nspden_updn==2) then
4397 [ - + ]: 13004 : LIBPAW_DEALLOCATE(vxcdn1)
4398 [ - + ]: 13004 : LIBPAW_DEALLOCATE(vxcdn2)
4399 [ - + ]: 13004 : LIBPAW_DEALLOCATE(kxcdn1)
4400 [ - + ]: 13004 : LIBPAW_DEALLOCATE(kxcdn2)
4401 : : end if
4402 : :
4403 : : end if ! (option/=4 and option/=5)
4404 : :
4405 [ - + ]: 72755 : LIBPAW_DEALLOCATE(rhosph)
4406 : :
4407 : : !If non-collinear magnetism, store 1/2(Vxc_up+Vxc_dn) and 1/2(Vxc_up-Vxc_dn)
4408 [ + + ]: 72755 : 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 [ + + ]: 72755 : if (option/=4.and.option/=5) then
4418 : :
4419 : : ! Non-collinear magnetism: replace rho_dn by (m_0.dot.m)/|m_0|
4420 [ + + ]: 72205 : 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 [ + - ]: 72205 : if (pawxcdev>=1) then
4452 [ - + + - : 288820 : LIBPAW_ALLOCATE(v1sum,(nrad,nsums))
- + + - +
- + - - +
- + ]
4453 : : else
4454 [ # # ]: 0 : LIBPAW_ALLOCATE(v1sum,(0,0))
4455 : : end if
4456 [ + + ]: 72205 : if (pawxcdev>=2) then
4457 [ - + + - : 1720 : LIBPAW_ALLOCATE(v2sum,(nrad,lm_size,nsums))
- + + - -
+ + - + -
+ - - + -
+ ]
4458 : : else
4459 [ - + ]: 71861 : LIBPAW_ALLOCATE(v2sum,(0,0,0))
4460 : : end if
4461 : : call pawxcsum(1,1,1,lmselect,lmselect,lm_size,nrad,nsums,pawxcdev,pawang,&
4462 : 72205 : & rho_up,rho_dn,v1sum,v2sum)
4463 : :
4464 : : end if !option
4465 : :
4466 : : !----------------------------------------------------------------------
4467 : : !----- Accumulate and store XC potential
4468 : : !----------------------------------------------------------------------
4469 : :
4470 [ + + ]: 72755 : if (option/=3.and.option/=4) then
4471 : :
4472 : : ! === First order development
4473 : : ! ---------------------------
4474 [ + - ]: 72249 : if (pawxcdev>=1) then
4475 : :
4476 : : ! Non-magnetic system
4477 [ + + ]: 72249 : if (nspden_updn==1) then
4478 [ + + ]: 83957467 : vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi
4479 [ + + ]: 59241 : if (option/=5) then
4480 [ + + ]: 83934903 : vxc(1:nrad,1,1)=vxc(1:nrad,1,1)+v1sum(1:nrad,1)*d2vxc(1:nrad,1)*invsqfpi2
4481 [ + + ]: 492233 : do ilm=2,lm_size
4482 [ + + ]: 492233 : if (lmselect(ilm)) then
4483 [ + + ]: 329947297 : 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 [ + - ]: 13008 : else if (nspden_updn==2) then
4490 [ + + ]: 10332256 : vxc(1:nrad,1,1)=vxci(1:nrad,1)*sqfpi
4491 [ + + ]: 10332256 : vxc(1:nrad,1,2)=vxci(1:nrad,2)*sqfpi
4492 [ + + ]: 13008 : 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 [ + + ]: 10326924 : & +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 [ + + ]: 10326924 : & +two*v1sum(1:nrad,2)*d2vxc(1:nrad,3)+v1sum(1:nrad,3)*d2vxc(1:nrad,4))
4497 [ + + ]: 284830 : do ilm=2,lm_size
4498 [ + + ]: 284830 : if (lmselect(ilm)) then
4499 : : vxc(1:nrad,ilm,1)=vxc(1:nrad,ilm,1) &
4500 [ + + ]: 131265504 : & +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 [ + + ]: 131265504 : & +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 [ + + + - ]: 72249 : 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 [ + - ]: 72249 : if (lmselect(1)) then
4533 : 72249 : tol_rho=xc_denpos*(one+tol6)
4534 [ + + ]: 157506 : do ispden=1,nspden_updn
4535 : : ir1=0;ir2=0
4536 [ + + ]: 104694228 : do ir=1,nrad
4537 [ + + ]: 104621979 : if (rho_updn(ir,1,ispden)<tol_rho) then
4538 [ + + ]: 1232475 : if (ir1==0) ir1=ir-1
4539 : 1232475 : ir2=ir+1
4540 [ + + ]: 103304247 : 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 [ + + ]: 72249 : 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 [ + + ]: 72755 : if (nkxc>0) then
4576 : :
4577 : : ! === First order development
4578 : : ! ---------------------------
4579 [ + - ]: 134 : if (pawxcdev>=1) then
4580 : : ! Non-magnetic system:
4581 [ + + ]: 134 : 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 [ + - ]: 8 : else if (nspden==2) then
4593 [ + + ]: 2808 : kxc(1:nrad,1,1)=kxci(1:nrad,1)*sqfpi
4594 [ + + ]: 2808 : kxc(1:nrad,1,2)=kxci(1:nrad,2)*sqfpi
4595 [ + + ]: 2808 : kxc(1:nrad,1,3)=kxci(1:nrad,3)*sqfpi
4596 [ + - ]: 8 : 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 [ + + ]: 2808 : & +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 [ + + ]: 2808 : & +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 [ + + ]: 2808 : & +two*v1sum(1:nrad,2)*d2kxc(1:nrad,4)+v1sum(1:nrad,3)*d2kxc(1:nrad,5))
4603 [ + + ]: 136 : do ilm=2,lm_size
4604 [ + + ]: 136 : if (lmselect(ilm)) then
4605 : : kxc(1:nrad,ilm,1)=kxc(1:nrad,ilm,1) &
4606 [ + + ]: 29484 : & +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 [ + + ]: 29484 : & +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 [ + + ]: 29484 : & +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 [ - + - - : 134 : 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 [ + - ]: 134 : if (lmselect(1)) then
4644 : 134 : tol_rho=xc_denpos*(one+tol6)
4645 [ + + ]: 276 : do ispden=1,nspden_updn
4646 : : ir1=0;ir2=0
4647 [ + + ]: 91436 : do ir=1,nrad
4648 [ - + ]: 91302 : if (rho_updn(ir,1,ispden)<tol_rho) then
4649 [ # # ]: 0 : if (ir1==0) ir1=ir-1
4650 : 0 : ir2=ir+1
4651 [ - + ]: 91160 : 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 [ - + ]: 134 : 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 [ + + ]: 72755 : if (nspden==4) then
4676 [ - + ]: 2798 : LIBPAW_DEALLOCATE(rho_nc)
4677 [ - + ]: 2798 : LIBPAW_DEALLOCATE(m_norm_inv)
4678 : : end if
4679 : :
4680 [ - + ]: 72755 : LIBPAW_DEALLOCATE(kxci)
4681 [ + + + - : 72755 : if (nkxc>0.and.option/=4.and.option/=5) then
+ - ]
4682 [ - + ]: 134 : LIBPAW_DEALLOCATE(d1kxc)
4683 [ - + ]: 134 : LIBPAW_DEALLOCATE(d2kxc)
4684 : : end if
4685 : :
4686 : : !----------------------------------------------------------------------
4687 : : !----- Accumulate and store XC energies
4688 : : !----------------------------------------------------------------------
4689 : :
4690 : : !----- Calculate Exc (direct scheme) term
4691 : : !----------------------------------------
4692 [ + + ]: 72755 : if (option/=1.and.option/=5) then
4693 [ - + + - : 140592 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + -
+ ]
4694 : :
4695 : : ! Contribution from spherical part of rho
4696 [ + + ]: 70296 : if (nspden==1.or.nspden==4) then
4697 [ + + ]: 86026904 : ff(1:nrad)=rho_updn(1:nrad,1,1)*exci(1:nrad)*sqfpi
4698 [ + - ]: 9384 : else if (nspden==2) then
4699 [ + + ]: 7203469 : 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 [ + + ]: 70296 : if (option/=4) then
4704 : :
4705 : : ! First order development
4706 [ + - ]: 69790 : if (pawxcdev>=1) then
4707 [ + + ]: 69790 : if (nspden_updn==1) then
4708 [ + + ]: 82974878 : ff(1:nrad)=ff(1:nrad)+half*v1sum(1:nrad,1)*d1vxc(1:nrad,1)
4709 [ + - ]: 11992 : else if (nspden_updn==2) then
4710 : : ff(1:nrad)=ff(1:nrad)+v1sum(1:nrad,2)*d1vxc(1:nrad,2) &
4711 [ + + ]: 9628594 : & +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 [ + + ]: 69790 : 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 [ + + ]: 93230373 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
4756 : 70296 : call simp_gen(enxc,ff,pawrad)
4757 [ - + ]: 70296 : LIBPAW_DEALLOCATE(ff)
4758 : : end if ! option/=1 and option/=5
4759 : :
4760 : : !----- Calculate Sxc term (using Exc as a model)
4761 : : !----------------------------------------
4762 [ + + + + : 94905604 : 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 [ - + ]: 72755 : LIBPAW_DEALLOCATE(tsxci)
4832 [ - + ]: 72755 : LIBPAW_DEALLOCATE(exci)
4833 [ - + ]: 72755 : LIBPAW_DEALLOCATE(vxci)
4834 [ + + + - : 72755 : if (nspden==4.and.option/=4.and.option/=5) then
+ - ]
4835 [ - + ]: 2798 : LIBPAW_POINTER_DEALLOCATE(rho_dn)
4836 : : end if
4837 [ + + ]: 72755 : if (allocated(v1sum)) then
4838 : 72205 : LIBPAW_DEALLOCATE(v1sum)
4839 : : end if
4840 [ + + ]: 72755 : if (allocated(v2sum)) then
4841 : 72205 : LIBPAW_DEALLOCATE(v2sum)
4842 : : end if
4843 [ + + ]: 72755 : if (allocated(d1vxc)) then
4844 : 72205 : LIBPAW_DEALLOCATE(d1vxc)
4845 : : end if
4846 [ + + ]: 72755 : if (allocated(d2vxc)) then
4847 : 72205 : LIBPAW_DEALLOCATE(d2vxc)
4848 : : end if
4849 : :
4850 : : !----- Calculate Excdc double counting term
4851 : : !------------------------------------------
4852 [ + + ]: 72755 : if (option==0.or.option==2) then
4853 : :
4854 [ - + + - : 139580 : LIBPAW_ALLOCATE(ff,(nrad))
- + - + -
+ ]
4855 : :
4856 : : ! Build appropriate density (without core density)
4857 [ + + + + : 1031506802 : rho_updn(:,:,:)=rhor(:,:,:)
+ + ]
4858 [ + + + + : 209550178 : if (usexcnhat>0) rho_updn(:,:,:)=rho_updn(:,:,:)+nhat(:,:,:)
+ + + + ]
4859 [ + + ]: 69790 : if (nspden==2) then
4860 [ + + ]: 201358 : do ilm=1,lm_size
4861 [ + + ]: 130622362 : ff(:)=rho_updn(:,ilm,2)
4862 [ + + ]: 130622362 : rho_updn(:,ilm,2)=rho_updn(:,ilm,1)-ff(:)
4863 [ + + ]: 130631704 : rho_updn(:,ilm,1)=ff(:)
4864 : : end do
4865 : : end if
4866 : :
4867 [ + + ]: 92603472 : ff(1:nrad)=zero
4868 : :
4869 : : ! Non magnetic or collinear magnetic system:
4870 [ + + ]: 69790 : if (nspden/=4) then
4871 [ + + ]: 143622 : do ispden=1,nspden_updn
4872 [ + + ]: 998572 : do ilm=1,lm_size
4873 [ + + + + ]: 561318116 : 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 [ + + ]: 92603472 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
4890 : 69790 : call simp_gen(enxcdc,ff,pawrad)
4891 [ - + ]: 69790 : LIBPAW_DEALLOCATE(ff)
4892 : :
4893 : : end if ! option
4894 : :
4895 [ - + ]: 72755 : LIBPAW_DEALLOCATE(rho_updn)
4896 : :
4897 [ - + - + : 146498 : 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 : 34970 : subroutine pawxcm_dfpt(corexc1,cplex_den,cplex_vxc,d2enxc,ixc,kxc,lm_size,lmselect,nhat1,&
4951 : 34970 : & nkxc,non_magnetic_xc,nrad,nspden,option,pawang,pawrad,rhor1,usecore,&
4952 : 34970 : & 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 : 34970 : real(dp),allocatable :: ff(:),gg(:),rho1_updn(:,:,:)
4982 : 34970 : real(dp),allocatable :: v1sum(:),v2sum(:,:)
4983 : 34970 : 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 : 34970 : if(option<0.or.option>3) then
4996 : 0 : msg='wrong option!'
4997 : 0 : LIBPAW_BUG(msg)
4998 : : end if
4999 [ + + ]: 34970 : if(option/=3) then
5000 : 18026 : call pawxc_get_nkxc(nkxc_cur,nspden,xclevel)
5001 [ - + ]: 18026 : 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 [ - + - - ]: 34970 : 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 [ + + ]: 34970 : if (option/=1) then
5011 [ - + ]: 25578 : 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 : 34970 : need_impart=present(d2enxc_im)
5023 : 34970 : sqfpi=sqrt(four_pi);sqfpi2=half*sqfpi;invsqfpi=one/sqfpi
5024 : :
5025 : : !Initializations of outputs
5026 [ + + ]: 34970 : if (option/=1) then
5027 : 25578 : d2enxc=zero
5028 [ + + ]: 25578 : if (need_impart) d2enxc_im=zero
5029 : : end if
5030 [ + + + + : 55491634 : if (option<=1) vxc1(:,:,:)=zero
+ + + + ]
5031 : :
5032 : : !Special case: no XC applied
5033 [ + - + + : 34970 : 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 [ - + + - : 174850 : LIBPAW_ALLOCATE(rho1_updn,(cplex_den*nrad,lm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
5047 [ + + + + : 197098690 : rho1_updn(:,:,:)=rhor1(:,:,:)
+ + ]
5048 [ + + + + : 68821036 : if (usexcnhat==2) rho1_updn(:,:,:)=rho1_updn(:,:,:)+nhat1(:,:,:)
+ + + + ]
5049 [ - + ]: 34970 : 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 [ - + ]: 34970 : 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 [ + + ]: 34970 : if (nspden==2) then
5066 [ - + + - : 2544 : LIBPAW_ALLOCATE(ff,(cplex_den*nrad))
+ - + - -
+ - + ]
5067 [ + + ]: 15264 : do ilm=1,lm_size
5068 [ + + ]: 5060016 : ff(:)=rho1_updn(:,ilm,2)
5069 [ + + ]: 5060016 : rho1_updn(:,ilm,2)=rho1_updn(:,ilm,1)-ff(:)
5070 [ + + ]: 5060864 : rho1_updn(:,ilm,1)=ff(:)
5071 : : end do
5072 [ - + ]: 848 : LIBPAW_DEALLOCATE(ff)
5073 : : end if
5074 : :
5075 : : !
5076 : : !----------------------------------------------------------------------
5077 : : !----- Accumulate and store 1st-order change of XC potential
5078 : : !----------------------------------------------------------------------
5079 : :
5080 [ + + ]: 34970 : if (option==2) then
5081 [ - + + - : 43170 : LIBPAW_POINTER_ALLOCATE(vxc1_,(cplex_vxc*nrad,lm_size,nspden))
- + + - -
+ + - + -
+ - - + -
+ ]
5082 : : else
5083 : 26336 : vxc1_ => vxc1
5084 : : end if
5085 : :
5086 [ + + ]: 34970 : if (option/=3) then
5087 : :
5088 [ + + + + : 106453636 : vxc1_=zero
+ + ]
5089 [ - + + - : 54078 : LIBPAW_ALLOCATE(v1sum,(cplex_vxc*nrad))
+ - + - -
+ - + ]
5090 [ - + + - : 72104 : LIBPAW_ALLOCATE(v2sum,(cplex_vxc*nrad,lm_size))
- + + - +
- + - - +
- + ]
5091 : :
5092 [ + + ]: 38020 : do ii=1,3*nspden-2
5093 [ + + ]: 19994 : ivxc=1;if (ii>2) ivxc=2
5094 : :
5095 : : ! === Vxc1 and Rho1 are REAL
5096 [ + + + - ]: 38020 : 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 : 18602 : & kxc(:,:,ikxc(ii)),rho1_updn(:,:,irho(ii)),v1sum,v2sum)
5099 [ + + ]: 10184144 : vxc1_(:,1,ivxc)=vxc1_(:,1,ivxc)+invsqfpi*(v1sum(:)+kxc(:,1,ikxc(ii))*rho1_updn(:,1,irho(ii)))
5100 [ + + ]: 191066 : 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 [ + + ]: 91940458 : & +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 [ - + ]: 18026 : LIBPAW_DEALLOCATE(v1sum)
5127 [ - + ]: 18026 : LIBPAW_DEALLOCATE(v2sum)
5128 : :
5129 : : end if
5130 : :
5131 : : !----------------------------------------------------------------------
5132 : : !----- Accumulate and store 2nd-order change of XC energy
5133 : : !----------------------------------------------------------------------
5134 [ + + ]: 34970 : if (option/=1) then
5135 : :
5136 [ + - ]: 25578 : if (.not.non_magnetic_xc) then
5137 : : ! For usexnhat=1 particular case, add now compensation density
5138 [ - + ]: 25578 : 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 [ - + + - : 76734 : LIBPAW_ALLOCATE(ff,(nrad))
+ - + - -
+ - + -
+ ]
5157 [ + + ]: 14373014 : ff=zero
5158 [ + + ]: 25578 : if (need_impart) then
5159 [ - + + - : 33888 : LIBPAW_ALLOCATE(gg,(nrad))
- + - + ]
5160 [ + + ]: 9499502 : gg=zero
5161 : : end if
5162 : :
5163 : : ! ----- Calculate d2Exc=Int[Vxc^(1)^*(r).n^(1)(r).dr]
5164 [ + + ]: 51668 : do ii=1,nspden
5165 : : ! === Vxc1 and Rho1 are REAL
5166 [ + + + - ]: 51668 : if (cplex_vxc==1.and.cplex_den==1) then
5167 [ + + ]: 261364 : do ilm=1,lm_size
5168 [ + + + + ]: 79920166 : 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 [ + + ]: 14373014 : ff(1:nrad)=ff(1:nrad)*pawrad%rad(1:nrad)**2
5211 : 25578 : call simp_gen(vxcrho,ff,pawrad)
5212 : 25578 : d2enxc=d2enxc+vxcrho
5213 [ - + ]: 25578 : LIBPAW_DEALLOCATE(ff)
5214 : :
5215 [ + + ]: 51156 : if (need_impart) then
5216 [ + + ]: 9499502 : gg(1:nrad)=gg(1:nrad)*pawrad%rad(1:nrad)**2
5217 : 16944 : call simp_gen(vxcrho,gg,pawrad)
5218 : 16944 : d2enxc_im=d2enxc_im+vxcrho
5219 [ - + ]: 16944 : LIBPAW_DEALLOCATE(gg)
5220 : : end if
5221 : :
5222 : : end if
5223 : :
5224 [ - + ]: 34970 : LIBPAW_DEALLOCATE(rho1_updn)
5225 [ + + ]: 34970 : if (option==2) then
5226 [ - + ]: 8634 : LIBPAW_POINTER_DEALLOCATE(vxc1_)
5227 : : end if
5228 : :
5229 [ - + - + : 69940 : 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 : 24374 : 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 : 24374 : nkxc=0
5803 : :
5804 [ + + ]: 24374 : if (nspden==1) then ! Non polarized
5805 : :
5806 [ + + ]: 19367 : if (xclevel==1) nkxc=1
5807 [ + + ]: 19367 : if (xclevel==2) nkxc=7
5808 : :
5809 [ + - ]: 5007 : else if (nspden==2) then ! Polarized
5810 : :
5811 [ + + ]: 5007 : if (xclevel==1) nkxc=3
5812 [ + + ]: 5007 : 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 : 24374 : 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 : 538320 : subroutine pawxc_drivexc_wrapper(hyb_mixing,ixc,order,npts,nspden,usegradient,uselaplacian,usekden,&
5844 : 538320 : & 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 : 538320 : 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 : 538320 : subroutine pawxc_drivexc_abinit()
5897 : :
5898 : : logical :: test_args
5899 : :
5900 : : ! *************************************************************************
5901 : :
5902 : 538320 : test_args=present(dvxc)
5903 [ + + ]: 538320 : if (nd2vxc>0) test_args=(test_args.and.present(d2vxc))
5904 [ + + + - : 538320 : if (usegradient==1) test_args=(test_args.and.present(grho2).and.present(vxcgrho))
- + ]
5905 [ + + + - : 538320 : if (uselaplacian==1) test_args=(test_args.and.present(lrho).and.present(vxclrho))
- + ]
5906 [ + + + - : 538320 : if (usekden==1) test_args=(test_args.and.present(tau).and.present(vxctau))
- + ]
5907 [ - + ]: 387298 : 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 [ + + + + ]: 538320 : 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 [ + + ]: 387298 : else if (usegradient==1) then
5934 [ + + ]: 113736 : 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 : 75085 : & 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 : 273562 : & dvxc=dvxc,d2vxc=d2vxc,hyb_mixing=hyb_mixing)
5950 : : end if
5951 : :
5952 : 538320 : 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 : : !!***
|
